1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 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
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)))
57 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
58 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
61 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
63 scm_puts ("#<jmpbuffer ", port
);
64 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
65 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
74 SCM_CRITICAL_SECTION_START
;
76 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
77 SETJBJMPBUF(answer
, (jmp_buf *)0);
80 SCM_CRITICAL_SECTION_END
;
85 /* scm_c_catch (the guts of catch) */
87 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
89 jmp_buf buf
; /* must be first */
94 /* These are the structures we use to store pre-unwind handling (aka
95 "lazy") information for a regular catch, and put on the wind list
96 for a "lazy" catch. They store the pre-unwind handler function to
97 call, and the data pointer to pass through to it. It's not a
98 Scheme closure, but it is a function with data, so the term
99 "closure" is appropriate in its broader sense.
101 (We don't need anything like this to run the normal (post-unwind)
102 catch handler, because the same C frame runs both the body and the
105 struct pre_unwind_data
{
106 scm_t_catch_handler handler
;
113 /* scm_c_catch is the guts of catch. It handles all the mechanics of
114 setting up a catch target, invoking the catch body, and perhaps
115 invoking the handler if the body does a throw.
117 The function is designed to be usable from C code, but is general
118 enough to implement all the semantics Guile Scheme expects from
121 TAG is the catch tag. Typically, this is a symbol, but this
122 function doesn't actually care about that.
124 BODY is a pointer to a C function which runs the body of the catch;
125 this is the code you can throw from. We call it like this:
128 BODY_DATA is just the BODY_DATA argument we received; we pass it
129 through to BODY as its first argument. The caller can make
130 BODY_DATA point to anything useful that BODY might need.
132 HANDLER is a pointer to a C function to deal with a throw to TAG,
133 should one occur. We call it like this:
134 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
136 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
137 same idea as BODY_DATA above.
138 THROWN_TAG is the tag that the user threw to; usually this is
139 TAG, but it could be something else if TAG was #t (i.e., a
140 catch-all), or the user threw to a jmpbuf.
141 THROW_ARGS is the list of arguments the user passed to the THROW
142 function, after the tag.
144 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
145 is just a pointer we pass through to HANDLER. We don't actually
146 use either of those pointers otherwise ourselves. The idea is
147 that, if our caller wants to communicate something to BODY or
148 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
149 HANDLER can then use. Think of it as a way to make BODY and
150 HANDLER closures, not just functions; MUMBLE_DATA points to the
153 Of course, it's up to the caller to make sure that any data a
154 MUMBLE_DATA needs is protected from GC. A common way to do this is
155 to make MUMBLE_DATA a pointer to data stored in an automatic
156 structure variable; since the collector must scan the stack for
157 references anyway, this assures that any references in MUMBLE_DATA
161 scm_c_catch (SCM tag
,
162 scm_t_catch_body body
, void *body_data
,
163 scm_t_catch_handler handler
, void *handler_data
,
164 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
166 struct jmp_buf_and_retval jbr
;
169 struct pre_unwind_data pre_unwind
;
171 jmpbuf
= make_jmpbuf ();
173 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
174 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
175 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
177 pre_unwind
.handler
= pre_unwind_handler
;
178 pre_unwind
.handler_data
= pre_unwind_handler_data
;
179 pre_unwind
.running
= 0;
180 pre_unwind
.lazy_catch_p
= 0;
181 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
183 if (setjmp (jbr
.buf
))
188 #ifdef STACK_CHECKING
189 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
191 SCM_CRITICAL_SECTION_START
;
192 DEACTIVATEJB (jmpbuf
);
193 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
194 SCM_CRITICAL_SECTION_END
;
195 throw_args
= jbr
.retval
;
196 throw_tag
= jbr
.throw_tag
;
197 jbr
.throw_tag
= SCM_EOL
;
198 jbr
.retval
= SCM_EOL
;
199 answer
= handler (handler_data
, throw_tag
, throw_args
);
204 answer
= body (body_data
);
205 SCM_CRITICAL_SECTION_START
;
206 DEACTIVATEJB (jmpbuf
);
207 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
208 SCM_CRITICAL_SECTION_END
;
214 scm_internal_catch (SCM tag
,
215 scm_t_catch_body body
, void *body_data
,
216 scm_t_catch_handler handler
, void *handler_data
)
218 return scm_c_catch(tag
,
220 handler
, handler_data
,
226 /* The smob tag for pre_unwind_data smobs. */
227 static scm_t_bits tc16_pre_unwind_data
;
229 /* Strictly speaking, we could just pass a zero for our print
230 function, because we don't need to print them. They should never
231 appear in normal data structures, only in the wind list. However,
232 it might be nice for debugging someday... */
234 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
236 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
239 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
240 (long) c
->handler
, (long) c
->handler_data
);
241 scm_puts (buf
, port
);
247 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
248 suitable for inclusion in the wind list. ("Ah yes, a Château
249 Gollombiere '72, non?"). */
251 make_pre_unwind_data (struct pre_unwind_data
*c
)
253 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
256 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
259 scm_c_with_throw_handler (SCM tag
,
260 scm_t_catch_body body
,
262 scm_t_catch_handler handler
,
266 SCM pre_unwind
, answer
;
267 struct pre_unwind_data c
;
270 c
.handler_data
= handler_data
;
272 c
.lazy_catch_p
= lazy_catch_p
;
273 pre_unwind
= make_pre_unwind_data (&c
);
275 SCM_CRITICAL_SECTION_START
;
276 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
277 SCM_CRITICAL_SECTION_END
;
279 answer
= (*body
) (body_data
);
281 SCM_CRITICAL_SECTION_START
;
282 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
283 SCM_CRITICAL_SECTION_END
;
288 /* Exactly like scm_internal_catch, except:
289 - It does not unwind the stack (this is the major difference).
290 - The handler is not allowed to return. */
292 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
294 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
298 /* scm_internal_stack_catch
299 Use this one if you want debugging information to be stored in
300 scm_the_last_stack_fluid_var on error. */
303 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
306 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
307 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
308 /* Throw the error */
309 return scm_throw (tag
, throw_args
);
315 scm_t_catch_body body
;
320 cwss_body (void *data
)
322 struct cwss_data
*d
= data
;
323 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
327 scm_internal_stack_catch (SCM tag
,
328 scm_t_catch_body body
,
330 scm_t_catch_handler handler
,
337 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
342 /* body and handler functions for use with any of the above catch variants */
344 /* This is a body function you can pass to scm_internal_catch if you
345 want the body to be like Scheme's `catch' --- a thunk.
347 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
348 contains the Scheme procedure to invoke as the body, and the tag
352 scm_body_thunk (void *body_data
)
354 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
356 return scm_call_0 (c
->body_proc
);
360 /* This is a handler function you can pass to scm_internal_catch if
361 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
362 applies a handler procedure to (TAG ARGS ...).
364 If the user does a throw to this catch, this function runs a
365 handler procedure written in Scheme. HANDLER_DATA is a pointer to
366 an SCM variable holding the Scheme procedure object to invoke. It
367 ought to be a pointer to an automatic variable (i.e., one living on
368 the stack), or the procedure object should be otherwise protected
371 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
373 SCM
*handler_proc_p
= (SCM
*) handler_data
;
375 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
378 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
379 catches all throws that the handler might emit itself. The handler
380 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
388 hbpca_body (void *body_data
)
390 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
391 return scm_apply_0 (data
->proc
, data
->args
);
395 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
397 SCM
*handler_proc_p
= (SCM
*) handler_data
;
398 struct hbpca_data data
;
399 data
.proc
= *handler_proc_p
;
400 data
.args
= scm_cons (tag
, throw_args
);
402 return scm_internal_catch (SCM_BOOL_T
,
404 scm_handle_by_message_noexit
, NULL
);
407 /* Derive the an exit status from the arguments to (quit ...). */
409 scm_exit_status (SCM args
)
411 if (!SCM_NULL_OR_NIL_P (args
))
413 SCM cqa
= SCM_CAR (args
);
415 if (scm_is_integer (cqa
))
416 return (scm_to_int (cqa
));
417 else if (scm_is_false (cqa
))
425 handler_message (void *handler_data
, SCM tag
, SCM args
)
427 char *prog_name
= (char *) handler_data
;
428 SCM p
= scm_current_error_port ();
430 if (scm_ilength (args
) == 4)
432 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
433 SCM subr
= SCM_CAR (args
);
434 SCM message
= SCM_CADR (args
);
435 SCM parts
= SCM_CADDR (args
);
436 SCM rest
= SCM_CADDDR (args
);
438 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
442 if (scm_is_eq (tag
, scm_arg_type_key
)
443 || scm_is_eq (tag
, scm_out_of_range_key
))
446 highlights
= SCM_EOL
;
448 scm_puts ("Backtrace:\n", p
);
449 scm_display_backtrace_with_highlights (stack
, p
,
450 SCM_BOOL_F
, SCM_BOOL_F
,
454 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
461 scm_puts (prog_name
, p
);
464 scm_puts ("uncaught throw to ", p
);
465 scm_prin1 (tag
, p
, 0);
467 scm_prin1 (args
, p
, 1);
473 /* This is a handler function to use if you want scheme to print a
474 message and die. Useful for dealing with throws to uncaught keys
477 At boot time, we establish a catch-all that uses this as its handler.
478 1) If the user wants something different, they can use (catch #t
479 ...) to do what they like.
480 2) Outside the context of a read-eval-print loop, there isn't
481 anything else good to do; libguile should not assume the existence
482 of a read-eval-print loop.
483 3) Given that we shouldn't do anything complex, it's much more
484 robust to do it in C code.
486 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
487 message header to print; if zero, we use "guile" instead. That
488 text is followed by a colon, then the message described by ARGS. */
490 /* Dirk:FIXME:: The name of the function should make clear that the
491 * application gets terminated.
495 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
497 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
498 exit (scm_exit_status (args
));
500 handler_message (handler_data
, tag
, args
);
501 scm_i_pthread_exit (NULL
);
503 /* this point not reached, but suppress gcc warning about no return value
504 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
505 to be the case on cygwin for instance) */
510 /* This is just like scm_handle_by_message, but it doesn't exit; it
511 just returns #f. It's useful in cases where you don't really know
512 enough about the body to handle things in a better way, but don't
513 want to let throws fall off the bottom of the wind list. */
515 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
517 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
518 exit (scm_exit_status (args
));
520 handler_message (handler_data
, tag
, args
);
527 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
529 scm_ithrow (tag
, args
, 1);
530 return SCM_UNSPECIFIED
; /* never returns */
535 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
537 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
538 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
539 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
540 "exceptions matching @var{key}. If thunk throws to the symbol\n"
541 "@var{key}, then @var{handler} is invoked this way:\n"
543 "(handler key args ...)\n"
546 "@var{key} is a symbol or @code{#t}.\n"
548 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
549 "normally, that is the return value of @code{catch}.\n"
551 "Handler is invoked outside the scope of its own @code{catch}.\n"
552 "If @var{handler} again throws to the same key, a new handler\n"
553 "from further up the call chain is invoked.\n"
555 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
556 "match this call to @code{catch}.\n"
558 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
559 "an exception that matches @var{key}, Guile calls the\n"
560 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
561 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
562 "be a procedure with the same signature as @var{handler}, that\n"
563 "is @code{(lambda (key . args))}. It is typically used to save\n"
564 "the stack at the point where the exception occurred, but can also\n"
565 "query other parts of the dynamic state at that point, such as\n"
568 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
569 "If it exits normally, Guile unwinds the stack and dynamic context\n"
570 "and then calls the normal (third argument) handler. If it exits\n"
571 "non-locally, that exit determines the continuation.")
572 #define FUNC_NAME s_scm_catch_with_pre_unwind_handler
574 struct scm_body_thunk_data c
;
576 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
577 key
, SCM_ARG1
, FUNC_NAME
);
582 /* scm_c_catch takes care of all the mechanics of setting up a catch
583 key; we tell it to call scm_body_thunk to run the body, and
584 scm_handle_by_proc to deal with any throws to this catch. The
585 former receives a pointer to c, telling it how to behave. The
586 latter receives a pointer to HANDLER, so it knows who to
588 return scm_c_catch (key
,
590 scm_handle_by_proc
, &handler
,
591 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
592 &pre_unwind_handler
);
596 /* The following function exists to provide backwards compatibility
597 for the C scm_catch API. Otherwise we could just change
598 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
600 scm_catch (SCM key
, SCM thunk
, SCM handler
)
602 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
606 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
607 (SCM key
, SCM thunk
, SCM handler
),
608 "Add @var{handler} to the dynamic context as a throw handler\n"
609 "for key @var{key}, then invoke @var{thunk}.")
610 #define FUNC_NAME s_scm_with_throw_handler
612 struct scm_body_thunk_data c
;
614 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
615 key
, SCM_ARG1
, FUNC_NAME
);
620 /* scm_c_with_throw_handler takes care of the mechanics of setting
621 up a throw handler; we tell it to call scm_body_thunk to run the
622 body, and scm_handle_by_proc to deal with any throws to this
623 handler. The former receives a pointer to c, telling it how to
624 behave. The latter receives a pointer to HANDLER, so it knows
626 return scm_c_with_throw_handler (key
,
628 scm_handle_by_proc
, &handler
,
633 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
634 (SCM key
, SCM thunk
, SCM handler
),
635 "This behaves exactly like @code{catch}, except that it does\n"
636 "not unwind the stack before invoking @var{handler}.\n"
637 "If the @var{handler} procedure returns normally, Guile\n"
638 "rethrows the same exception again to the next innermost catch,\n"
639 "lazy-catch or throw handler. If the @var{handler} exits\n"
640 "non-locally, that exit determines the continuation.")
641 #define FUNC_NAME s_scm_lazy_catch
643 struct scm_body_thunk_data c
;
645 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
646 key
, SCM_ARG1
, FUNC_NAME
);
651 /* scm_internal_lazy_catch takes care of all the mechanics of
652 setting up a lazy catch key; we tell it to call scm_body_thunk to
653 run the body, and scm_handle_by_proc to deal with any throws to
654 this catch. The former receives a pointer to c, telling it how
655 to behave. The latter receives a pointer to HANDLER, so it knows
657 return scm_internal_lazy_catch (key
,
659 scm_handle_by_proc
, &handler
);
667 static void toggle_pre_unwind_running (void *data
)
669 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
670 pre_unwind
->running
= !pre_unwind
->running
;
673 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
675 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
676 "@var{handler}. \n\n"
677 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
679 "If there is no handler at all, Guile prints an error and then exits.")
680 #define FUNC_NAME s_scm_throw
682 SCM_VALIDATE_SYMBOL (1, key
);
683 return scm_ithrow (key
, args
, 1);
688 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
690 SCM jmpbuf
= SCM_UNDEFINED
;
693 SCM dynpair
= SCM_UNDEFINED
;
696 if (scm_i_critical_section_level
)
698 fprintf (stderr
, "throw from within critical section.\n");
704 /* Search the wind list for an appropriate catch.
705 "Waiter, please bring us the wind list." */
706 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
708 dynpair
= SCM_CAR (winds
);
709 if (scm_is_pair (dynpair
))
711 SCM this_key
= SCM_CAR (dynpair
);
713 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
715 jmpbuf
= SCM_CDR (dynpair
);
717 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
721 struct pre_unwind_data
*c
=
722 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
730 /* If we didn't find anything, print a message and abort the process
731 right here. If you don't want this, establish a catch-all around
732 any code that might throw up. */
733 if (scm_is_null (winds
))
735 scm_handle_by_message (NULL
, key
, args
);
739 /* If the wind list is malformed, bail. */
740 if (!scm_is_pair (winds
))
743 for (wind_goal
= scm_i_dynwinds ();
744 (!scm_is_pair (SCM_CAR (wind_goal
))
745 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
746 wind_goal
= SCM_CDR (wind_goal
))
749 /* Is this a throw handler (or lazy catch)? In a wind list entry
750 for a throw handler or lazy catch, the key is bound to a
751 pre_unwind_data smob, not a jmpbuf. */
752 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
754 struct pre_unwind_data
*c
=
755 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
758 /* For old-style lazy-catch behaviour, we unwind the dynamic
759 context before invoking the handler. */
762 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
763 - scm_ilength (wind_goal
)));
764 SCM_CRITICAL_SECTION_START
;
765 handle
= scm_i_dynwinds ();
766 scm_i_set_dynwinds (SCM_CDR (handle
));
767 SCM_CRITICAL_SECTION_END
;
770 /* Call the handler, with framing to set the pre-unwind
771 structure's running field while the handler is running, so we
772 can avoid recursing into the same handler again. Note that
773 if the handler returns normally, the running flag stays
774 set until some kind of non-local jump occurs. */
775 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
776 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
778 SCM_F_WIND_EXPLICITLY
);
779 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
780 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
782 /* There is deliberately no scm_dynwind_end call here. This
783 means that the unwind handler (toggle_pre_unwind_running)
784 stays in place until a non-local exit occurs, and will then
785 reset the pre-unwind structure's running flag. For sample
786 code where this makes a difference, see the "again but with
787 two chained throw handlers" test case in exceptions.test. */
789 /* If the handler returns, rethrow the same key and args. */
793 /* Otherwise, it's a normal catch. */
794 else if (SCM_JMPBUFP (jmpbuf
))
796 struct pre_unwind_data
* pre_unwind
;
797 struct jmp_buf_and_retval
* jbr
;
799 /* Before unwinding anything, run the pre-unwind handler if
800 there is one, and if it isn't already running. */
801 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
802 if (pre_unwind
->handler
&& !pre_unwind
->running
)
804 /* Use framing to detect and avoid possible reentry into
805 this handler, which could otherwise cause an infinite
807 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
808 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
810 SCM_F_WIND_EXPLICITLY
);
811 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
813 SCM_F_WIND_EXPLICITLY
);
814 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
818 /* Now unwind and jump. */
819 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
820 - scm_ilength (wind_goal
)));
821 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
822 jbr
->throw_tag
= key
;
824 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
825 longjmp (*JBJMPBUF (jmpbuf
), 1);
828 /* Otherwise, it's some random piece of junk. */
837 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
838 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
840 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
841 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
843 #include "libguile/throw.x"