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"
45 /* the jump buffer data structure */
46 static scm_t_bits tc16_jmpbuffer;
48 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
50 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
51 #define ACTIVATEJB(x) \
52 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
53 #define DEACTIVATEJB(x) \
54 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
56 #define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
57 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
58 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
59 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
60 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
61 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
64 jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
66 scm_puts ("#<jmpbuffer ", port);
67 scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
68 scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
77 SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
78 SETJBJMPBUF(answer, (scm_i_jmp_buf *)0);
84 /* scm_c_catch (the guts of catch) */
86 struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
88 scm_i_jmp_buf buf; /* must be first */
93 /* These are the structures we use to store pre-unwind handling (aka
94 "lazy") information for a regular catch, and put on the wind list
95 for a "lazy" catch. They store the pre-unwind handler function to
96 call, and the data pointer to pass through to it. It's not a
97 Scheme closure, but it is a function with data, so the term
98 "closure" is appropriate in its broader sense.
100 (We don't need anything like this to run the normal (post-unwind)
101 catch handler, because the same C frame runs both the body and the
104 struct pre_unwind_data {
105 scm_t_catch_handler handler;
112 /* scm_c_catch is the guts of catch. It handles all the mechanics of
113 setting up a catch target, invoking the catch body, and perhaps
114 invoking the handler if the body does a throw.
116 The function is designed to be usable from C code, but is general
117 enough to implement all the semantics Guile Scheme expects from
120 TAG is the catch tag. Typically, this is a symbol, but this
121 function doesn't actually care about that.
123 BODY is a pointer to a C function which runs the body of the catch;
124 this is the code you can throw from. We call it like this:
127 BODY_DATA is just the BODY_DATA argument we received; we pass it
128 through to BODY as its first argument. The caller can make
129 BODY_DATA point to anything useful that BODY might need.
131 HANDLER is a pointer to a C function to deal with a throw to TAG,
132 should one occur. We call it like this:
133 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
135 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
136 same idea as BODY_DATA above.
137 THROWN_TAG is the tag that the user threw to; usually this is
138 TAG, but it could be something else if TAG was #t (i.e., a
139 catch-all), or the user threw to a jmpbuf.
140 THROW_ARGS is the list of arguments the user passed to the THROW
141 function, after the tag.
143 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
144 is just a pointer we pass through to HANDLER. We don't actually
145 use either of those pointers otherwise ourselves. The idea is
146 that, if our caller wants to communicate something to BODY or
147 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
148 HANDLER can then use. Think of it as a way to make BODY and
149 HANDLER closures, not just functions; MUMBLE_DATA points to the
152 Of course, it's up to the caller to make sure that any data a
153 MUMBLE_DATA needs is protected from GC. A common way to do this is
154 to make MUMBLE_DATA a pointer to data stored in an automatic
155 structure variable; since the collector must scan the stack for
156 references anyway, this assures that any references in MUMBLE_DATA
160 scm_c_catch (SCM tag,
161 scm_t_catch_body body, void *body_data,
162 scm_t_catch_handler handler, void *handler_data,
163 scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
165 struct jmp_buf_and_retval jbr;
168 struct pre_unwind_data pre_unwind;
170 jmpbuf = make_jmpbuf ();
172 scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
173 SETJBJMPBUF(jmpbuf, &jbr.buf);
174 SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
176 pre_unwind.handler = pre_unwind_handler;
177 pre_unwind.handler_data = pre_unwind_handler_data;
178 pre_unwind.running = 0;
179 pre_unwind.lazy_catch_p = 0;
180 SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
182 if (SCM_I_SETJMP (jbr.buf))
187 #ifdef STACK_CHECKING
188 scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
190 SCM_CRITICAL_SECTION_START;
191 DEACTIVATEJB (jmpbuf);
192 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
193 SCM_CRITICAL_SECTION_END;
194 throw_args = jbr.retval;
195 throw_tag = jbr.throw_tag;
196 jbr.throw_tag = SCM_EOL;
197 jbr.retval = SCM_EOL;
198 answer = handler (handler_data, throw_tag, throw_args);
203 answer = body (body_data);
204 SCM_CRITICAL_SECTION_START;
205 DEACTIVATEJB (jmpbuf);
206 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
207 SCM_CRITICAL_SECTION_END;
213 scm_internal_catch (SCM tag,
214 scm_t_catch_body body, void *body_data,
215 scm_t_catch_handler handler, void *handler_data)
217 return scm_c_catch(tag,
219 handler, handler_data,
225 /* The smob tag for pre_unwind_data smobs. */
226 static scm_t_bits tc16_pre_unwind_data;
228 /* Strictly speaking, we could just pass a zero for our print
229 function, because we don't need to print them. They should never
230 appear in normal data structures, only in the wind list. However,
231 it might be nice for debugging someday... */
233 pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
235 struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
238 sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
239 (long) c->handler, (long) c->handler_data);
240 scm_puts (buf, port);
246 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
247 suitable for inclusion in the wind list. ("Ah yes, a Château
248 Gollombiere '72, non?"). */
250 make_pre_unwind_data (struct pre_unwind_data *c)
252 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
255 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
258 scm_c_with_throw_handler (SCM tag,
259 scm_t_catch_body body,
261 scm_t_catch_handler handler,
265 SCM pre_unwind, answer;
266 struct pre_unwind_data c;
269 c.handler_data = handler_data;
271 c.lazy_catch_p = lazy_catch_p;
272 pre_unwind = make_pre_unwind_data (&c);
274 SCM_CRITICAL_SECTION_START;
275 scm_i_set_dynwinds (scm_acons (tag, pre_unwind, scm_i_dynwinds ()));
276 SCM_CRITICAL_SECTION_END;
278 answer = (*body) (body_data);
280 SCM_CRITICAL_SECTION_START;
281 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
282 SCM_CRITICAL_SECTION_END;
287 /* Exactly like scm_internal_catch, except:
288 - It does not unwind the stack (this is the major difference).
289 - The handler is not allowed to return. */
291 scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
293 return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 1);
297 /* scm_internal_stack_catch
298 Use this one if you want debugging information to be stored in
299 scm_the_last_stack_fluid_var on error. */
302 ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
305 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
306 scm_make_stack (SCM_BOOL_T, SCM_EOL));
307 /* Throw the error */
308 return scm_throw (tag, throw_args);
314 scm_t_catch_body body;
319 cwss_body (void *data)
321 struct cwss_data *d = data;
322 return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
326 scm_internal_stack_catch (SCM tag,
327 scm_t_catch_body body,
329 scm_t_catch_handler handler,
336 return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
341 /* body and handler functions for use with any of the above catch variants */
343 /* This is a body function you can pass to scm_internal_catch if you
344 want the body to be like Scheme's `catch' --- a thunk.
346 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
347 contains the Scheme procedure to invoke as the body, and the tag
351 scm_body_thunk (void *body_data)
353 struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
355 return scm_call_0 (c->body_proc);
359 /* This is a handler function you can pass to scm_internal_catch if
360 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
361 applies a handler procedure to (TAG ARGS ...).
363 If the user does a throw to this catch, this function runs a
364 handler procedure written in Scheme. HANDLER_DATA is a pointer to
365 an SCM variable holding the Scheme procedure object to invoke. It
366 ought to be a pointer to an automatic variable (i.e., one living on
367 the stack), or the procedure object should be otherwise protected
370 scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
372 SCM *handler_proc_p = (SCM *) handler_data;
374 return scm_apply_1 (*handler_proc_p, tag, throw_args);
377 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
378 catches all throws that the handler might emit itself. The handler
379 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
387 hbpca_body (void *body_data)
389 struct hbpca_data *data = (struct hbpca_data *)body_data;
390 return scm_apply_0 (data->proc, data->args);
394 scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
396 SCM *handler_proc_p = (SCM *) handler_data;
397 struct hbpca_data data;
398 data.proc = *handler_proc_p;
399 data.args = scm_cons (tag, throw_args);
401 return scm_internal_catch (SCM_BOOL_T,
403 scm_handle_by_message_noexit, NULL);
406 /* Derive the an exit status from the arguments to (quit ...). */
408 scm_exit_status (SCM args)
410 if (!SCM_NULL_OR_NIL_P (args))
412 SCM cqa = SCM_CAR (args);
414 if (scm_is_integer (cqa))
415 return (scm_to_int (cqa));
416 else if (scm_is_false (cqa))
424 handler_message (void *handler_data, SCM tag, SCM args)
426 char *prog_name = (char *) handler_data;
427 SCM p = scm_current_error_port ();
429 if (scm_ilength (args) == 4)
431 SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
432 SCM subr = SCM_CAR (args);
433 SCM message = SCM_CADR (args);
434 SCM parts = SCM_CADDR (args);
435 SCM rest = SCM_CADDDR (args);
437 if (SCM_BACKTRACE_P && scm_is_true (stack))
441 if (scm_is_eq (tag, scm_arg_type_key)
442 || scm_is_eq (tag, scm_out_of_range_key))
445 highlights = SCM_EOL;
447 scm_puts ("Backtrace:\n", p);
448 scm_display_backtrace_with_highlights (stack, p,
449 SCM_BOOL_F, SCM_BOOL_F,
453 scm_i_display_error (stack, p, subr, message, parts, rest);
460 scm_puts (prog_name, p);
463 scm_puts ("uncaught throw to ", p);
464 scm_prin1 (tag, p, 0);
466 scm_prin1 (args, p, 1);
472 /* This is a handler function to use if you want scheme to print a
473 message and die. Useful for dealing with throws to uncaught keys
476 At boot time, we establish a catch-all that uses this as its handler.
477 1) If the user wants something different, they can use (catch #t
478 ...) to do what they like.
479 2) Outside the context of a read-eval-print loop, there isn't
480 anything else good to do; libguile should not assume the existence
481 of a read-eval-print loop.
482 3) Given that we shouldn't do anything complex, it's much more
483 robust to do it in C code.
485 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
486 message header to print; if zero, we use "guile" instead. That
487 text is followed by a colon, then the message described by ARGS. */
489 /* Dirk:FIXME:: The name of the function should make clear that the
490 * application gets terminated.
494 scm_handle_by_message (void *handler_data, SCM tag, SCM args)
496 if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
497 exit (scm_exit_status (args));
499 handler_message (handler_data, tag, args);
500 scm_i_pthread_exit (NULL);
502 /* this point not reached, but suppress gcc warning about no return value
503 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
504 to be the case on cygwin for instance) */
509 /* This is just like scm_handle_by_message, but it doesn't exit; it
510 just returns #f. It's useful in cases where you don't really know
511 enough about the body to handle things in a better way, but don't
512 want to let throws fall off the bottom of the wind list. */
514 scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
516 if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
517 exit (scm_exit_status (args));
519 handler_message (handler_data, tag, args);
526 scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
528 scm_ithrow (tag, args, 1);
529 return SCM_UNSPECIFIED; /* never returns */
534 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
536 SCM_DEFINE (scm_catch_with_pre_unwind_handler, "catch", 3, 1, 0,
537 (SCM key, SCM thunk, SCM handler, SCM pre_unwind_handler),
538 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
539 "exceptions matching @var{key}. If thunk throws to the symbol\n"
540 "@var{key}, then @var{handler} is invoked this way:\n"
542 "(handler key args ...)\n"
545 "@var{key} is a symbol or @code{#t}.\n"
547 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
548 "normally, that is the return value of @code{catch}.\n"
550 "Handler is invoked outside the scope of its own @code{catch}.\n"
551 "If @var{handler} again throws to the same key, a new handler\n"
552 "from further up the call chain is invoked.\n"
554 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
555 "match this call to @code{catch}.\n"
557 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
558 "an exception that matches @var{key}, Guile calls the\n"
559 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
560 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
561 "be a procedure with the same signature as @var{handler}, that\n"
562 "is @code{(lambda (key . args))}. It is typically used to save\n"
563 "the stack at the point where the exception occurred, but can also\n"
564 "query other parts of the dynamic state at that point, such as\n"
567 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
568 "If it exits normally, Guile unwinds the stack and dynamic context\n"
569 "and then calls the normal (third argument) handler. If it exits\n"
570 "non-locally, that exit determines the continuation.")
571 #define FUNC_NAME s_scm_catch_with_pre_unwind_handler
573 struct scm_body_thunk_data c;
575 SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
576 key, SCM_ARG1, FUNC_NAME);
581 /* scm_c_catch takes care of all the mechanics of setting up a catch
582 key; we tell it to call scm_body_thunk to run the body, and
583 scm_handle_by_proc to deal with any throws to this catch. The
584 former receives a pointer to c, telling it how to behave. The
585 latter receives a pointer to HANDLER, so it knows who to
587 return scm_c_catch (key,
589 scm_handle_by_proc, &handler,
590 SCM_UNBNDP (pre_unwind_handler) ? NULL : scm_handle_by_proc,
591 &pre_unwind_handler);
595 /* The following function exists to provide backwards compatibility
596 for the C scm_catch API. Otherwise we could just change
597 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
599 scm_catch (SCM key, SCM thunk, SCM handler)
601 return scm_catch_with_pre_unwind_handler (key, thunk, handler, SCM_UNDEFINED);
605 SCM_DEFINE (scm_with_throw_handler, "with-throw-handler", 3, 0, 0,
606 (SCM key, SCM thunk, SCM handler),
607 "Add @var{handler} to the dynamic context as a throw handler\n"
608 "for key @var{key}, then invoke @var{thunk}.")
609 #define FUNC_NAME s_scm_with_throw_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_with_throw_handler takes care of the mechanics of setting
620 up a throw handler; we tell it to call scm_body_thunk to run the
621 body, and scm_handle_by_proc to deal with any throws to this
622 handler. The former receives a pointer to c, telling it how to
623 behave. The latter receives a pointer to HANDLER, so it knows
625 return scm_c_with_throw_handler (key,
627 scm_handle_by_proc, &handler,
632 SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
633 (SCM key, SCM thunk, SCM handler),
634 "This behaves exactly like @code{catch}, except that it does\n"
635 "not unwind the stack before invoking @var{handler}.\n"
636 "If the @var{handler} procedure returns normally, Guile\n"
637 "rethrows the same exception again to the next innermost catch,\n"
638 "lazy-catch or throw handler. If the @var{handler} exits\n"
639 "non-locally, that exit determines the continuation.")
640 #define FUNC_NAME s_scm_lazy_catch
642 struct scm_body_thunk_data c;
644 SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
645 key, SCM_ARG1, FUNC_NAME);
650 /* scm_internal_lazy_catch takes care of all the mechanics of
651 setting up a lazy catch key; we tell it to call scm_body_thunk to
652 run the body, and scm_handle_by_proc to deal with any throws to
653 this catch. The former receives a pointer to c, telling it how
654 to behave. The latter receives a pointer to HANDLER, so it knows
656 return scm_internal_lazy_catch (key,
658 scm_handle_by_proc, &handler);
666 static void toggle_pre_unwind_running (void *data)
668 struct pre_unwind_data *pre_unwind = (struct pre_unwind_data *)data;
669 pre_unwind->running = !pre_unwind->running;
672 SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
674 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
675 "@var{handler}. \n\n"
676 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
678 "If there is no handler at all, Guile prints an error and then exits.")
679 #define FUNC_NAME s_scm_throw
681 SCM_VALIDATE_SYMBOL (1, key);
682 return scm_ithrow (key, args, 1);
687 scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
689 SCM jmpbuf = SCM_UNDEFINED;
692 SCM dynpair = SCM_UNDEFINED;
695 if (SCM_I_CURRENT_THREAD->critical_section_level)
697 fprintf (stderr, "throw from within critical section.\n");
703 /* Search the wind list for an appropriate catch.
704 "Waiter, please bring us the wind list." */
705 for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
707 dynpair = SCM_CAR (winds);
708 if (scm_is_pair (dynpair))
710 SCM this_key = SCM_CAR (dynpair);
712 if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
714 jmpbuf = SCM_CDR (dynpair);
716 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
720 struct pre_unwind_data *c =
721 (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
729 /* If we didn't find anything, print a message and abort the process
730 right here. If you don't want this, establish a catch-all around
731 any code that might throw up. */
732 if (scm_is_null (winds))
734 scm_handle_by_message (NULL, key, args);
738 /* If the wind list is malformed, bail. */
739 if (!scm_is_pair (winds))
742 for (wind_goal = scm_i_dynwinds ();
743 (!scm_is_pair (SCM_CAR (wind_goal))
744 || !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf));
745 wind_goal = SCM_CDR (wind_goal))
748 /* Is this a throw handler (or lazy catch)? In a wind list entry
749 for a throw handler or lazy catch, the key is bound to a
750 pre_unwind_data smob, not a jmpbuf. */
751 if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
753 struct pre_unwind_data *c =
754 (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
757 /* For old-style lazy-catch behaviour, we unwind the dynamic
758 context before invoking the handler. */
761 scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
762 - scm_ilength (wind_goal)));
763 SCM_CRITICAL_SECTION_START;
764 handle = scm_i_dynwinds ();
765 scm_i_set_dynwinds (SCM_CDR (handle));
766 SCM_CRITICAL_SECTION_END;
769 /* Call the handler, with framing to set the pre-unwind
770 structure's running field while the handler is running, so we
771 can avoid recursing into the same handler again. Note that
772 if the handler returns normally, the running flag stays
773 set until some kind of non-local jump occurs. */
774 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
775 scm_dynwind_rewind_handler (toggle_pre_unwind_running,
777 SCM_F_WIND_EXPLICITLY);
778 scm_dynwind_unwind_handler (toggle_pre_unwind_running, c, 0);
779 answer = (c->handler) (c->handler_data, key, args);
781 /* There is deliberately no scm_dynwind_end call here. This
782 means that the unwind handler (toggle_pre_unwind_running)
783 stays in place until a non-local exit occurs, and will then
784 reset the pre-unwind structure's running flag. For sample
785 code where this makes a difference, see the "again but with
786 two chained throw handlers" test case in exceptions.test. */
788 /* If the handler returns, rethrow the same key and args. */
792 /* Otherwise, it's a normal catch. */
793 else if (SCM_JMPBUFP (jmpbuf))
795 struct pre_unwind_data * pre_unwind;
796 struct jmp_buf_and_retval * jbr;
798 /* Before unwinding anything, run the pre-unwind handler if
799 there is one, and if it isn't already running. */
800 pre_unwind = SCM_JBPREUNWIND (jmpbuf);
801 if (pre_unwind->handler && !pre_unwind->running)
803 /* Use framing to detect and avoid possible reentry into
804 this handler, which could otherwise cause an infinite
806 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
807 scm_dynwind_rewind_handler (toggle_pre_unwind_running,
809 SCM_F_WIND_EXPLICITLY);
810 scm_dynwind_unwind_handler (toggle_pre_unwind_running,
812 SCM_F_WIND_EXPLICITLY);
813 (pre_unwind->handler) (pre_unwind->handler_data, key, args);
817 /* Now unwind and jump. */
818 scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
819 - scm_ilength (wind_goal)));
820 jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
821 jbr->throw_tag = key;
823 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
824 SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
827 /* Otherwise, it's some random piece of junk. */
832 /* On IA64, we #define longjmp as setcontext, and GCC appears not to
833 know that that doesn't return. */
834 return SCM_UNSPECIFIED;
842 tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
843 scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
845 tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
846 scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
848 #include "libguile/throw.x"