Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* Copyright (C) 1995,1996 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
41 | \f | |
42 | ||
43 | #include <stdio.h> | |
44 | #include "_scm.h" | |
20e6290e JB |
45 | #include "genio.h" |
46 | #include "smob.h" | |
47 | #include "alist.h" | |
48 | #include "eval.h" | |
49 | #include "dynwind.h" | |
50 | #ifdef DEBUG_EXTENSIONS | |
51 | #include "debug.h" | |
52 | #endif | |
53 | #include "continuations.h" | |
7f759d79 | 54 | #include "stackchk.h" |
0f2d19dd | 55 | |
20e6290e | 56 | #include "throw.h" |
0f2d19dd | 57 | |
32f7b3a1 | 58 | \f |
0f2d19dd JB |
59 | /* {Catch and Throw} |
60 | */ | |
61 | static int scm_tc16_jmpbuffer; | |
62 | ||
0f2d19dd JB |
63 | #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) |
64 | #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) | |
65 | #define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L)) | |
66 | #define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L)) | |
e68b42c1 MD |
67 | #define JBLAZY (1L << 17L) |
68 | #define JBLAZYP(O) (SCM_CAR (O) & JBLAZY) | |
0f2d19dd | 69 | |
e137c6b3 MD |
70 | #ifndef DEBUG_EXTENSIONS |
71 | #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) | |
72 | #define SETJBJMPBUF SCM_SETCDR | |
73 | #else | |
08b5b88c | 74 | #define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) |
0f2d19dd | 75 | #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) |
08b5b88c | 76 | #define SCM_SETJBDFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X) |
0f2d19dd | 77 | #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) |
e137c6b3 | 78 | |
32f7b3a1 JB |
79 | static scm_sizet freejb SCM_P ((SCM jbsmob)); |
80 | ||
faa6b3df | 81 | static scm_sizet |
e137c6b3 MD |
82 | freejb (jbsmob) |
83 | SCM jbsmob; | |
e137c6b3 MD |
84 | { |
85 | scm_must_free ((char *) SCM_CDR (jbsmob)); | |
86 | return sizeof (scm_cell); | |
87 | } | |
0f2d19dd JB |
88 | #endif |
89 | ||
32f7b3a1 | 90 | static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); |
0f2d19dd | 91 | static int |
9882ea19 | 92 | printjb (exp, port, pstate) |
0f2d19dd JB |
93 | SCM exp; |
94 | SCM port; | |
9882ea19 | 95 | scm_print_state *pstate; |
0f2d19dd JB |
96 | { |
97 | scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); | |
e68b42c1 MD |
98 | scm_gen_puts (scm_regular_string, JBACTIVE (exp) ? "(active" : "(inactive", port); |
99 | if (JBLAZYP (exp)) | |
100 | scm_gen_puts (scm_regular_string, ", lazy", port); | |
101 | scm_gen_puts (scm_regular_string, ") ", port); | |
0f2d19dd JB |
102 | scm_intprint((SCM) JBJMPBUF(exp), 16, port); |
103 | scm_gen_putc ('>', port); | |
104 | return 1 ; | |
105 | } | |
106 | ||
e137c6b3 MD |
107 | static scm_smobfuns jbsmob = { |
108 | scm_mark0, | |
109 | #ifdef DEBUG_EXTENSIONS | |
110 | freejb, | |
111 | #else | |
112 | scm_free0, | |
113 | #endif | |
114 | printjb, | |
115 | 0 | |
116 | }; | |
0f2d19dd | 117 | |
e68b42c1 | 118 | static SCM make_jmpbuf SCM_P ((int lazyp)); |
0f2d19dd | 119 | static SCM |
e68b42c1 | 120 | make_jmpbuf (int lazyp) |
0f2d19dd JB |
121 | { |
122 | SCM answer; | |
123 | SCM_NEWCELL (answer); | |
7f759d79 | 124 | SCM_REDEFER_INTS; |
0f2d19dd | 125 | { |
e137c6b3 MD |
126 | #ifdef DEBUG_EXTENSIONS |
127 | char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); | |
128 | SCM_SETCDR (answer, (SCM) mem); | |
129 | #endif | |
e68b42c1 MD |
130 | SCM_CAR (answer) = scm_tc16_jmpbuffer | (lazyp ? JBLAZY : 0); |
131 | SETJBJMPBUF (answer, (jmp_buf *) 0); | |
132 | DEACTIVATEJB (answer); | |
0f2d19dd | 133 | } |
7f759d79 | 134 | SCM_REALLOW_INTS; |
0f2d19dd JB |
135 | return answer; |
136 | } | |
137 | ||
0f2d19dd JB |
138 | struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ |
139 | { | |
140 | jmp_buf buf; /* must be first */ | |
141 | SCM throw_tag; | |
142 | SCM retval; | |
143 | }; | |
144 | ||
0f2d19dd | 145 | SCM |
e68b42c1 | 146 | scm_catch_apply (tag, proc, a1, args, handler, lazyp) |
0f2d19dd | 147 | SCM tag; |
e68b42c1 MD |
148 | SCM proc; |
149 | SCM a1; | |
150 | SCM args; | |
0f2d19dd | 151 | SCM handler; |
e68b42c1 | 152 | int lazyp; |
0f2d19dd JB |
153 | { |
154 | struct jmp_buf_and_retval jbr; | |
155 | SCM jmpbuf; | |
156 | SCM answer; | |
157 | ||
e68b42c1 | 158 | jmpbuf = make_jmpbuf (lazyp); |
0f2d19dd JB |
159 | answer = SCM_EOL; |
160 | scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); | |
161 | SETJBJMPBUF(jmpbuf, &jbr.buf); | |
162 | #ifdef DEBUG_EXTENSIONS | |
e68b42c1 | 163 | SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); |
0f2d19dd JB |
164 | #endif |
165 | if (setjmp (jbr.buf)) | |
166 | { | |
167 | SCM throw_tag; | |
168 | SCM throw_args; | |
169 | ||
7f759d79 MD |
170 | #ifdef STACK_CHECKING |
171 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; | |
172 | #endif | |
173 | SCM_REDEFER_INTS; | |
0f2d19dd JB |
174 | DEACTIVATEJB (jmpbuf); |
175 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 176 | SCM_REALLOW_INTS; |
0f2d19dd JB |
177 | throw_args = jbr.retval; |
178 | throw_tag = jbr.throw_tag; | |
179 | jbr.throw_tag = SCM_EOL; | |
180 | jbr.retval = SCM_EOL; | |
181 | answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL); | |
182 | } | |
183 | else | |
184 | { | |
185 | ACTIVATEJB (jmpbuf); | |
e68b42c1 MD |
186 | if (tag == SCM_BOOL_F) |
187 | answer = scm_apply (proc, | |
188 | SCM_NULLP (a1) | |
189 | ? scm_cons (jmpbuf, SCM_EOL) | |
190 | : scm_cons2 (jmpbuf, a1, args), | |
191 | SCM_EOL); | |
192 | else | |
193 | answer = scm_apply (proc, a1, args); | |
7f759d79 | 194 | SCM_REDEFER_INTS; |
0f2d19dd JB |
195 | DEACTIVATEJB (jmpbuf); |
196 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 197 | SCM_REALLOW_INTS; |
0f2d19dd JB |
198 | } |
199 | return answer; | |
200 | } | |
201 | ||
e68b42c1 MD |
202 | SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); |
203 | SCM | |
204 | scm_catch (tag, thunk, handler) | |
205 | SCM tag; | |
206 | SCM thunk; | |
207 | SCM handler; | |
208 | { | |
209 | SCM_ASSERT ((tag == SCM_BOOL_F) | |
210 | || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) | |
211 | || (tag == SCM_BOOL_T), | |
212 | tag, SCM_ARG1, s_catch); | |
213 | return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 0); | |
214 | } | |
215 | ||
216 | SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); | |
217 | SCM | |
218 | scm_lazy_catch (tag, thunk, handler) | |
219 | SCM tag; | |
220 | SCM thunk; | |
221 | SCM handler; | |
222 | { | |
223 | SCM_ASSERT ((tag == SCM_BOOL_F) | |
224 | || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) | |
225 | || (tag == SCM_BOOL_T), | |
226 | tag, SCM_ARG1, s_lazy_catch); | |
227 | return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 1); | |
228 | } | |
0f2d19dd | 229 | |
32f7b3a1 JB |
230 | /* The user has thrown to an uncaught key --- print a message and die. |
231 | 1) If the user wants something different, they can use (catch #t | |
232 | ...) to do what they like. | |
233 | 2) Outside the context of a read-eval-print loop, there isn't | |
234 | anything else good to do; libguile should not assume the existence | |
235 | of a read-eval-print loop. | |
236 | 3) Given that we shouldn't do anything complex, it's much more | |
237 | robust to do it in C code. */ | |
1d1cf2bf | 238 | static SCM uncaught_throw SCM_P ((SCM key, SCM args)); |
32f7b3a1 | 239 | static SCM |
1d1cf2bf | 240 | uncaught_throw (key, args) |
32f7b3a1 JB |
241 | SCM key; |
242 | SCM args; | |
243 | { | |
244 | SCM p = scm_def_errp; | |
245 | scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); | |
246 | scm_prin1 (key, p, 0); | |
247 | scm_gen_puts (scm_regular_string, ": ", p); | |
248 | scm_prin1 (args, p, 1); | |
249 | scm_gen_putc ('\n', p); | |
250 | ||
251 | exit (2); | |
252 | } | |
253 | ||
254 | ||
0f2d19dd | 255 | static char s_throw[]; |
0f2d19dd JB |
256 | SCM |
257 | scm_ithrow (key, args, noreturn) | |
258 | SCM key; | |
259 | SCM args; | |
260 | int noreturn; | |
0f2d19dd JB |
261 | { |
262 | SCM jmpbuf; | |
263 | SCM wind_goal; | |
264 | ||
265 | if (SCM_NIMP (key) && SCM_JMPBUFP (key)) | |
266 | { | |
267 | jmpbuf = key; | |
268 | if (noreturn) | |
269 | { | |
270 | SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf, | |
271 | "throw to dynamically inactive catch", | |
272 | s_throw); | |
273 | } | |
274 | else if (!JBACTIVE (jmpbuf)) | |
275 | return SCM_UNSPECIFIED; | |
276 | } | |
277 | else | |
278 | { | |
279 | SCM dynpair; | |
32f7b3a1 | 280 | SCM winds; |
0f2d19dd JB |
281 | |
282 | if (noreturn) | |
283 | { | |
32f7b3a1 JB |
284 | SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, |
285 | s_throw); | |
0f2d19dd JB |
286 | } |
287 | else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key))) | |
288 | return SCM_UNSPECIFIED; | |
289 | ||
32f7b3a1 JB |
290 | /* Search the wind list for an appropriate catch. |
291 | "Waiter, please bring us the wind list." */ | |
b20b2777 | 292 | for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds)) |
0f2d19dd | 293 | { |
b20b2777 JB |
294 | if (! SCM_CONSP (winds)) |
295 | abort (); | |
296 | ||
32f7b3a1 | 297 | dynpair = SCM_CAR (winds); |
b20b2777 | 298 | if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair)) |
32f7b3a1 JB |
299 | { |
300 | SCM this_key = SCM_CAR (dynpair); | |
301 | ||
302 | if (this_key == SCM_BOOL_T || this_key == key) | |
303 | break; | |
304 | } | |
0f2d19dd | 305 | } |
32f7b3a1 JB |
306 | |
307 | /* If we didn't find anything, print a message and exit Guile. */ | |
b20b2777 | 308 | if (winds == SCM_EOL) |
1d1cf2bf | 309 | uncaught_throw (key, args); |
b20b2777 JB |
310 | |
311 | if (SCM_IMP (winds) || SCM_NCONSP (winds)) | |
312 | abort (); | |
0f2d19dd JB |
313 | |
314 | if (dynpair != SCM_BOOL_F) | |
315 | jmpbuf = SCM_CDR (dynpair); | |
316 | else | |
317 | { | |
318 | if (!noreturn) | |
319 | return SCM_UNSPECIFIED; | |
320 | else | |
321 | { | |
322 | scm_exitval = scm_cons (key, args); | |
323 | scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); | |
faa6b3df | 324 | #ifdef DEBUG_EXTENSIONS |
e68b42c1 | 325 | scm_last_debug_frame = SCM_DFRAME (scm_rootcont); |
faa6b3df | 326 | #endif |
0f2d19dd JB |
327 | longjmp (SCM_JMPBUF (scm_rootcont), 1); |
328 | } | |
329 | } | |
330 | } | |
0f2d19dd JB |
331 | for (wind_goal = scm_dynwinds; |
332 | SCM_CDAR (wind_goal) != jmpbuf; | |
333 | wind_goal = SCM_CDR (wind_goal)) | |
334 | ; | |
335 | { | |
336 | struct jmp_buf_and_retval * jbr; | |
337 | jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); | |
338 | jbr->throw_tag = key; | |
339 | jbr->retval = args; | |
340 | } | |
341 | scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); | |
faa6b3df | 342 | #ifdef DEBUG_EXTENSIONS |
e68b42c1 | 343 | scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); |
faa6b3df | 344 | #endif |
0f2d19dd JB |
345 | longjmp (*JBJMPBUF (jmpbuf), 1); |
346 | } | |
347 | ||
348 | ||
349 | SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); | |
0f2d19dd JB |
350 | SCM |
351 | scm_throw (key, args) | |
352 | SCM key; | |
353 | SCM args; | |
0f2d19dd JB |
354 | { |
355 | scm_ithrow (key, args, 1); | |
356 | return SCM_BOOL_F; /* never really returns */ | |
357 | } | |
358 | ||
359 | ||
0f2d19dd JB |
360 | void |
361 | scm_init_throw () | |
0f2d19dd JB |
362 | { |
363 | scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); | |
0f2d19dd JB |
364 | #include "throw.x" |
365 | } |