Commit | Line | Data |
---|---|---|
d90ca38d | 1 | /* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. |
0f2d19dd JB |
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 | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
0f2d19dd JB |
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" | |
1a36eef2 | 49 | #include "eq.h" |
20e6290e | 50 | #include "dynwind.h" |
e82afdb8 | 51 | #include "backtrace.h" |
20e6290e JB |
52 | #ifdef DEBUG_EXTENSIONS |
53 | #include "debug.h" | |
54 | #endif | |
55 | #include "continuations.h" | |
7f759d79 | 56 | #include "stackchk.h" |
95384717 | 57 | #include "stacks.h" |
b6609fc7 | 58 | #include "fluids.h" |
0f2d19dd | 59 | |
20e6290e | 60 | #include "throw.h" |
0f2d19dd | 61 | |
32f7b3a1 | 62 | \f |
74229f75 | 63 | /* the jump buffer data structure */ |
0f2d19dd JB |
64 | static int scm_tc16_jmpbuffer; |
65 | ||
0f2d19dd JB |
66 | #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) |
67 | #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) | |
898a256f MD |
68 | #define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) |
69 | #define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) | |
0f2d19dd | 70 | |
e137c6b3 MD |
71 | #ifndef DEBUG_EXTENSIONS |
72 | #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) | |
73 | #define SETJBJMPBUF SCM_SETCDR | |
74 | #else | |
08b5b88c | 75 | #define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) |
0f2d19dd | 76 | #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) |
898a256f | 77 | #define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) |
0f2d19dd | 78 | #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) |
e137c6b3 | 79 | |
32f7b3a1 JB |
80 | static scm_sizet freejb SCM_P ((SCM jbsmob)); |
81 | ||
faa6b3df | 82 | static scm_sizet |
e137c6b3 MD |
83 | freejb (jbsmob) |
84 | SCM jbsmob; | |
e137c6b3 MD |
85 | { |
86 | scm_must_free ((char *) SCM_CDR (jbsmob)); | |
87 | return sizeof (scm_cell); | |
88 | } | |
0f2d19dd JB |
89 | #endif |
90 | ||
32f7b3a1 | 91 | static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); |
0f2d19dd | 92 | static int |
9882ea19 | 93 | printjb (exp, port, pstate) |
0f2d19dd JB |
94 | SCM exp; |
95 | SCM port; | |
9882ea19 | 96 | scm_print_state *pstate; |
0f2d19dd | 97 | { |
b7f3516f TT |
98 | scm_puts ("#<jmpbuffer ", port); |
99 | scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port); | |
0f2d19dd | 100 | scm_intprint((SCM) JBJMPBUF(exp), 16, port); |
b7f3516f | 101 | scm_putc ('>', port); |
0f2d19dd JB |
102 | return 1 ; |
103 | } | |
104 | ||
0f2d19dd | 105 | |
11702758 | 106 | static SCM make_jmpbuf SCM_P ((void)); |
0f2d19dd | 107 | static SCM |
11702758 | 108 | make_jmpbuf () |
0f2d19dd JB |
109 | { |
110 | SCM answer; | |
7f759d79 | 111 | SCM_REDEFER_INTS; |
0f2d19dd | 112 | { |
e137c6b3 MD |
113 | #ifdef DEBUG_EXTENSIONS |
114 | char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); | |
e137c6b3 | 115 | #endif |
23a62151 MD |
116 | #ifdef DEBUG_EXTENSIONS |
117 | SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, mem); | |
118 | #else | |
119 | SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0); | |
120 | #endif | |
11702758 MD |
121 | SETJBJMPBUF(answer, (jmp_buf *)0); |
122 | DEACTIVATEJB(answer); | |
0f2d19dd | 123 | } |
7f759d79 | 124 | SCM_REALLOW_INTS; |
0f2d19dd JB |
125 | return answer; |
126 | } | |
127 | ||
74229f75 | 128 | \f |
18eadcbe | 129 | /* scm_internal_catch (the guts of catch) */ |
74229f75 | 130 | |
0f2d19dd JB |
131 | struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ |
132 | { | |
133 | jmp_buf buf; /* must be first */ | |
134 | SCM throw_tag; | |
135 | SCM retval; | |
136 | }; | |
137 | ||
650fa1ab JB |
138 | |
139 | /* scm_internal_catch is the guts of catch. It handles all the | |
140 | mechanics of setting up a catch target, invoking the catch body, | |
141 | and perhaps invoking the handler if the body does a throw. | |
142 | ||
143 | The function is designed to be usable from C code, but is general | |
144 | enough to implement all the semantics Guile Scheme expects from | |
145 | throw. | |
146 | ||
147 | TAG is the catch tag. Typically, this is a symbol, but this | |
148 | function doesn't actually care about that. | |
149 | ||
150 | BODY is a pointer to a C function which runs the body of the catch; | |
151 | this is the code you can throw from. We call it like this: | |
816a6f06 | 152 | BODY (BODY_DATA, JMPBUF) |
650fa1ab | 153 | where: |
816a6f06 JB |
154 | BODY_DATA is just the BODY_DATA argument we received; we pass it |
155 | through to BODY as its first argument. The caller can make | |
156 | BODY_DATA point to anything useful that BODY might need. | |
650fa1ab JB |
157 | JMPBUF is the Scheme jmpbuf object corresponding to this catch, |
158 | which we have just created and initialized. | |
159 | ||
160 | HANDLER is a pointer to a C function to deal with a throw to TAG, | |
161 | should one occur. We call it like this: | |
86327304 | 162 | HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS) |
650fa1ab | 163 | where |
816a6f06 JB |
164 | HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the |
165 | same idea as BODY_DATA above. | |
86327304 JB |
166 | THROWN_TAG is the tag that the user threw to; usually this is |
167 | TAG, but it could be something else if TAG was #t (i.e., a | |
168 | catch-all), or the user threw to a jmpbuf. | |
650fa1ab | 169 | THROW_ARGS is the list of arguments the user passed to the THROW |
4dd8323f | 170 | function, after the tag. |
650fa1ab | 171 | |
3eed3475 JB |
172 | BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA |
173 | is just a pointer we pass through to HANDLER. We don't actually | |
174 | use either of those pointers otherwise ourselves. The idea is | |
175 | that, if our caller wants to communicate something to BODY or | |
176 | HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and | |
177 | HANDLER can then use. Think of it as a way to make BODY and | |
178 | HANDLER closures, not just functions; MUMBLE_DATA points to the | |
179 | enclosed variables. | |
180 | ||
181 | Of course, it's up to the caller to make sure that any data a | |
182 | MUMBLE_DATA needs is protected from GC. A common way to do this is | |
183 | to make MUMBLE_DATA a pointer to data stored in an automatic | |
184 | structure variable; since the collector must scan the stack for | |
185 | references anyway, this assures that any references in MUMBLE_DATA | |
186 | will be found. */ | |
650fa1ab | 187 | |
0f2d19dd | 188 | SCM |
816a6f06 | 189 | scm_internal_catch (tag, body, body_data, handler, handler_data) |
0f2d19dd | 190 | SCM tag; |
650fa1ab | 191 | scm_catch_body_t body; |
816a6f06 | 192 | void *body_data; |
650fa1ab | 193 | scm_catch_handler_t handler; |
816a6f06 | 194 | void *handler_data; |
0f2d19dd JB |
195 | { |
196 | struct jmp_buf_and_retval jbr; | |
197 | SCM jmpbuf; | |
198 | SCM answer; | |
199 | ||
11702758 | 200 | jmpbuf = make_jmpbuf (); |
0f2d19dd JB |
201 | answer = SCM_EOL; |
202 | scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); | |
203 | SETJBJMPBUF(jmpbuf, &jbr.buf); | |
204 | #ifdef DEBUG_EXTENSIONS | |
e68b42c1 | 205 | SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); |
0f2d19dd JB |
206 | #endif |
207 | if (setjmp (jbr.buf)) | |
208 | { | |
209 | SCM throw_tag; | |
210 | SCM throw_args; | |
211 | ||
7f759d79 MD |
212 | #ifdef STACK_CHECKING |
213 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; | |
214 | #endif | |
215 | SCM_REDEFER_INTS; | |
0f2d19dd JB |
216 | DEACTIVATEJB (jmpbuf); |
217 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 218 | SCM_REALLOW_INTS; |
0f2d19dd JB |
219 | throw_args = jbr.retval; |
220 | throw_tag = jbr.throw_tag; | |
221 | jbr.throw_tag = SCM_EOL; | |
222 | jbr.retval = SCM_EOL; | |
816a6f06 | 223 | answer = handler (handler_data, throw_tag, throw_args); |
0f2d19dd JB |
224 | } |
225 | else | |
226 | { | |
227 | ACTIVATEJB (jmpbuf); | |
492960a4 | 228 | answer = body (body_data); |
7f759d79 | 229 | SCM_REDEFER_INTS; |
0f2d19dd JB |
230 | DEACTIVATEJB (jmpbuf); |
231 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 232 | SCM_REALLOW_INTS; |
0f2d19dd JB |
233 | } |
234 | return answer; | |
235 | } | |
236 | ||
650fa1ab | 237 | |
18eadcbe JB |
238 | \f |
239 | /* scm_internal_lazy_catch (the guts of lazy catching) */ | |
240 | ||
241 | /* The smob tag for lazy_catch smobs. */ | |
242 | static long tc16_lazy_catch; | |
243 | ||
244 | /* This is the structure we put on the wind list for a lazy catch. It | |
245 | stores the handler function to call, and the data pointer to pass | |
246 | through to it. It's not a Scheme closure, but it is a function | |
247 | with data, so the term "closure" is appropriate in its broader | |
248 | sense. | |
249 | ||
250 | (We don't need anything like this in the "eager" catch code, | |
251 | because the same C frame runs both the body and the handler.) */ | |
252 | struct lazy_catch { | |
253 | scm_catch_handler_t handler; | |
254 | void *handler_data; | |
255 | }; | |
256 | ||
257 | /* Strictly speaking, we could just pass a zero for our print | |
258 | function, because we don't need to print them. They should never | |
259 | appear in normal data structures, only in the wind list. However, | |
260 | it might be nice for debugging someday... */ | |
261 | static int | |
262 | print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate) | |
263 | { | |
264 | struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (closure); | |
265 | char buf[200]; | |
266 | ||
267 | sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>", | |
268 | (long) c->handler, (long) c->handler_data); | |
b7f3516f | 269 | scm_puts (buf, port); |
18eadcbe JB |
270 | |
271 | return 1; | |
272 | } | |
273 | ||
18eadcbe JB |
274 | |
275 | /* Given a pointer to a lazy catch structure, return a smob for it, | |
276 |