Commit | Line | Data |
---|---|---|
22a52da1 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
73be1d9e MV |
8 | * This library 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 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 | |
15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
16 | */ | |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
0f2d19dd JB |
19 | \f |
20 | ||
21 | #include <stdio.h> | |
a0599745 MD |
22 | #include "libguile/_scm.h" |
23 | #include "libguile/smob.h" | |
24 | #include "libguile/alist.h" | |
25 | #include "libguile/eval.h" | |
26 | #include "libguile/eq.h" | |
27 | #include "libguile/dynwind.h" | |
28 | #include "libguile/backtrace.h" | |
20e6290e | 29 | #ifdef DEBUG_EXTENSIONS |
a0599745 | 30 | #include "libguile/debug.h" |
20e6290e | 31 | #endif |
a0599745 MD |
32 | #include "libguile/continuations.h" |
33 | #include "libguile/stackchk.h" | |
34 | #include "libguile/stacks.h" | |
35 | #include "libguile/fluids.h" | |
36 | #include "libguile/ports.h" | |
c96d76b8 | 37 | #include "libguile/lang.h" |
0f2d19dd | 38 | |
a0599745 MD |
39 | #include "libguile/validate.h" |
40 | #include "libguile/throw.h" | |
0f2d19dd | 41 | |
32f7b3a1 | 42 | \f |
74229f75 | 43 | /* the jump buffer data structure */ |
92c2555f | 44 | static scm_t_bits tc16_jmpbuffer; |
0f2d19dd | 45 | |
e841c3e0 | 46 | #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) |
c209c88e | 47 | |
e841c3e0 | 48 | #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) |
22a52da1 DH |
49 | #define ACTIVATEJB(x) \ |
50 | (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L)))) | |
51 | #define DEACTIVATEJB(x) \ | |
52 | (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) | |
0f2d19dd | 53 | |
4260a7fc | 54 | #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) |
34d19ef6 | 55 | #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) |
1a548472 | 56 | #ifdef DEBUG_EXTENSIONS |
92c2555f | 57 | #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) |
34d19ef6 | 58 | #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (v))) |
0f2d19dd JB |
59 | #endif |
60 | ||
0f2d19dd | 61 | static int |
e81d98ec | 62 | jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
0f2d19dd | 63 | { |
b7f3516f TT |
64 | scm_puts ("#<jmpbuffer ", port); |
65 | scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port); | |
4260a7fc | 66 | scm_intprint((long) JBJMPBUF (exp), 16, port); |
b7f3516f | 67 | scm_putc ('>', port); |
0f2d19dd JB |
68 | return 1 ; |
69 | } | |
70 | ||
0f2d19dd | 71 | static SCM |
1bbd0b84 | 72 | make_jmpbuf (void) |
0f2d19dd JB |
73 | { |
74 | SCM answer; | |
7f759d79 | 75 | SCM_REDEFER_INTS; |
0f2d19dd | 76 | { |
e137c6b3 | 77 | #ifdef DEBUG_EXTENSIONS |
e841c3e0 | 78 | SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); |
23a62151 | 79 | #else |
e841c3e0 | 80 | SCM_NEWSMOB (answer, tc16_jmpbuffer, 0); |
23a62151 | 81 | #endif |
11702758 MD |
82 | SETJBJMPBUF(answer, (jmp_buf *)0); |
83 | DEACTIVATEJB(answer); | |
0f2d19dd | 84 | } |
7f759d79 | 85 | SCM_REALLOW_INTS; |
0f2d19dd JB |
86 | return answer; |
87 | } | |
88 | ||
74229f75 | 89 | \f |
18eadcbe | 90 | /* scm_internal_catch (the guts of catch) */ |
74229f75 | 91 | |
0f2d19dd JB |
92 | struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ |
93 | { | |
94 | jmp_buf buf; /* must be first */ | |
95 | SCM throw_tag; | |
96 | SCM retval; | |
97 | }; | |
98 | ||
650fa1ab JB |
99 | |
100 | /* scm_internal_catch is the guts of catch. It handles all the | |
101 | mechanics of setting up a catch target, invoking the catch body, | |
102 | and perhaps invoking the handler if the body does a throw. | |
103 | ||
104 | The function is designed to be usable from C code, but is general | |
105 | enough to implement all the semantics Guile Scheme expects from | |
106 | throw. | |
107 | ||
108 | TAG is the catch tag. Typically, this is a symbol, but this | |
109 | function doesn't actually care about that. | |
110 | ||
111 | BODY is a pointer to a C function which runs the body of the catch; | |
112 | this is the code you can throw from. We call it like this: | |
19b27fa2 | 113 | BODY (BODY_DATA) |
650fa1ab | 114 | where: |
816a6f06 JB |
115 | BODY_DATA is just the BODY_DATA argument we received; we pass it |
116 | through to BODY as its first argument. The caller can make | |
117 | BODY_DATA point to anything useful that BODY might need. | |
650fa1ab JB |
118 | |
119 | HANDLER is a pointer to a C function to deal with a throw to TAG, | |
120 | should one occur. We call it like this: | |
86327304 | 121 | HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS) |
650fa1ab | 122 | where |
816a6f06 JB |
123 | HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the |
124 | same idea as BODY_DATA above. | |
86327304 JB |
125 | THROWN_TAG is the tag that the user threw to; usually this is |
126 | TAG, but it could be something else if TAG was #t (i.e., a | |
127 | catch-all), or the user threw to a jmpbuf. | |
650fa1ab | 128 | THROW_ARGS is the list of arguments the user passed to the THROW |
4dd8323f | 129 | function, after the tag. |
650fa1ab | 130 | |
3eed3475 JB |
131 | BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA |
132 | is just a pointer we pass through to HANDLER. We don't actually | |
133 | use either of those pointers otherwise ourselves. The idea is | |
134 | that, if our caller wants to communicate something to BODY or | |
135 | HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and | |
136 | HANDLER can then use. Think of it as a way to make BODY and | |
137 | HANDLER closures, not just functions; MUMBLE_DATA points to the | |
138 | enclosed variables. | |
139 | ||
140 | Of course, it's up to the caller to make sure that any data a | |
141 | MUMBLE_DATA needs is protected from GC. A common way to do this is | |
142 | to make MUMBLE_DATA a pointer to data stored in an automatic | |
143 | structure variable; since the collector must scan the stack for | |
144 | references anyway, this assures that any references in MUMBLE_DATA | |
145 | will be found. */ | |
650fa1ab | 146 | |
0f2d19dd | 147 | SCM |
92c2555f | 148 | scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) |
0f2d19dd JB |
149 | { |
150 | struct jmp_buf_and_retval jbr; | |
151 | SCM jmpbuf; | |
152 | SCM answer; | |
153 | ||
11702758 | 154 | jmpbuf = make_jmpbuf (); |
0f2d19dd JB |
155 | answer = SCM_EOL; |
156 | scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); | |
157 | SETJBJMPBUF(jmpbuf, &jbr.buf); | |
158 | #ifdef DEBUG_EXTENSIONS | |
e68b42c1 | 159 | SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); |
0f2d19dd JB |
160 | #endif |
161 | if (setjmp (jbr.buf)) | |
162 | { | |
163 | SCM throw_tag; | |
164 | SCM throw_args; | |
165 | ||
7f759d79 MD |
166 | #ifdef STACK_CHECKING |
167 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; | |
168 | #endif | |
169 | SCM_REDEFER_INTS; | |
0f2d19dd JB |
170 | DEACTIVATEJB (jmpbuf); |
171 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 172 | SCM_REALLOW_INTS; |
0f2d19dd JB |
173 | throw_args = jbr.retval; |
174 | throw_tag = jbr.throw_tag; | |
175 | jbr.throw_tag = SCM_EOL; | |
176 | jbr.retval = SCM_EOL; | |
816a6f06 | 177 | answer = handler (handler_data, throw_tag, throw_args); |
0f2d19dd JB |
178 | } |
179 | else | |
180 | { | |
181 | ACTIVATEJB (jmpbuf); | |
492960a4 | 182 | answer = body (body_data); |
7f759d79 | 183 | SCM_REDEFER_INTS; |
0f2d19dd JB |
184 | DEACTIVATEJB (jmpbuf); |
185 | scm_dynwinds = SCM_CDR (scm_dynwinds); | |
7f759d79 | 186 | SCM_REALLOW_INTS; |
0f2d19dd JB |
187 | } |
188 | return answer; | |
189 | } | |
190 | ||
650fa1ab | 191 | |
18eadcbe JB |
192 | \f |
193 | /* scm_internal_lazy_catch (the guts of lazy catching) */ | |
194 | ||
195 | /* The smob tag for lazy_catch smobs. */ | |
92c2555f | 196 | static scm_t_bits tc16_lazy_catch; |
18eadcbe JB |
197 | |
198 | /* This is the structure we put on the wind list for a lazy catch. It | |
199 | stores the handler function to call, and the data pointer to pass | |
200 | through to it. It's not a Scheme closure, but it is a function | |
201 | with data, so the term "closure" is appropriate in its broader | |
202 | sense. | |
203 | ||
204 | (We don't need anything like this in the "eager" catch code, | |
205 | because the same C frame runs both the body and the handler.) */ | |
206 | struct lazy_catch { | |
92c2555f | 207 | scm_t_catch_handler handler; |
18eadcbe JB |
208 | void *handler_data; |
209 | }; | |
210 | ||
211 | /* Strictly speaking, we could just pass a zero for our print | |
212 | function, because we don't need to print them. They should never | |
213 | appear in normal data structures, only in the wind list. However, | |
214 | it might be nice for debugging someday... */ | |
215 | static int | |
e81d98ec | 216 | lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED) |
18eadcbe | 217 | { |
4260a7fc | 218 | struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure); |
18eadcbe JB |
219 | char buf[200]; |
220 | ||
221 | sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>", | |
222 | (long) c->handler, (long) c->handler_data); | |
b7f3516f | 223 | scm_puts (buf, port); |
18eadcbe JB |
224 | |
225 | return 1; | |
226 | } | |
227 | ||
18eadcbe JB |
228 | |
229 | /* Given a pointer to a lazy catch structure, return a smob for it, | |
230 |