/[gcl]/gcl/cmpnew/gcl_cmpcatch.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpcatch.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
1    ;;; CMPCATCH  Catch, Unwind-protect, and Throw.
2    ;;;
3    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4    
5    ;; This file is part of GNU Common Lisp, herein referred to as GCL
6    ;;
7    ;; GCL is free software; you can redistribute it and/or modify it under
8    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9    ;; the Free Software Foundation; either version 2, or (at your option)
10    ;; any later version.
11    ;;
12    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
13    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
15    ;; License for more details.
16    ;;
17    ;; You should have received a copy of the GNU Library General Public License
18    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
19    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20    
21    
22    (in-package 'compiler)
23    
24    (si:putprop 'catch 'c1catch 'c1special)
25    (si:putprop 'catch 'c2catch 'c2)
26    (si:putprop 'unwind-protect 'c1unwind-protect 'c1special)
27    (si:putprop 'unwind-protect 'c2unwind-protect 'c2)
28    (si:putprop 'throw 'c1throw 'c1special)
29    (si:putprop 'throw 'c2throw 'c2)
30    
31    (defun c1catch (args &aux (info (make-info :sp-change t)) tag)
32      (incf *setjmps*)
33      (when (endp args) (too-few-args 'catch 1 0))
34      (setq tag (c1expr (car args)))
35      (add-info info (cadr tag))
36      (setq args (c1progn (cdr args)))
37      (add-info info (cadr args))
38      (list 'catch info tag args))
39    
40    (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc)
41    
42    (defun c2catch (tag body &aux (*vs* *vs*))
43      (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag))
44      (wt-nl "if(nlj_active)")
45      (wt-nl "{nlj_active=FALSE;frs_pop();")
46      (unwind-exit 'fun-val 'jump)
47      (wt "}")
48      (wt-nl "else{")
49      (let ((*unwind-exit* (cons 'frame *unwind-exit*)))
50           (c2expr body))
51      (wt "}")
52      )
53    
54    (defun set-push-catch-frame (loc)
55      (wt-nl "frs_push(FRS_CATCH," loc ");"))
56    
57    (defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form)
58      (incf *setjmps*)
59      (when (endp args) (too-few-args 'unwind-protect 1 0))
60      (setq form (let ((*blocks* (cons 'lb *blocks*))
61                       (*tags* (cons 'lb *tags*))
62                       (*vars* (cons 'lb *vars*)))
63                      (c1expr (car args))))
64      (add-info info (cadr form))
65      (setq args (c1progn (cdr args)))
66      (add-info info (cadr args))
67      (list 'unwind-protect info form args)
68      )
69    
70    (defun c2unwind-protect (form body
71                             &aux (*vs* *vs*) (loc (list 'vs (vs-push)))
72                             top-data)
73      ;;;  exchanged following two lines to eliminate setjmp clobbering warning
74      (wt-nl "frs_push(FRS_PROTECT,Cnil);")
75      (wt-nl "{object tag=Cnil;frame_ptr fr=NULL;object p;bool active;")
76      (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}")
77      (wt-nl "else{")
78      (let ((*value-to-go* 'top)
79            *top-data* )
80        (c2expr* form)
81        (setq top-data *top-data*))
82      (wt-nl "active=FALSE;}")
83      (wt-nl loc "=Cnil;")
84      (wt-nl "while(vs_base<vs_top)")
85      (wt-nl "{" loc "=MMcons(vs_top[-1]," loc ");vs_top--;}")
86      (wt-nl) (reset-top)
87      (wt-nl "nlj_active=FALSE;frs_pop();")
88      (let ((*value-to-go* 'trash)) (c2expr* body))
89      (wt-nl "vs_base=vs_top=base+" *vs* ";")
90      (base-used)
91      (wt-nl "for(p= " loc ";!endp(p);p=MMcdr(p))vs_push(MMcar(p));")
92      (wt-nl "if(active)unwind(fr,tag);else{")
93      (unwind-exit 'fun-val nil (if top-data (car top-data)))
94      (wt "}}")
95      )
96    
97    (defun c1throw (args &aux (info (make-info)) tag)
98      (when (or (endp args) (endp (cdr args)))
99            (too-few-args 'throw 2 (length args)))
100      (unless (endp (cddr args))
101              (too-many-args 'throw 2 (length args)))
102      (setq tag (c1expr (car args)))
103      (add-info info (cadr tag))
104      (setq args (c1expr (cadr args)))
105      (add-info info (cadr args))
106      (list 'throw info tag args)
107      )
108    
109    (defun c2throw (tag val &aux (*vs* *vs*) loc)
110      (wt-nl "{frame_ptr fr;")
111      (case (car tag)
112        (LOCATION (setq loc (caddr tag)))
113        (VAR  (setq loc (cons 'var (third tag))))  
114        (t (setq loc (list 'vs (vs-push)))
115           (let ((*value-to-go* loc)) (c2expr* tag))))
116    
117      (wt-nl "fr=frs_sch_catch(" loc ");")
118      (wt-nl "if(fr==NULL) FEerror(\"The tag ~s is undefined.\",1," loc ");")
119      (let ((*value-to-go* 'top)) (c2expr* val))
120      (wt-nl "unwind(fr," loc ");}")
121    ;  (wt-nl "return Cnil;}")
122      )
123    
124    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26