1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc.
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.
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.
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
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"
29 #include "libguile/debug.h"
30 #include "libguile/continuations.h"
31 #include "libguile/stackchk.h"
32 #include "libguile/stacks.h"
33 #include "libguile/fluids.h"
34 #include "libguile/ports.h"
35 #include "libguile/lang.h"
37 #include "libguile/validate.h"
38 #include "libguile/throw.h"
41 /* the jump buffer data structure */
42 static scm_t_bits tc16_jmpbuffer
;
44 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
46 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
47 #define ACTIVATEJB(x) \
48 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
49 #define DEACTIVATEJB(x) \
50 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
52 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
53 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
54 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
55 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
58 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
60 scm_puts ("#<jmpbuffer ", port
);
61 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
62 scm_intprint((long) JBJMPBUF (exp
), 16, port
);
73 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
74 SETJBJMPBUF(answer
, (jmp_buf *)0);
82 /* scm_internal_catch (the guts of catch) */
84 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
86 jmp_buf buf
; /* must be first */
92 /* scm_internal_catch is the guts of catch. It handles all the
93 mechanics of setting up a catch target, invoking the catch body,
94 and perhaps invoking the handler if the body does a throw.
96 The function is designed to be usable from C code, but is general
97 enough to implement all the semantics Guile Scheme expects from
100 TAG is the catch tag. Typically, this is a symbol, but this
101 function doesn't actually care about that.
103 BODY is a pointer to a C function which runs the body of the catch;
104 this is the code you can throw from. We call it like this:
107 BODY_DATA is just the BODY_DATA argument we received; we pass it
108 through to BODY as its first argument. The caller can make
109 BODY_DATA point to anything useful that BODY might need.
111 HANDLER is a pointer to a C function to deal with a throw to TAG,
112 should one occur. We call it like this:
113 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
115 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
116 same idea as BODY_DATA above.
117 THROWN_TAG is the tag that the user threw to; usually this is
118 TAG, but it could be something else if TAG was #t (i.e., a
119 catch-all), or the user threw to a jmpbuf.
120 THROW_ARGS is the list of arguments the user passed to the THROW
121 function, after the tag.
123 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
124 is just a pointer we pass through to HANDLER. We don't actually
125 use either of those pointers otherwise ourselves. The idea is
126 that, if our caller wants to communicate something to BODY or
127 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
128 HANDLER can then use. Think of it as a way to make BODY and
129 HANDLER closures, not just functions; MUMBLE_DATA points to the
132 Of course, it's up to the caller to make sure that any data a
133 MUMBLE_DATA needs is protected from GC. A common way to do this is
134 to make MUMBLE_DATA a pointer to data stored in an automatic
135 structure variable; since the collector must scan the stack for
136 references anyway, this assures that any references in MUMBLE_DATA
140 scm_internal_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
142 struct jmp_buf_and_retval jbr
;
146 jmpbuf
= make_jmpbuf ();
148 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
149 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
150 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
151 if (setjmp (jbr
.buf
))
156 #ifdef STACK_CHECKING
157 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
160 DEACTIVATEJB (jmpbuf
);
161 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
163 throw_args
= jbr
.retval
;
164 throw_tag
= jbr
.throw_tag
;
165 jbr
.throw_tag
= SCM_EOL
;
166 jbr
.retval
= SCM_EOL
;
167 answer
= handler (handler_data
, throw_tag
, throw_args
);
172 answer
= body (body_data
);
174 DEACTIVATEJB (jmpbuf
);
175 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
183 /* scm_internal_lazy_catch (the guts of lazy catching) */
185 /* The smob tag for lazy_catch smobs. */
186 static scm_t_bits tc16_lazy_catch
;
188 /* This is the structure we put on the wind list for a lazy catch. It
189 stores the handler function to call, and the data pointer to pass
190 through to it. It's not a Scheme closure, but it is a function
191 with data, so the term "closure" is appropriate in its broader
194 (We don't need anything like this in the "eager" catch code,
195 because the same C frame runs both the body and the handler.) */
197 scm_t_catch_handler handler
;
201 /* Strictly speaking, we could just pass a zero for our print
202 function, because we don't need to print them. They should never
203 appear in normal data structures, only in the wind list. However,
204 it might be nice for debugging someday... */
206 lazy_catch_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
208 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (closure
);
211 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
212 (long) c
->handler
, (long) c
->handler_data
);
213 scm_puts (buf
, port
);
219 /* Given a pointer to a lazy catch structure, return a smob for it,
220 suitable for inclusion in the wind list. ("Ah yes, a Château
221 Gollombiere '72, non?"). */
223 make_lazy_catch (struct lazy_catch
*c
)
225 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
228 #define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
231 /* Exactly like scm_internal_catch, except:
232 - It does not unwind the stack (this is the major difference).
233 - The handler is not allowed to return. */
235 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
237 SCM lazy_catch
, answer
;
241 c
.handler_data
= handler_data
;
242 lazy_catch
= make_lazy_catch (&c
);
245 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
248 answer
= (*body
) (body_data
);
251 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
258 /* scm_internal_stack_catch
259 Use this one if you want debugging information to be stored in
260 scm_the_last_stack_fluid_var on error. */
263 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
266 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
267 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
268 /* Throw the error */
269 return scm_throw (tag
, throw_args
);
275 scm_t_catch_body body
;
280 cwss_body (void *data
)
282 struct cwss_data
*d
= data
;
283 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
287 scm_internal_stack_catch (SCM tag
,
288 scm_t_catch_body body
,
290 scm_t_catch_handler handler
,
297 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
302 /* body and handler functions for use with any of the above catch variants */
304 /* This is a body function you can pass to scm_internal_catch if you
305 want the body to be like Scheme's `catch' --- a thunk.
307 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
308 contains the Scheme procedure to invoke as the body, and the tag
312 scm_body_thunk (void *body_data
)
314 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
316 return scm_call_0 (c
->body_proc
);
320 /* This is a handler function you can pass to scm_internal_catch if
321 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
322 applies a handler procedure to (TAG ARGS ...).
324 If the user does a throw to this catch, this function runs a
325 handler procedure written in Scheme. HANDLER_DATA is a pointer to
326 an SCM variable holding the Scheme procedure object to invoke. It
327 ought to be a pointer to an automatic variable (i.e., one living on
328 the stack), or the procedure object should be otherwise protected
331 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
333 SCM
*handler_proc_p
= (SCM
*) handler_data
;
335 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
338 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
339 catches all throws that the handler might emit itself. The handler
340 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
348 hbpca_body (void *body_data
)
350 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
351 return scm_apply_0 (data
->proc
, data
->args
);
355 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
357 SCM
*handler_proc_p
= (SCM
*) handler_data
;
358 struct hbpca_data data
;
359 data
.proc
= *handler_proc_p
;
360 data
.args
= scm_cons (tag
, throw_args
);
362 return scm_internal_catch (SCM_BOOL_T
,
364 scm_handle_by_message_noexit
, NULL
);
367 /* Derive the an exit status from the arguments to (quit ...). */
369 scm_exit_status (SCM args
)
371 if (!SCM_NULL_OR_NIL_P (args
))
373 SCM cqa
= SCM_CAR (args
);
375 if (scm_is_integer (cqa
))
376 return (scm_to_int (cqa
));
377 else if (scm_is_false (cqa
))
385 handler_message (void *handler_data
, SCM tag
, SCM args
)
387 char *prog_name
= (char *) handler_data
;
388 SCM p
= scm_cur_errp
;
390 if (scm_ilength (args
) >= 3)
392 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
393 SCM subr
= SCM_CAR (args
);
394 SCM message
= SCM_CADR (args
);
395 SCM parts
= SCM_CADDR (args
);
396 SCM rest
= SCM_CDDDR (args
);
398 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
400 scm_puts ("Backtrace:\n", p
);
401 scm_display_backtrace (stack
, p
, SCM_UNDEFINED
, SCM_UNDEFINED
);
404 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
411 scm_puts (prog_name
, p
);
414 scm_puts ("uncaught throw to ", p
);
415 scm_prin1 (tag
, p
, 0);
417 scm_prin1 (args
, p
, 1);
423 /* This is a handler function to use if you want scheme to print a
424 message and die. Useful for dealing with throws to uncaught keys
427 At boot time, we establish a catch-all that uses this as its handler.
428 1) If the user wants something different, they can use (catch #t
429 ...) to do what they like.
430 2) Outside the context of a read-eval-print loop, there isn't
431 anything else good to do; libguile should not assume the existence
432 of a read-eval-print loop.
433 3) Given that we shouldn't do anything complex, it's much more
434 robust to do it in C code.
436 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
437 message header to print; if zero, we use "guile" instead. That
438 text is followed by a colon, then the message described by ARGS. */
440 /* Dirk:FIXME:: The name of the function should make clear that the
441 * application gets terminated.
445 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
447 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
449 exit (scm_exit_status (args
));
452 handler_message (handler_data
, tag
, args
);
457 /* This is just like scm_handle_by_message, but it doesn't exit; it
458 just returns #f. It's useful in cases where you don't really know
459 enough about the body to handle things in a better way, but don't
460 want to let throws fall off the bottom of the wind list. */
462 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
464 handler_message (handler_data
, tag
, args
);
471 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
473 scm_ithrow (tag
, args
, 1);
474 return SCM_UNSPECIFIED
; /* never returns */
479 /* the Scheme-visible CATCH and LAZY-CATCH functions */
481 SCM_DEFINE (scm_catch
, "catch", 3, 0, 0,
482 (SCM key
, SCM thunk
, SCM handler
),
483 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
484 "exceptions matching @var{key}. If thunk throws to the symbol\n"
485 "@var{key}, then @var{handler} is invoked this way:\n"
487 "(handler key args ...)\n"
490 "@var{key} is a symbol or @code{#t}.\n"
492 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
493 "normally, that is the return value of @code{catch}.\n"
495 "Handler is invoked outside the scope of its own @code{catch}.\n"
496 "If @var{handler} again throws to the same key, a new handler\n"
497 "from further up the call chain is invoked.\n"
499 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
500 "match this call to @code{catch}.")
501 #define FUNC_NAME s_scm_catch
503 struct scm_body_thunk_data c
;
505 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
506 key
, SCM_ARG1
, FUNC_NAME
);
511 /* scm_internal_catch takes care of all the mechanics of setting up
512 a catch key; we tell it to call scm_body_thunk to run the body,
513 and scm_handle_by_proc to deal with any throws to this catch.
514 The former receives a pointer to c, telling it how to behave.
515 The latter receives a pointer to HANDLER, so it knows who to call. */
516 return scm_internal_catch (key
,
518 scm_handle_by_proc
, &handler
);
523 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
524 (SCM key
, SCM thunk
, SCM handler
),
525 "This behaves exactly like @code{catch}, except that it does\n"
526 "not unwind the stack before invoking @var{handler}.\n"
527 "The @var{handler} procedure is not allowed to return:\n"
528 "it must throw to another catch, or otherwise exit non-locally.")
529 #define FUNC_NAME s_scm_lazy_catch
531 struct scm_body_thunk_data c
;
533 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
534 key
, SCM_ARG1
, FUNC_NAME
);
539 /* scm_internal_lazy_catch takes care of all the mechanics of
540 setting up a lazy catch key; we tell it to call scm_body_thunk to
541 run the body, and scm_handle_by_proc to deal with any throws to
542 this catch. The former receives a pointer to c, telling it how
543 to behave. The latter receives a pointer to HANDLER, so it knows
545 return scm_internal_lazy_catch (key
,
547 scm_handle_by_proc
, &handler
);
555 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
557 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
558 "@var{handler}. \n\n"
559 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
561 "If there is no handler at all, Guile prints an error and then exits.")
562 #define FUNC_NAME s_scm_throw
564 SCM_VALIDATE_SYMBOL (1, key
);
565 return scm_ithrow (key
, args
, 1);
570 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
572 SCM jmpbuf
= SCM_UNDEFINED
;
575 SCM dynpair
= SCM_UNDEFINED
;
578 /* Search the wind list for an appropriate catch.
579 "Waiter, please bring us the wind list." */
580 for (winds
= scm_dynwinds
; SCM_CONSP (winds
); winds
= SCM_CDR (winds
))
582 dynpair
= SCM_CAR (winds
);
583 if (SCM_CONSP (dynpair
))
585 SCM this_key
= SCM_CAR (dynpair
);
587 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
592 /* If we didn't find anything, print a message and abort the process
593 right here. If you don't want this, establish a catch-all around
594 any code that might throw up. */
595 if (SCM_NULLP (winds
))
597 scm_handle_by_message (NULL
, key
, args
);
601 /* If the wind list is malformed, bail. */
602 if (!SCM_CONSP (winds
))
605 jmpbuf
= SCM_CDR (dynpair
);
607 for (wind_goal
= scm_dynwinds
;
608 !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
);
609 wind_goal
= SCM_CDR (wind_goal
))
612 /* Is a lazy catch? In wind list entries for lazy catches, the key
613 is bound to a lazy_catch smob, not a jmpbuf. */
614 if (SCM_LAZY_CATCH_P (jmpbuf
))
616 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (jmpbuf
);
618 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
619 - scm_ilength (wind_goal
)));
621 handle
= scm_dynwinds
;
622 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
624 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
625 scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL
);
628 /* Otherwise, it's a normal catch. */
629 else if (SCM_JMPBUFP (jmpbuf
))
631 struct jmp_buf_and_retval
* jbr
;
632 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
633 - scm_ilength (wind_goal
)));
634 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
635 jbr
->throw_tag
= key
;
637 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
638 longjmp (*JBJMPBUF (jmpbuf
), 1);
641 /* Otherwise, it's some random piece of junk. */
650 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
651 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
653 tc16_lazy_catch
= scm_make_smob_type ("lazy-catch", 0);
654 scm_set_smob_print (tc16_lazy_catch
, lazy_catch_print
);
656 #include "libguile/throw.x"