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 |
|
|