1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 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/async.h"
24 #include "libguile/smob.h"
25 #include "libguile/alist.h"
26 #include "libguile/eval.h"
27 #include "libguile/eq.h"
28 #include "libguile/dynwind.h"
29 #include "libguile/backtrace.h"
30 #include "libguile/debug.h"
31 #include "libguile/continuations.h"
32 #include "libguile/stackchk.h"
33 #include "libguile/stacks.h"
34 #include "libguile/fluids.h"
35 #include "libguile/ports.h"
36 #include "libguile/lang.h"
37 #include "libguile/validate.h"
38 #include "libguile/throw.h"
39 #include "libguile/init.h"
42 /* the jump buffer data structure */
43 static scm_t_bits tc16_jmpbuffer
;
45 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
47 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
48 #define ACTIVATEJB(x) \
49 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
50 #define DEACTIVATEJB(x) \
51 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
53 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
54 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
55 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
56 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
59 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
61 scm_puts ("#<jmpbuffer ", port
);
62 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
63 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
72 SCM_CRITICAL_SECTION_START
;
74 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
75 SETJBJMPBUF(answer
, (jmp_buf *)0);
78 SCM_CRITICAL_SECTION_END
;
83 /* scm_internal_catch (the guts of catch) */
85 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
87 jmp_buf buf
; /* must be first */
93 /* scm_internal_catch is the guts of catch. It handles all the
94 mechanics of setting up a catch target, invoking the catch body,
95 and perhaps invoking the handler if the body does a throw.
97 The function is designed to be usable from C code, but is general
98 enough to implement all the semantics Guile Scheme expects from
101 TAG is the catch tag. Typically, this is a symbol, but this
102 function doesn't actually care about that.
104 BODY is a pointer to a C function which runs the body of the catch;
105 this is the code you can throw from. We call it like this:
108 BODY_DATA is just the BODY_DATA argument we received; we pass it
109 through to BODY as its first argument. The caller can make
110 BODY_DATA point to anything useful that BODY might need.
112 HANDLER is a pointer to a C function to deal with a throw to TAG,
113 should one occur. We call it like this:
114 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
116 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
117 same idea as BODY_DATA above.
118 THROWN_TAG is the tag that the user threw to; usually this is
119 TAG, but it could be something else if TAG was #t (i.e., a
120 catch-all), or the user threw to a jmpbuf.
121 THROW_ARGS is the list of arguments the user passed to the THROW
122 function, after the tag.
124 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
125 is just a pointer we pass through to HANDLER. We don't actually
126 use either of those pointers otherwise ourselves. The idea is
127 that, if our caller wants to communicate something to BODY or
128 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
129 HANDLER can then use. Think of it as a way to make BODY and
130 HANDLER closures, not just functions; MUMBLE_DATA points to the
133 Of course, it's up to the caller to make sure that any data a
134 MUMBLE_DATA needs is protected from GC. A common way to do this is
135 to make MUMBLE_DATA a pointer to data stored in an automatic
136 structure variable; since the collector must scan the stack for
137 references anyway, this assures that any references in MUMBLE_DATA
141 scm_internal_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
143 struct jmp_buf_and_retval jbr
;
147 jmpbuf
= make_jmpbuf ();
149 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
150 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
151 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
152 if (setjmp (jbr
.buf
))
157 #ifdef STACK_CHECKING
158 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
160 SCM_CRITICAL_SECTION_START
;
161 DEACTIVATEJB (jmpbuf
);
162 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
163 SCM_CRITICAL_SECTION_END
;
164 throw_args
= jbr
.retval
;
165 throw_tag
= jbr
.throw_tag
;
166 jbr
.throw_tag
= SCM_EOL
;
167 jbr
.retval
= SCM_EOL
;
168 answer
= handler (handler_data
, throw_tag
, throw_args
);
173 answer
= body (body_data
);
174 SCM_CRITICAL_SECTION_START
;
175 DEACTIVATEJB (jmpbuf
);
176 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
177 SCM_CRITICAL_SECTION_END
;
184 /* scm_internal_lazy_catch (the guts of lazy catching) */
186 /* The smob tag for lazy_catch smobs. */
187 static scm_t_bits tc16_lazy_catch
;
189 /* This is the structure we put on the wind list for a lazy catch. It
190 stores the handler function to call, and the data pointer to pass
191 through to it. It's not a Scheme closure, but it is a function
192 with data, so the term "closure" is appropriate in its broader
195 (We don't need anything like this in the "eager" catch code,
196 because the same C frame runs both the body and the handler.) */
198 scm_t_catch_handler handler
;
202 /* Strictly speaking, we could just pass a zero for our print
203 function, because we don't need to print them. They should never
204 appear in normal data structures, only in the wind list. However,
205 it might be nice for debugging someday... */
207 lazy_catch_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
209 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (closure
);
212 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
213 (long) c
->handler
, (long) c
->handler_data
);
214 scm_puts (buf
, port
);
220 /* Given a pointer to a lazy catch structure, return a smob for it,
221 suitable for inclusion in the wind list. ("Ah yes, a Château
222 Gollombiere '72, non?"). */
224 make_lazy_catch (struct lazy_catch
*c
)
226 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
229 #define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
232 /* Exactly like scm_internal_catch, except:
233 - It does not unwind the stack (this is the major difference).
234 - The handler is not allowed to return. */
236 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
238 SCM lazy_catch
, answer
;
242 c
.handler_data
= handler_data
;
243 lazy_catch
= make_lazy_catch (&c
);
245 SCM_CRITICAL_SECTION_START
;
246 scm_i_set_dynwinds (scm_acons (tag
, lazy_catch
, scm_i_dynwinds ()));
247 SCM_CRITICAL_SECTION_END
;
249 answer
= (*body
) (body_data
);
251 SCM_CRITICAL_SECTION_START
;
252 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
253 SCM_CRITICAL_SECTION_END
;
259 /* scm_internal_stack_catch
260 Use this one if you want debugging information to be stored in
261 scm_the_last_stack_fluid_var on error. */
264 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
267 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
268 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
269 /* Throw the error */
270 return scm_throw (tag
, throw_args
);
276 scm_t_catch_body body
;
281 cwss_body (void *data
)
283 struct cwss_data
*d
= data
;
284 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
288 scm_internal_stack_catch (SCM tag
,
289 scm_t_catch_body body
,
291 scm_t_catch_handler handler
,
298 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
303 /* body and handler functions for use with any of the above catch variants */
305 /* This is a body function you can pass to scm_internal_catch if you
306 want the body to be like Scheme's `catch' --- a thunk.
308 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
309 contains the Scheme procedure to invoke as the body, and the tag
313 scm_body_thunk (void *body_data
)
315 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
317 return scm_call_0 (c
->body_proc
);
321 /* This is a handler function you can pass to scm_internal_catch if
322 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
323 applies a handler procedure to (TAG ARGS ...).
325 If the user does a throw to this catch, this function runs a
326 handler procedure written in Scheme. HANDLER_DATA is a pointer to
327 an SCM variable holding the Scheme procedure object to invoke. It
328 ought to be a pointer to an automatic variable (i.e., one living on
329 the stack), or the procedure object should be otherwise protected
332 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
334 SCM
*handler_proc_p
= (SCM
*) handler_data
;
336 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
339 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
340 catches all throws that the handler might emit itself. The handler
341 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
349 hbpca_body (void *body_data
)
351 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
352 return scm_apply_0 (data
->proc
, data
->args
);
356 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
358 SCM
*handler_proc_p
= (SCM
*) handler_data
;
359 struct hbpca_data data
;
360 data
.proc
= *handler_proc_p
;
361 data
.args
= scm_cons (tag
, throw_args
);
363 return scm_internal_catch (SCM_BOOL_T
,
365 scm_handle_by_message_noexit
, NULL
);
368 /* Derive the an exit status from the arguments to (quit ...). */
370 scm_exit_status (SCM args
)
372 if (!SCM_NULL_OR_NIL_P (args
))
374 SCM cqa
= SCM_CAR (args
);
376 if (scm_is_integer (cqa
))
377 return (scm_to_int (cqa
));
378 else if (scm_is_false (cqa
))
386 handler_message (void *handler_data
, SCM tag
, SCM args
)
388 char *prog_name
= (char *) handler_data
;
389 SCM p
= scm_current_error_port ();
391 if (scm_ilength (args
) == 4)
393 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
394 SCM subr
= SCM_CAR (args
);
395 SCM message
= SCM_CADR (args
);
396 SCM parts
= SCM_CADDR (args
);
397 SCM rest
= SCM_CADDDR (args
);
399 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
403 if (scm_is_eq (tag
, scm_arg_type_key
)
404 || scm_is_eq (tag
, scm_out_of_range_key
))
407 highlights
= SCM_EOL
;
409 scm_puts ("Backtrace:\n", p
);
410 scm_display_backtrace_with_highlights (stack
, p
,
411 SCM_BOOL_F
, SCM_BOOL_F
,
415 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
422 scm_puts (prog_name
, p
);
425 scm_puts ("uncaught throw to ", p
);
426 scm_prin1 (tag
, p
, 0);
428 scm_prin1 (args
, p
, 1);
434 /* This is a handler function to use if you want scheme to print a
435 message and die. Useful for dealing with throws to uncaught keys
438 At boot time, we establish a catch-all that uses this as its handler.
439 1) If the user wants something different, they can use (catch #t
440 ...) to do what they like.
441 2) Outside the context of a read-eval-print loop, there isn't
442 anything else good to do; libguile should not assume the existence
443 of a read-eval-print loop.
444 3) Given that we shouldn't do anything complex, it's much more
445 robust to do it in C code.
447 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
448 message header to print; if zero, we use "guile" instead. That
449 text is followed by a colon, then the message described by ARGS. */
451 /* Dirk:FIXME:: The name of the function should make clear that the
452 * application gets terminated.
456 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
458 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
459 exit (scm_exit_status (args
));
461 handler_message (handler_data
, tag
, args
);
462 scm_i_pthread_exit (NULL
);
466 /* This is just like scm_handle_by_message, but it doesn't exit; it
467 just returns #f. It's useful in cases where you don't really know
468 enough about the body to handle things in a better way, but don't
469 want to let throws fall off the bottom of the wind list. */
471 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
473 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
474 exit (scm_exit_status (args
));
476 handler_message (handler_data
, tag
, args
);
483 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
485 scm_ithrow (tag
, args
, 1);
486 return SCM_UNSPECIFIED
; /* never returns */
491 /* the Scheme-visible CATCH and LAZY-CATCH functions */
493 SCM_DEFINE (scm_catch
, "catch", 3, 0, 0,
494 (SCM key
, SCM thunk
, SCM handler
),
495 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
496 "exceptions matching @var{key}. If thunk throws to the symbol\n"
497 "@var{key}, then @var{handler} is invoked this way:\n"
499 "(handler key args ...)\n"
502 "@var{key} is a symbol or @code{#t}.\n"
504 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
505 "normally, that is the return value of @code{catch}.\n"
507 "Handler is invoked outside the scope of its own @code{catch}.\n"
508 "If @var{handler} again throws to the same key, a new handler\n"
509 "from further up the call chain is invoked.\n"
511 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
512 "match this call to @code{catch}.")
513 #define FUNC_NAME s_scm_catch
515 struct scm_body_thunk_data c
;
517 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
518 key
, SCM_ARG1
, FUNC_NAME
);
523 /* scm_internal_catch takes care of all the mechanics of setting up
524 a catch key; we tell it to call scm_body_thunk to run the body,
525 and scm_handle_by_proc to deal with any throws to this catch.
526 The former receives a pointer to c, telling it how to behave.
527 The latter receives a pointer to HANDLER, so it knows who to call. */
528 return scm_internal_catch (key
,
530 scm_handle_by_proc
, &handler
);
535 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
536 (SCM key
, SCM thunk
, SCM handler
),
537 "This behaves exactly like @code{catch}, except that it does\n"
538 "not unwind the stack before invoking @var{handler}.\n"
539 "The @var{handler} procedure is not allowed to return:\n"
540 "it must throw to another catch, or otherwise exit non-locally.")
541 #define FUNC_NAME s_scm_lazy_catch
543 struct scm_body_thunk_data c
;
545 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
546 key
, SCM_ARG1
, FUNC_NAME
);
551 /* scm_internal_lazy_catch takes care of all the mechanics of
552 setting up a lazy catch key; we tell it to call scm_body_thunk to
553 run the body, and scm_handle_by_proc to deal with any throws to
554 this catch. The former receives a pointer to c, telling it how
555 to behave. The latter receives a pointer to HANDLER, so it knows
557 return scm_internal_lazy_catch (key
,
559 scm_handle_by_proc
, &handler
);
567 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
569 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
570 "@var{handler}. \n\n"
571 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
573 "If there is no handler at all, Guile prints an error and then exits.")
574 #define FUNC_NAME s_scm_throw
576 SCM_VALIDATE_SYMBOL (1, key
);
577 return scm_ithrow (key
, args
, 1);
582 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
584 SCM jmpbuf
= SCM_UNDEFINED
;
587 SCM dynpair
= SCM_UNDEFINED
;
590 if (scm_i_critical_section_level
)
592 fprintf (stderr
, "throw from within critical section.\n");
596 /* Search the wind list for an appropriate catch.
597 "Waiter, please bring us the wind list." */
598 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
600 dynpair
= SCM_CAR (winds
);
601 if (scm_is_pair (dynpair
))
603 SCM this_key
= SCM_CAR (dynpair
);
605 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
610 /* If we didn't find anything, print a message and abort the process
611 right here. If you don't want this, establish a catch-all around
612 any code that might throw up. */
613 if (scm_is_null (winds
))
615 scm_handle_by_message (NULL
, key
, args
);
619 /* If the wind list is malformed, bail. */
620 if (!scm_is_pair (winds
))
623 jmpbuf
= SCM_CDR (dynpair
);
625 for (wind_goal
= scm_i_dynwinds ();
626 !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
);
627 wind_goal
= SCM_CDR (wind_goal
))
630 /* Is a lazy catch? In wind list entries for lazy catches, the key
631 is bound to a lazy_catch smob, not a jmpbuf. */
632 if (SCM_LAZY_CATCH_P (jmpbuf
))
634 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (jmpbuf
);
636 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
637 - scm_ilength (wind_goal
)));
638 SCM_CRITICAL_SECTION_START
;
639 handle
= scm_i_dynwinds ();
640 scm_i_set_dynwinds (SCM_CDR (handle
));
641 SCM_CRITICAL_SECTION_END
;
642 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
643 scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL
);
646 /* Otherwise, it's a normal catch. */
647 else if (SCM_JMPBUFP (jmpbuf
))
649 struct jmp_buf_and_retval
* jbr
;
650 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
651 - scm_ilength (wind_goal
)));
652 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
653 jbr
->throw_tag
= key
;
655 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
656 longjmp (*JBJMPBUF (jmpbuf
), 1);
659 /* Otherwise, it's some random piece of junk. */
668 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
669 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
671 tc16_lazy_catch
= scm_make_smob_type ("lazy-catch", 0);
672 scm_set_smob_print (tc16_lazy_catch
, lazy_catch_print
);
674 #include "libguile/throw.x"