* Makefile.am (libguile_la_SOURCES): Remove backtrace.c, debug.c,
[bpt/guile.git] / libguile / throw.c
... / ...
CommitLineData
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"
45#include "genio.h"
46#include "smob.h"
47#include "alist.h"
48#include "eval.h"
49#include "dynwind.h"
50#include "backtrace.h"
51#ifdef DEBUG_EXTENSIONS
52#include "debug.h"
53#endif
54#include "continuations.h"
55#include "stackchk.h"
56
57#include "throw.h"
58
59\f
60/* {Catch and Throw}
61 */
62static int scm_tc16_jmpbuffer;
63
64#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
65#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
66#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
67#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
68
69#ifndef DEBUG_EXTENSIONS
70#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
71#define SETJBJMPBUF SCM_SETCDR
72#else
73#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
74#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
75#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
76#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
77
78static scm_sizet freejb SCM_P ((SCM jbsmob));
79
80static scm_sizet
81freejb (jbsmob)
82 SCM jbsmob;
83{
84 scm_must_free ((char *) SCM_CDR (jbsmob));
85 return sizeof (scm_cell);
86}
87#endif
88
89static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
90static int
91printjb (exp, port, pstate)
92 SCM exp;
93 SCM port;
94 scm_print_state *pstate;
95{
96 scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
97 scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
98 scm_intprint((SCM) JBJMPBUF(exp), 16, port);
99 scm_gen_putc ('>', port);
100 return 1 ;
101}
102
103static scm_smobfuns jbsmob = {
104 scm_mark0,
105#ifdef DEBUG_EXTENSIONS
106 freejb,
107#else
108 scm_free0,
109#endif
110 printjb,
111 0
112};
113
114static SCM make_jmpbuf SCM_P ((void));
115static SCM
116make_jmpbuf ()
117{
118 SCM answer;
119 SCM_NEWCELL (answer);
120 SCM_REDEFER_INTS;
121 {
122#ifdef DEBUG_EXTENSIONS
123 char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
124 SCM_SETCDR (answer, (SCM) mem);
125#endif
126 SCM_SETCAR (answer, scm_tc16_jmpbuffer);
127 SETJBJMPBUF(answer, (jmp_buf *)0);
128 DEACTIVATEJB(answer);
129 }
130 SCM_REALLOW_INTS;
131 return answer;
132}
133
134struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
135{
136 jmp_buf buf; /* must be first */
137 SCM throw_tag;
138 SCM retval;
139};
140
141
142/* scm_internal_catch is the guts of catch. It handles all the
143 mechanics of setting up a catch target, invoking the catch body,
144 and perhaps invoking the handler if the body does a throw.
145
146 The function is designed to be usable from C code, but is general
147 enough to implement all the semantics Guile Scheme expects from
148 throw.
149
150 TAG is the catch tag. Typically, this is a symbol, but this
151 function doesn't actually care about that.
152
153 BODY is a pointer to a C function which runs the body of the catch;
154 this is the code you can throw from. We call it like this:
155 BODY (BODY_DATA, JMPBUF)
156 where:
157 BODY_DATA is just the BODY_DATA argument we received; we pass it
158 through to BODY as its first argument. The caller can make
159 BODY_DATA point to anything useful that BODY might need.
160 JMPBUF is the Scheme jmpbuf object corresponding to this catch,
161 which we have just created and initialized.
162
163 HANDLER is a pointer to a C function to deal with a throw to TAG,
164 should one occur. We call it like this:
165 HANDLER (HANDLER_DATA, TAG, THROW_ARGS)
166 where
167 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
168 same idea as BODY_DATA above.
169 TAG is the tag that the user threw to; usually this is TAG, but
170 it could be something else if TAG was #t (i.e., a catch-all),
171 or the user threw to a jmpbuf.
172 THROW_ARGS is the list of arguments the user passed to the THROW
173 function.
174
175 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
176 is just a pointer we pass through to HANDLER. We don't actually
177 use either of those pointers otherwise ourselves. The idea is
178 that, if our caller wants to communicate something to BODY or
179 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
180 HANDLER can then use. Think of it as a way to make BODY and
181 HANDLER closures, not just functions; MUMBLE_DATA points to the
182 enclosed variables.
183
184 Of course, it's up to the caller to make sure that any data a
185 MUMBLE_DATA needs is protected from GC. A common way to do this is
186 to make MUMBLE_DATA a pointer to data stored in an automatic
187 structure variable; since the collector must scan the stack for
188 references anyway, this assures that any references in MUMBLE_DATA
189 will be found. */
190
191SCM
192scm_internal_catch (tag, body, body_data, handler, handler_data)
193 SCM tag;
194 scm_catch_body_t body;
195 void *body_data;
196 scm_catch_handler_t handler;
197 void *handler_data;
198{
199 struct jmp_buf_and_retval jbr;
200 SCM jmpbuf;
201 SCM answer;
202
203 jmpbuf = make_jmpbuf ();
204 answer = SCM_EOL;
205 scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
206 SETJBJMPBUF(jmpbuf, &jbr.buf);
207#ifdef DEBUG_EXTENSIONS
208 SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
209#endif
210 if (setjmp (jbr.buf))
211 {
212 SCM throw_tag;
213 SCM throw_args;
214
215#ifdef STACK_CHECKING
216 scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
217#endif
218 SCM_REDEFER_INTS;
219 DEACTIVATEJB (jmpbuf);
220 scm_dynwinds = SCM_CDR (scm_dynwinds);
221 SCM_REALLOW_INTS;
222 throw_args = jbr.retval;
223 throw_tag = jbr.throw_tag;
224 jbr.throw_tag = SCM_EOL;
225 jbr.retval = SCM_EOL;
226 answer = handler (handler_data, throw_tag, throw_args);
227 }
228 else
229 {
230 ACTIVATEJB (jmpbuf);
231 answer = body (body_data, jmpbuf);
232 SCM_REDEFER_INTS;
233 DEACTIVATEJB (jmpbuf);
234 scm_dynwinds = SCM_CDR (scm_dynwinds);
235 SCM_REALLOW_INTS;
236 }
237 return answer;
238}
239
240
241/* This is a body function you can pass to scm_internal_catch if you
242 want the body to be like Scheme's `catch' --- a thunk, or a
243 function of one argument if the tag is #f.
244
245 DATA contains the Scheme procedure to invoke. If the tag being
246 caught is #f, then we pass JMPBUF to the body procedure; otherwise,
247 it gets no arguments. */
248
249SCM
250scm_body_thunk (body_data, jmpbuf)
251 void *body_data;
252 SCM jmpbuf;
253{
254 struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
255
256 if (c->tag == SCM_BOOL_F)
257 return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
258 else
259 return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
260}
261
262
263/* If the user does a throw to this catch, this function runs a
264 handler procedure written in Scheme. HANDLER_DATA is a pointer to
265 an SCM variable holding the Scheme procedure object to invoke. It
266 ought to be a pointer to an automatic, or the procedure object
267 should be otherwise protected from GC. */
268SCM
269scm_handle_by_proc (handler_data, tag, throw_args)
270 void *handler_data;
271 SCM tag;
272 SCM throw_args;
273{
274 SCM *handler_proc_p = (SCM *) handler_data;
275
276 return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
277}
278
279
280SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
281SCM
282scm_catch (tag, thunk, handler)
283 SCM tag;
284 SCM thunk;
285 SCM handler;
286{
287 struct scm_body_thunk_data c;
288
289 SCM_ASSERT ((tag == SCM_BOOL_F)
290 || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
291 || (tag == SCM_BOOL_T),
292 tag, SCM_ARG1, s_catch);
293
294 c.tag = tag;
295 c.body_proc = thunk;
296
297 /* scm_internal_catch takes care of all the mechanics of setting up
298 a catch tag; we tell it to call scm_body_thunk to run the body,
299 and scm_handle_by_proc to deal with any throws to this catch.
300 The former receives a pointer to c, telling it how to behave.
301 The latter receives a pointer to HANDLER, so it knows who to call. */
302 return scm_internal_catch (tag,
303 scm_body_thunk, &c,
304 scm_handle_by_proc, &handler);
305}
306
307
308/* The smob tag for lazy_catch smobs. */
309static long tc16_lazy_catch;
310
311/* This is the structure we put on the wind list for a lazy catch. It
312 stores the handler function to call, and the data pointer to pass
313 through to it. It's not a Scheme closure, but it is a function
314 with data, so the term "closure" is appropriate in its broader
315 sense.
316
317 (We don't need anything like this in the "eager" catch code,
318 because the same C frame runs both the body and the handler.) */
319struct lazy_catch {
320 scm_catch_handler_t handler;
321 void *handler_data;
322};
323
324/* Strictly speaking, we could just pass a zero for our print
325 function, because we don't need to print them. They should never
326 appear in normal data structures, only in the wind list. However,
327 it might be nice for debugging someday... */
328static int
329print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
330{
331 struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (closure);
332 char buf[200];
333
334 sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
335 (long) c->handler, (long) c->handler_data);
336 scm_gen_puts (scm_regular_string, buf, port);
337
338 return 1;
339}
340
341static scm_smobfuns lazy_catch_funs = {
342 scm_mark0, scm_free0, print_lazy_catch, 0
343};
344
345
346/* Given a pointer to a lazy catch structure, return a smob for it,
347