1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 #include "libguile/_scm.h"
26 #include "libguile/async.h"
27 #include "libguile/smob.h"
28 #include "libguile/alist.h"
29 #include "libguile/eval.h"
30 #include "libguile/eq.h"
31 #include "libguile/dynwind.h"
32 #include "libguile/backtrace.h"
33 #include "libguile/debug.h"
34 #include "libguile/continuations.h"
35 #include "libguile/stackchk.h"
36 #include "libguile/stacks.h"
37 #include "libguile/fluids.h"
38 #include "libguile/ports.h"
39 #include "libguile/lang.h"
40 #include "libguile/validate.h"
41 #include "libguile/throw.h"
42 #include "libguile/init.h"
43 #include "libguile/strings.h"
44 #include "libguile/vm.h"
46 #include "libguile/private-options.h"
50 /* the jump buffer data structure */
51 static scm_t_bits tc16_jmpbuffer
;
53 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
55 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
56 #define ACTIVATEJB(x) \
57 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
58 #define DEACTIVATEJB(x) \
59 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
61 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
62 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
63 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
64 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
65 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
66 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
69 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
71 scm_puts ("#<jmpbuffer ", port
);
72 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
73 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
82 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
83 SETJBJMPBUF(answer
, (jmp_buf *)0);
89 /* scm_c_catch (the guts of catch) */
91 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
93 jmp_buf buf
; /* must be first */
98 /* These are the structures we use to store pre-unwind handling (aka
99 "lazy") information for a regular catch, and put on the wind list
100 for a "lazy" catch. They store the pre-unwind handler function to
101 call, and the data pointer to pass through to it. It's not a
102 Scheme closure, but it is a function with data, so the term
103 "closure" is appropriate in its broader sense.
105 (We don't need anything like this to run the normal (post-unwind)
106 catch handler, because the same C frame runs both the body and the
109 struct pre_unwind_data
{
110 scm_t_catch_handler handler
;
117 /* scm_c_catch is the guts of catch. It handles all the mechanics of
118 setting up a catch target, invoking the catch body, and perhaps
119 invoking the handler if the body does a throw.
121 The function is designed to be usable from C code, but is general
122 enough to implement all the semantics Guile Scheme expects from
125 TAG is the catch tag. Typically, this is a symbol, but this
126 function doesn't actually care about that.
128 BODY is a pointer to a C function which runs the body of the catch;
129 this is the code you can throw from. We call it like this:
132 BODY_DATA is just the BODY_DATA argument we received; we pass it
133 through to BODY as its first argument. The caller can make
134 BODY_DATA point to anything useful that BODY might need.
136 HANDLER is a pointer to a C function to deal with a throw to TAG,
137 should one occur. We call it like this:
138 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
140 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
141 same idea as BODY_DATA above.
142 THROWN_TAG is the tag that the user threw to; usually this is
143 TAG, but it could be something else if TAG was #t (i.e., a
144 catch-all), or the user threw to a jmpbuf.
145 THROW_ARGS is the list of arguments the user passed to the THROW
146 function, after the tag.
148 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
149 is just a pointer we pass through to HANDLER. We don't actually
150 use either of those pointers otherwise ourselves. The idea is
151 that, if our caller wants to communicate something to BODY or
152 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
153 HANDLER can then use. Think of it as a way to make BODY and
154 HANDLER closures, not just functions; MUMBLE_DATA points to the
157 Of course, it's up to the caller to make sure that any data a
158 MUMBLE_DATA needs is protected from GC. A common way to do this is
159 to make MUMBLE_DATA a pointer to data stored in an automatic
160 structure variable; since the collector must scan the stack for
161 references anyway, this assures that any references in MUMBLE_DATA
165 scm_c_catch (SCM tag
,
166 scm_t_catch_body body
, void *body_data
,
167 scm_t_catch_handler handler
, void *handler_data
,
168 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
170 struct jmp_buf_and_retval jbr
;
174 SCM
*sp
= NULL
, *fp
= NULL
; /* to reset the vm */
175 struct pre_unwind_data pre_unwind
;
178 if (SCM_NFALSEP (vm
))
180 sp
= SCM_VM_DATA (vm
)->sp
;
181 fp
= SCM_VM_DATA (vm
)->fp
;
184 jmpbuf
= make_jmpbuf ();
186 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
187 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
188 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
190 pre_unwind
.handler
= pre_unwind_handler
;
191 pre_unwind
.handler_data
= pre_unwind_handler_data
;
192 pre_unwind
.running
= 0;
193 pre_unwind
.lazy_catch_p
= 0;
194 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
196 if (setjmp (jbr
.buf
))
201 #ifdef STACK_CHECKING
202 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
204 SCM_CRITICAL_SECTION_START
;
205 DEACTIVATEJB (jmpbuf
);
206 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
207 SCM_CRITICAL_SECTION_END
;
208 throw_args
= jbr
.retval
;
209 throw_tag
= jbr
.throw_tag
;
210 jbr
.throw_tag
= SCM_EOL
;
211 jbr
.retval
= SCM_EOL
;
212 if (SCM_NFALSEP (vm
))
214 SCM_VM_DATA (vm
)->sp
= sp
;
215 SCM_VM_DATA (vm
)->fp
= fp
;
216 #ifdef VM_ENABLE_STACK_NULLING
217 /* see vm.c -- you'll have to enable this manually */
219 (SCM_VM_DATA (vm
)->stack_size
220 - (sp
+ 1 - SCM_VM_DATA (vm
)->stack_base
)) * sizeof(SCM
));
223 else if (SCM_NFALSEP ((vm
= scm_the_vm ())))
225 /* oof, it's possible this catch was called before the vm was
226 booted... yick. anyway, try to reset the vm stack. */
227 SCM_VM_DATA (vm
)->sp
= SCM_VM_DATA (vm
)->stack_base
- 1;
228 SCM_VM_DATA (vm
)->fp
= NULL
;
229 #ifdef VM_ENABLE_STACK_NULLING
230 /* see vm.c -- you'll have to enable this manually */
231 memset (SCM_VM_DATA (vm
)->stack_base
, 0,
232 SCM_VM_DATA (vm
)->stack_size
* sizeof(SCM
));
236 answer
= handler (handler_data
, throw_tag
, throw_args
);
241 answer
= body (body_data
);
242 SCM_CRITICAL_SECTION_START
;
243 DEACTIVATEJB (jmpbuf
);
244 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
245 SCM_CRITICAL_SECTION_END
;
251 scm_internal_catch (SCM tag
,
252 scm_t_catch_body body
, void *body_data
,
253 scm_t_catch_handler handler
, void *handler_data
)
255 return scm_c_catch(tag
,
257 handler
, handler_data
,
263 /* The smob tag for pre_unwind_data smobs. */
264 static scm_t_bits tc16_pre_unwind_data
;
266 /* Strictly speaking, we could just pass a zero for our print
267 function, because we don't need to print them. They should never
268 appear in normal data structures, only in the wind list. However,
269 it might be nice for debugging someday... */
271 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
273 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
276 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
277 (long) c
->handler
, (long) c
->handler_data
);
278 scm_puts (buf
, port
);
284 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
285 suitable for inclusion in the wind list. ("Ah yes, a Château
286 Gollombiere '72, non?"). */
288 make_pre_unwind_data (struct pre_unwind_data
*c
)
290 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
293 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
296 scm_c_with_throw_handler (SCM tag
,
297 scm_t_catch_body body
,
299 scm_t_catch_handler handler
,
303 SCM pre_unwind
, answer
;
304 struct pre_unwind_data c
;
307 c
.handler_data
= handler_data
;
309 c
.lazy_catch_p
= lazy_catch_p
;
310 pre_unwind
= make_pre_unwind_data (&c
);
312 SCM_CRITICAL_SECTION_START
;
313 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
314 SCM_CRITICAL_SECTION_END
;
316 answer
= (*body
) (body_data
);
318 SCM_CRITICAL_SECTION_START
;
319 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
320 SCM_CRITICAL_SECTION_END
;
325 /* Exactly like scm_internal_catch, except:
326 - It does not unwind the stack (this is the major difference).
327 - The handler is not allowed to return. */
329 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
331 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
335 /* scm_internal_stack_catch
336 Use this one if you want debugging information to be stored in
337 scm_the_last_stack_fluid_var on error. */
340 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
343 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
344 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
345 /* Throw the error */
346 return scm_throw (tag
, throw_args
);
352 scm_t_catch_body body
;
357 cwss_body (void *data
)
359 struct cwss_data
*d
= data
;
360 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
364 scm_internal_stack_catch (SCM tag
,
365 scm_t_catch_body body
,
367 scm_t_catch_handler handler
,
374 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
379 /* body and handler functions for use with any of the above catch variants */
381 /* This is a body function you can pass to scm_internal_catch if you
382 want the body to be like Scheme's `catch' --- a thunk.
384 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
385 contains the Scheme procedure to invoke as the body, and the tag
389 scm_body_thunk (void *body_data
)
391 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
393 return scm_call_0 (c
->body_proc
);
397 /* This is a handler function you can pass to scm_internal_catch if
398 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
399 applies a handler procedure to (TAG ARGS ...).
401 If the user does a throw to this catch, this function runs a
402 handler procedure written in Scheme. HANDLER_DATA is a pointer to
403 an SCM variable holding the Scheme procedure object to invoke. It
404 ought to be a pointer to an automatic variable (i.e., one living on
405 the stack), or the procedure object should be otherwise protected
408 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
410 SCM
*handler_proc_p
= (SCM
*) handler_data
;
412 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
415 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
416 catches all throws that the handler might emit itself. The handler
417 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
425 hbpca_body (void *body_data
)
427 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
428 return scm_apply_0 (data
->proc
, data
->args
);
432 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
434 SCM
*handler_proc_p
= (SCM
*) handler_data
;
435 struct hbpca_data data
;
436 data
.proc
= *handler_proc_p
;
437 data
.args
= scm_cons (tag
, throw_args
);
439 return scm_internal_catch (SCM_BOOL_T
,
441 scm_handle_by_message_noexit
, NULL
);
444 /* Derive the an exit status from the arguments to (quit ...). */
446 scm_exit_status (SCM args
)
448 if (!SCM_NULL_OR_NIL_P (args
))
450 SCM cqa
= SCM_CAR (args
);
452 if (scm_is_integer (cqa
))
453 return (scm_to_int (cqa
));
454 else if (scm_is_false (cqa
))
462 handler_message (void *handler_data
, SCM tag
, SCM args
)
464 char *prog_name
= (char *) handler_data
;
465 SCM p
= scm_current_error_port ();
467 if (scm_ilength (args
) == 4)
469 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
470 SCM subr
= SCM_CAR (args
);
471 SCM message
= SCM_CADR (args
);
472 SCM parts
= SCM_CADDR (args
);
473 SCM rest
= SCM_CADDDR (args
);
475 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
479 if (scm_is_eq (tag
, scm_arg_type_key
)
480 || scm_is_eq (tag
, scm_out_of_range_key
))
483 highlights
= SCM_EOL
;
485 scm_puts ("Backtrace:\n", p
);
486 scm_display_backtrace_with_highlights (stack
, p
,
487 SCM_BOOL_F
, SCM_BOOL_F
,
491 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
498 scm_puts (prog_name
, p
);
501 scm_puts ("uncaught throw to ", p
);
502 scm_prin1 (tag
, p
, 0);
504 scm_prin1 (args
, p
, 1);
510 /* This is a handler function to use if you want scheme to print a
511 message and die. Useful for dealing with throws to uncaught keys
514 At boot time, we establish a catch-all that uses this as its handler.
515 1) If the user wants something different, they can use (catch #t
516 ...) to do what they like.
517 2) Outside the context of a read-eval-print loop, there isn't
518 anything else good to do; libguile should not assume the existence
519 of a read-eval-print loop.
520 3) Given that we shouldn't do anything complex, it's much more
521 robust to do it in C code.
523 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
524 message header to print; if zero, we use "guile" instead. That
525 text is followed by a colon, then the message described by ARGS. */
527 /* Dirk:FIXME:: The name of the function should make clear that the
528 * application gets terminated.
532 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
534 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
535 exit (scm_exit_status (args
));
537 handler_message (handler_data
, tag
, args
);
538 scm_i_pthread_exit (NULL
);
540 /* this point not reached, but suppress gcc warning about no return value
541 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
542 to be the case on cygwin for instance) */
547 /* This is just like scm_handle_by_message, but it doesn't exit; it
548 just returns #f. It's useful in cases where you don't really know
549 enough about the body to handle things in a better way, but don't
550 want to let throws fall off the bottom of the wind list. */
552 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
554 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
555 exit (scm_exit_status (args
));
557 handler_message (handler_data
, tag
, args
);
564 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
566 scm_ithrow (tag
, args
, 1);
567 return SCM_UNSPECIFIED
; /* never returns */
572 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
574 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
575 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
576 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
577 "exceptions matching @var{key}. If thunk throws to the symbol\n"
578 "@var{key}, then @var{handler} is invoked this way:\n"
580 "(handler key args ...)\n"
583 "@var{key} is a symbol or @code{#t}.\n"
585 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
586 "normally, that is the return value of @code{catch}.\n"
588 "Handler is invoked outside the scope of its own @code{catch}.\n"
589 "If @var{handler} again throws to the same key, a new handler\n"
590 "from further up the call chain is invoked.\n"
592 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
593 "match this call to @code{catch}.\n"
595 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
596 "an exception that matches @var{key}, Guile calls the\n"
597 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
598 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
599 "be a procedure with the same signature as @var{handler}, that\n"
600 "is @code{(lambda (key . args))}. It is typically used to save\n"
601 "the stack at the point where the exception occurred, but can also\n"
602 "query other parts of the dynamic state at that point, such as\n"
605 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
606 "If it exits normally, Guile unwinds the stack and dynamic context\n"
607 "and then calls the normal (third argument) handler. If it exits\n"
608 "non-locally, that exit determines the continuation.")
609 #define FUNC_NAME s_scm_catch_with_pre_unwind_handler
611 struct scm_body_thunk_data c
;
613 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
614 key
, SCM_ARG1
, FUNC_NAME
);
619 /* scm_c_catch takes care of all the mechanics of setting up a catch
620 key; we tell it to call scm_body_thunk to run the body, and
621 scm_handle_by_proc to deal with any throws to this catch. The
622 former receives a pointer to c, telling it how to behave. The
623 latter receives a pointer to HANDLER, so it knows who to
625 return scm_c_catch (key
,
627 scm_handle_by_proc
, &handler
,
628 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
629 &pre_unwind_handler
);
633 /* The following function exists to provide backwards compatibility
634 for the C scm_catch API. Otherwise we could just change
635 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
637 scm_catch (SCM key
, SCM thunk
, SCM handler
)
639 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
643 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
644 (SCM key
, SCM thunk
, SCM handler
),
645 "Add @var{handler} to the dynamic context as a throw handler\n"
646 "for key @var{key}, then invoke @var{thunk}.")
647 #define FUNC_NAME s_scm_with_throw_handler
649 struct scm_body_thunk_data c
;
651 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
652 key
, SCM_ARG1
, FUNC_NAME
);
657 /* scm_c_with_throw_handler takes care of the mechanics of setting
658 up a throw handler; we tell it to call scm_body_thunk to run the
659 body, and scm_handle_by_proc to deal with any throws to this
660 handler. The former receives a pointer to c, telling it how to
661 behave. The latter receives a pointer to HANDLER, so it knows
663 return scm_c_with_throw_handler (key
,
665 scm_handle_by_proc
, &handler
,
670 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
671 (SCM key
, SCM thunk
, SCM handler
),
672 "This behaves exactly like @code{catch}, except that it does\n"
673 "not unwind the stack before invoking @var{handler}.\n"
674 "If the @var{handler} procedure returns normally, Guile\n"
675 "rethrows the same exception again to the next innermost catch,\n"
676 "lazy-catch or throw handler. If the @var{handler} exits\n"
677 "non-locally, that exit determines the continuation.")
678 #define FUNC_NAME s_scm_lazy_catch
680 struct scm_body_thunk_data c
;
682 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
683 key
, SCM_ARG1
, FUNC_NAME
);
688 /* scm_internal_lazy_catch takes care of all the mechanics of
689 setting up a lazy catch key; we tell it to call scm_body_thunk to
690 run the body, and scm_handle_by_proc to deal with any throws to
691 this catch. The former receives a pointer to c, telling it how
692 to behave. The latter receives a pointer to HANDLER, so it knows
694 return scm_internal_lazy_catch (key
,
696 scm_handle_by_proc
, &handler
);
704 static void toggle_pre_unwind_running (void *data
)
706 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
707 pre_unwind
->running
= !pre_unwind
->running
;
710 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
712 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
713 "@var{handler}. \n\n"
714 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
716 "If there is no handler at all, Guile prints an error and then exits.")
717 #define FUNC_NAME s_scm_throw
719 SCM_VALIDATE_SYMBOL (1, key
);
720 return scm_ithrow (key
, args
, 1);
725 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
727 SCM jmpbuf
= SCM_UNDEFINED
;
730 SCM dynpair
= SCM_UNDEFINED
;
733 if (scm_i_critical_section_level
)
739 We have much better routines for displaying Scheme, but we're
740 already inside a pernicious error, and it's unlikely that they
741 are available to us. We try to print something useful anyway,
742 so users don't need a debugger to find out what went wrong.
744 fprintf (stderr
, "throw from within critical section.\n");
745 if (scm_is_symbol (key
))
746 fprintf (stderr
, "error key: %s\n", scm_i_symbol_chars (key
));
749 for (; scm_is_pair (s
); s
= scm_cdr (s
), i
++)
751 char const *str
= NULL
;
752 if (scm_is_string (scm_car (s
)))
753 str
= scm_i_string_chars (scm_car (s
));
754 else if (scm_is_symbol (scm_car (s
)))
755 str
= scm_i_symbol_chars (scm_car (s
));
758 fprintf (stderr
, "argument %d: %s\n", i
, str
);
765 /* Search the wind list for an appropriate catch.
766 "Waiter, please bring us the wind list." */
767 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
769 dynpair
= SCM_CAR (winds
);
770 if (scm_is_pair (dynpair
))
772 SCM this_key
= SCM_CAR (dynpair
);
774 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
776 jmpbuf
= SCM_CDR (dynpair
);
778 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
782 struct pre_unwind_data
*c
=
783 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
791 /* If we didn't find anything, print a message and abort the process
792 right here. If you don't want this, establish a catch-all around
793 any code that might throw up. */
794 if (scm_is_null (winds
))
796 scm_handle_by_message (NULL
, key
, args
);
800 /* If the wind list is malformed, bail. */
801 if (!scm_is_pair (winds
))
804 for (wind_goal
= scm_i_dynwinds ();
805 (!scm_is_pair (SCM_CAR (wind_goal
))
806 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
807 wind_goal
= SCM_CDR (wind_goal
))
810 /* Is this a throw handler (or lazy catch)? In a wind list entry
811 for a throw handler or lazy catch, the key is bound to a
812 pre_unwind_data smob, not a jmpbuf. */
813 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
815 struct pre_unwind_data
*c
=
816 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
819 /* For old-style lazy-catch behaviour, we unwind the dynamic
820 context before invoking the handler. */
823 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
824 - scm_ilength (wind_goal
)));
825 SCM_CRITICAL_SECTION_START
;
826 handle
= scm_i_dynwinds ();
827 scm_i_set_dynwinds (SCM_CDR (handle
));
828 SCM_CRITICAL_SECTION_END
;
831 /* Call the handler, with framing to set the pre-unwind
832 structure's running field while the handler is running, so we
833 can avoid recursing into the same handler again. Note that
834 if the handler returns normally, the running flag stays
835 set until some kind of non-local jump occurs. */
836 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
837 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
839 SCM_F_WIND_EXPLICITLY
);
840 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
841 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
843 /* There is deliberately no scm_dynwind_end call here. This
844 means that the unwind handler (toggle_pre_unwind_running)
845 stays in place until a non-local exit occurs, and will then
846 reset the pre-unwind structure's running flag. For sample
847 code where this makes a difference, see the "again but with
848 two chained throw handlers" test case in exceptions.test. */
850 /* If the handler returns, rethrow the same key and args. */
854 /* Otherwise, it's a normal catch. */
855 else if (SCM_JMPBUFP (jmpbuf
))
857 struct pre_unwind_data
* pre_unwind
;
858 struct jmp_buf_and_retval
* jbr
;
860 /* Before unwinding anything, run the pre-unwind handler if
861 there is one, and if it isn't already running. */
862 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
863 if (pre_unwind
->handler
&& !pre_unwind
->running
)
865 /* Use framing to detect and avoid possible reentry into
866 this handler, which could otherwise cause an infinite
868 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
869 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
871 SCM_F_WIND_EXPLICITLY
);
872 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
874 SCM_F_WIND_EXPLICITLY
);
875 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
879 /* Now unwind and jump. */
880 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
881 - scm_ilength (wind_goal
)));
882 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
883 jbr
->throw_tag
= key
;
885 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
886 longjmp (*JBJMPBUF (jmpbuf
), 1);
889 /* Otherwise, it's some random piece of junk. */
894 /* On IA64, we #define longjmp as setcontext, and GCC appears not to
895 know that that doesn't return. */
896 return SCM_UNSPECIFIED
;
904 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
905 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
907 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
908 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
910 #include "libguile/throw.x"