Commit | Line | Data |
---|---|---|
86a597f8 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
0f2d19dd JB |
24 | |
25 | #include <stdio.h> | |
27646f41 | 26 | #include <unistdio.h> |
a0599745 | 27 | #include "libguile/_scm.h" |
54f2445b | 28 | #include "libguile/async.h" |
a0599745 MD |
29 | #include "libguile/smob.h" |
30 | #include "libguile/alist.h" | |
31 | #include "libguile/eval.h" | |
32 | #include "libguile/eq.h" | |
33 | #include "libguile/dynwind.h" | |
34 | #include "libguile/backtrace.h" | |
a0599745 | 35 | #include "libguile/debug.h" |
a0599745 MD |
36 | #include "libguile/continuations.h" |
37 | #include "libguile/stackchk.h" | |
38 | #include "libguile/stacks.h" | |
39 | #include "libguile/fluids.h" | |
40 | #include "libguile/ports.h" | |
c96d76b8 | 41 | #include "libguile/lang.h" |
a0599745 MD |
42 | #include "libguile/validate.h" |
43 | #include "libguile/throw.h" | |
9de87eea | 44 | #include "libguile/init.h" |
a2c40dc7 | 45 | #include "libguile/strings.h" |
747a1635 | 46 | #include "libguile/vm.h" |
0f2d19dd | 47 | |
22fc179a HWN |
48 | #include "libguile/private-options.h" |
49 | ||
50 | ||
32f7b3a1 | 51 | \f |
74229f75 | 52 | /* the jump buffer data structure */ |
92c2555f | 53 | static scm_t_bits tc16_jmpbuffer; |
0f2d19dd | 54 | |
e841c3e0 | 55 | #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) |
c209c88e | 56 | |
e841c3e0 | 57 | #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) |
22a52da1 DH |
58 | #define ACTIVATEJB(x) \ |
59 | (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L)))) | |
60 | #define DEACTIVATEJB(x) \ | |
61 | (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) | |
0f2d19dd | 62 | |
a4dbe1ac | 63 | #define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ)) |
770e048f | 64 | #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) |
92c2555f | 65 | #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) |
770e048f | 66 | #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v))) |
43e01b1e NJ |
67 | #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x)) |
68 | #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v))) | |
0f2d19dd | 69 | |
0f2d19dd | 70 | static int |
e81d98ec | 71 | jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
0f2d19dd | 72 | { |
b7f3516f TT |
73 | scm_puts ("#<jmpbuffer ", port); |
74 | scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port); | |
0345e278 | 75 | scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port); |
b7f3516f | 76 | scm_putc ('>', port); |
0f2d19dd JB |
77 | return 1 ; |
78 | } | |
79 | ||
0f2d19dd | 80 | static SCM |
1bbd0b84 | 81 | make_jmpbuf (void) |
0f2d19dd JB |
82 | { |
83 | SCM answer; | |
86a597f8 | 84 | SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); |
a4dbe1ac | 85 | SETJBJMPBUF(answer, (scm_i_jmp_buf *)0); |
86a597f8 | 86 | DEACTIVATEJB(answer); |
0f2d19dd JB |
87 | return answer; |
88 | } | |
89 | ||
74229f75 | 90 | \f |
43e01b1e | 91 | /* scm_c_catch (the guts of catch) */ |
74229f75 | 92 | |
0f2d19dd JB |
93 | struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ |
94 | { | |
a4dbe1ac | 95 | scm_i_jmp_buf buf; /* must be first */ |
0f2d19dd JB |
96 | SCM throw_tag; |
97 | SCM retval; | |
98 | }; | |
99 | ||
43e01b1e NJ |
100 | /* These are the structures we use to store pre-unwind handling (aka |
101 | "lazy") information for a regular catch, and put on the wind list | |
102 | for a "lazy" catch. They store the pre-unwind handler function to | |
103 | call, and the data pointer to pass through to it. It's not a | |
104 | Scheme closure, but it is a function with data, so the term | |
105 | "closure" is appropriate in its broader sense. | |
650fa1ab | 106 | |
43e01b1e NJ |
107 | (We don't need anything like this to run the normal (post-unwind) |
108 | catch handler, because the same C frame runs both the body and the | |
109 | handler.) */ | |
110 | ||
111 | struct pre_unwind_data { | |
112 | scm_t_catch_handler handler; | |
113 | void *handler_data; | |
114 | int running; | |
115 | int lazy_catch_p; | |
116 | }; | |
117 | ||
118 | ||
119 | /* scm_c_catch is the guts of catch. It handles all the mechanics of | |
120 | setting up a catch target, invoking the catch body, and perhaps | |
121 | invoking the handler if the body does a throw. | |
650fa1ab JB |
122 | |
123 | The function is designed to be usable from C code, but is general | |
124 | enough to implement all the semantics Guile Scheme expects from | |
125 | throw. | |
126 | ||
127 | TAG is the catch tag. Typically, this is a symbol, but this | |
128 | function doesn't actually care about that. | |
129 | ||
130 | BODY is a pointer to a C function which runs the body of the catch; | |
131 | this is the code you can throw from. We call it like this: | |
19b27fa2 | 132 | BODY (BODY_DATA) |
650fa1ab | 133 | where: |
816a6f06 JB |
134 | BODY_DATA is just the BODY_DATA argument we received; we pass it |
135 | through to BODY as its first argument. The caller can make | |
136 | BODY_DATA point to anything useful that BODY might need. | |
650fa1ab JB |
137 | |
138 | HANDLER is a pointer to a C function to deal with a throw to TAG, | |
139 | should one occur. We call it like this: | |
86327304 | 140 | HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS) |
650fa1ab | 141 | where |
816a6f06 JB |
142 | HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the |
143 | same idea as BODY_DATA above. | |
86327304 JB |
144 | THROWN_TAG is the tag that the user threw to; usually this is |
145 | TAG, but it could be something else if TAG was #t (i.e., a | |
146 | catch-all), or the user threw to a jmpbuf. | |
650fa1ab | 147 | THROW_ARGS is the list of arguments the user passed to the THROW |
4dd8323f | 148 | function, after the tag. |
650fa1ab | 149 | |
3eed3475 JB |
150 | BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA |
151 | is just a pointer we pass through to HANDLER. We don't actually | |
152 | use either of those pointers otherwise ourselves. The idea is | |
153 | that, if our caller wants to communicate something to BODY or | |
154 | HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and | |
155 | HANDLER can then use. Think of it as a way to make BODY and | |
156 | HANDLER closures, not just functions; MUMBLE_DATA points to the | |
157 | enclosed variables. | |
158 | ||
159 | Of course, it's up to the caller to make sure that any data a | |
160 | MUMBLE_DATA needs is protected from GC. A common way to do this is | |
161 | to make MUMBLE_DATA a pointer to data stored in an automatic | |
162 | structure variable; since the collector must scan the stack for | |
163 | references anyway, this assures that any references in MUMBLE_DATA | |
164 | will be found. */ | |
650fa1ab | 165 | |
0f2d19dd | 166 | SCM |
43e01b1e NJ |
167 | scm_c_catch (SCM tag, |
168 | scm_t_catch_body body, void *body_data, | |
169 | scm_t_catch_handler handler, void *handler_data, | |
170 | scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data) | |
0f2d19dd JB |
171 | { |
172 | struct jmp_buf_and_retval jbr; | |
173 | SCM jmpbuf; | |
174 | SCM answer; | |
747a1635 AW |
175 | SCM vm; |
176 | SCM *sp = NULL, *fp = NULL; /* to reset the vm */ | |
43e01b1e | 177 | struct pre_unwind_data pre_unwind; |
0f2d19dd | 178 | |
747a1635 AW |
179 | vm = scm_the_vm (); |
180 | if (SCM_NFALSEP (vm)) | |
181 | { | |
182 | sp = SCM_VM_DATA (vm)->sp; | |
183 | fp = SCM_VM_DATA (vm)->fp; | |
184 | } | |
185 | ||
11702758 | 186 | jmpbuf = make_jmpbuf (); |
0f2d19dd | 187 | answer = SCM_EOL; |
9de87eea | 188 | scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ())); |
0f2d19dd | 189 | SETJBJMPBUF(jmpbuf, &jbr.buf); |
9de87eea | 190 | SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ()); |
43e01b1e NJ |
191 | |
192 | pre_unwind.handler = pre_unwind_handler; | |
193 | pre_unwind.handler_data = pre_unwind_handler_data; | |
194 | pre_unwind.running = 0; | |
195 | pre_unwind.lazy_catch_p = 0; | |
196 | SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind); | |
197 | ||
a4dbe1ac | 198 | if (SCM_I_SETJMP (jbr.buf)) |
0f2d19dd JB |
199 | { |
200 | SCM throw_tag; | |
201 | SCM throw_args; | |
202 | ||
7f759d79 MD |
203 | #ifdef STACK_CHECKING |
204 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; | |
205 | #endif | |
9de87eea | 206 | SCM_CRITICAL_SECTION_START; |
0f2d19dd | 207 | DEACTIVATEJB (jmpbuf); |
9de87eea MV |
208 | scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); |
209 | SCM_CRITICAL_SECTION_END; | |
0f2d19dd JB |
210 | throw_args = jbr.retval; |
211 | throw_tag = jbr.throw_tag; | |
212 | jbr.throw_tag = SCM_EOL; | |
213 | jbr.retval = SCM_EOL; | |
747a1635 AW |
214 | if (SCM_NFALSEP (vm)) |
215 | { | |
216 | SCM_VM_DATA (vm)->sp = sp; | |
217 | SCM_VM_DATA (vm)->fp = fp; | |
218 | #ifdef VM_ENABLE_STACK_NULLING | |
219 | /* see vm.c -- you'll have to enable this manually */ | |
220 | memset (sp + 1, 0, | |
221 | (SCM_VM_DATA (vm)->stack_size | |
222 | - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM)); | |
223 | #endif | |
224 | } | |
225 | else if (SCM_NFALSEP ((vm = scm_the_vm ()))) | |
226 | { | |
227 | /* oof, it's possible this catch was called before the vm was | |
228 | booted... yick. anyway, try to reset the vm stack. */ | |
229 | SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1; | |
230 | SCM_VM_DATA (vm)->fp = NULL; | |
231 | #ifdef VM_ENABLE_STACK_NULLING | |
232 | /* see vm.c -- you'll have to enable this manually */ | |
233 | memset (SCM_VM_DATA (vm)->stack_base, 0, | |
234 | SCM_VM_DATA (vm)->stack_size * sizeof(SCM)); | |
235 | #endif | |
236 | } | |
237 | ||
816a6f06 | 238 | answer = handler (handler_data, throw_tag, throw_args); |
0f2d19dd JB |
239 | } |
240 | else | |
241 | { | |
242 | ACTIVATEJB (jmpbuf); | |
492960a4 | 243 | answer = body (body_data); |
9de87eea | 244 | SCM_CRITICAL_SECTION_START; |
0f2d19dd | 245 | DEACTIVATEJB (jmpbuf); |
9de87eea MV |
246 | scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); |
247 | SCM_CRITICAL_SECTION_END; | |
0f2d19dd JB |
248 | } |
249 | return answer; | |
250 | } | |
251 | ||
43e01b1e NJ |
252 | SCM |
253 | scm_internal_catch (SCM tag, | |
254 | scm_t_catch_body body, void *body_data, | |
255 | scm_t_catch_handler handler, void *handler_data) | |
256 | { | |
257 | return scm_c_catch(tag, | |
258 | body, body_data, | |
259 | handler, handler_data, | |
260 | NULL, NULL); | |
261 | } | |
650fa1ab | 262 | |
18eadcbe | 263 | |
43e01b1e NJ |
264 | \f |
265 | /* The smob tag for pre_unwind_data smobs. */ | |
266 | static scm_t_bits tc16_pre_unwind_data; | |
18eadcbe JB |
267 | |
268 | /* Strictly speaking, we could just pass a zero for our print | |
269 | function, because we don't need to print them. They should never | |
270 | appear in normal data structures, only in the wind list. However, | |
271 | it might be nice for debugging someday... */ | |
272 | static int | |
43e01b1e | 273 | pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED) |
18eadcbe | 274 | { |
43e01b1e | 275 | struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure); |
18eadcbe JB |
276 | char buf[200]; |
277 | ||
43e01b1e | 278 | sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>", |
18eadcbe | 279 | (long) c->handler, (long) c->handler_data); |
b7f3516f | 280 | scm_puts (buf, port); |
18eadcbe JB |
281 | |
282 | return 1; | |
283 | } | |
284 | ||
18eadcbe | 285 | |
43e01b1e | 286 | /* Given a pointer to a pre_unwind_data structure, return a smob for it, |
18eadcbe JB |
287 |