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"
40 #include "libguile/strings.h"
43 /* the jump buffer data structure */
44 static scm_t_bits tc16_jmpbuffer
;
46 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
48 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
49 #define ACTIVATEJB(x) \
50 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
51 #define DEACTIVATEJB(x) \
52 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
54 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
55 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
56 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
57 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
58 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
59 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
62 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
64 scm_puts ("#<jmpbuffer ", port
);
65 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
66 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
75 SCM_CRITICAL_SECTION_START
;
77 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
78 SETJBJMPBUF(answer
, (jmp_buf *)0);
81 SCM_CRITICAL_SECTION_END
;
86 /* scm_c_catch (the guts of catch) */
88 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
90 jmp_buf buf
; /* must be first */
95 /* These are the structures we use to store pre-unwind handling (aka
96 "lazy") information for a regular catch, and put on the wind list
97 for a "lazy" catch. They store the pre-unwind handler function to
98 call, and the data pointer to pass through to it. It's not a
99 Scheme closure, but it is a function with data, so the term
100 "closure" is appropriate in its broader sense.
102 (We don't need anything like this to run the normal (post-unwind)
103 catch handler, because the same C frame runs both the body and the
106 struct pre_unwind_data
{
107 scm_t_catch_handler handler
;
114 /* scm_c_catch is the guts of catch. It handles all the mechanics of
115 setting up a catch target, invoking the catch body, and perhaps
116 invoking the handler if the body does a throw.
118 The function is designed to be usable from C code, but is general
119 enough to implement all the semantics Guile Scheme expects from
122 TAG is the catch tag. Typically, this is a symbol, but this
123 function doesn't actually care about that.
125 BODY is a pointer to a C function which runs the body of the catch;
126 this is the code you can throw from. We call it like this:
129 BODY_DATA is just the BODY_DATA argument we received; we pass it
130 through to BODY as its first argument. The caller can make
131 BODY_DATA point to anything useful that BODY might need.
133 HANDLER is a pointer to a C function to deal with a throw to TAG,
134 should one occur. We call it like this:
135 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
137 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
138 same idea as BODY_DATA above.
139 THROWN_TAG is the tag that the user threw to; usually this is
140 TAG, but it could be something else if TAG was #t (i.e., a
141 catch-all), or the user threw to a jmpbuf.
142 THROW_ARGS is the list of arguments the user passed to the THROW
143 function, after the tag.
145 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
146 is just a pointer we pass through to HANDLER. We don't actually
147 use either of those pointers otherwise ourselves. The idea is
148 that, if our caller wants to communicate something to BODY or
149 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
150 HANDLER can then use. Think of it as a way to make BODY and
151 HANDLER closures, not just functions; MUMBLE_DATA points to the
154 Of course, it's up to the caller to make sure that any data a
155 MUMBLE_DATA needs is protected from GC. A common way to do this is
156 to make MUMBLE_DATA a pointer to data stored in an automatic
157 structure variable; since the collector must scan the stack for
158 references anyway, this assures that any references in MUMBLE_DATA
162 scm_c_catch (SCM tag
,
163 scm_t_catch_body body
, void *body_data
,
164 scm_t_catch_handler handler
, void *handler_data
,
165 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
167 struct jmp_buf_and_retval jbr
;
170 struct pre_unwind_data pre_unwind
;
172 jmpbuf
= make_jmpbuf ();
174 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
175 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
176 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
178 pre_unwind
.handler
= pre_unwind_handler
;
179 pre_unwind
.handler_data
= pre_unwind_handler_data
;
180 pre_unwind
.running
= 0;
181 pre_unwind
.lazy_catch_p
= 0;
182 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
184 if (setjmp (jbr
.buf
))
189 #ifdef STACK_CHECKING
190 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
192 SCM_CRITICAL_SECTION_START
;
193 DEACTIVATEJB (jmpbuf
);
194 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
195 SCM_CRITICAL_SECTION_END
;
196 throw_args
= jbr
.retval
;
197 throw_tag
= jbr
.throw_tag
;
198 jbr
.throw_tag
= SCM_EOL
;
199 jbr
.retval
= SCM_EOL
;
200 answer
= handler (handler_data
, throw_tag
, throw_args
);
205 answer
= body (body_data
);
206 SCM_CRITICAL_SECTION_START
;
207 DEACTIVATEJB (jmpbuf
);
208 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
209 SCM_CRITICAL_SECTION_END
;
215 scm_internal_catch (SCM tag
,
216 scm_t_catch_body body
, void *body_data
,
217 scm_t_catch_handler handler
, void *handler_data
)
219 return scm_c_catch(tag
,
221 handler
, handler_data
,
227 /* The smob tag for pre_unwind_data smobs. */
228 static scm_t_bits tc16_pre_unwind_data
;
230 /* Strictly speaking, we could just pass a zero for our print
231 function, because we don't need to print them. They should never
232 appear in normal data structures, only in the wind list. However,
233 it might be nice for debugging someday... */
235 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
237 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
240 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
241 (long) c
->handler
, (long) c
->handler_data
);
242 scm_puts (buf
, port
);
248 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
249 suitable for inclusion in the wind list. ("Ah yes, a Château
250 Gollombiere '72, non?"). */
252 make_pre_unwind_data (struct pre_unwind_data
*c
)
254 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
257 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
260 scm_c_with_throw_handler (SCM tag
,
261 scm_t_catch_body body
,
263 scm_t_catch_handler handler
,
267 SCM pre_unwind
, answer
;
268 struct pre_unwind_data c
;
271 c
.handler_data
= handler_data
;
273 c
.lazy_catch_p
= lazy_catch_p
;
274 pre_unwind
= make_pre_unwind_data (&c
);
276 SCM_CRITICAL_SECTION_START
;
277 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
278 SCM_CRITICAL_SECTION_END
;
280 answer
= (*body
) (body_data
);
282 SCM_CRITICAL_SECTION_START
;
283 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
284 SCM_CRITICAL_SECTION_END
;
289 /* Exactly like scm_internal_catch, except:
290 - It does not unwind the stack (this is the major difference).
291 - The handler is not allowed to return. */
293 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
295 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
299 /* scm_internal_stack_catch
300 Use this one if you want debugging information to be stored in
301 scm_the_last_stack_fluid_var on error. */
304 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
307 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
308 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
309 /* Throw the error */
310 return scm_throw (tag
, throw_args
);
316 scm_t_catch_body body
;
321 cwss_body (void *data
)
323 struct cwss_data
*d
= data
;
324 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
328 scm_internal_stack_catch (SCM tag
,
329 scm_t_catch_body body
,
331 scm_t_catch_handler handler
,
338 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
343 /* body and handler functions for use with any of the above catch variants */
345 /* This is a body function you can pass to scm_internal_catch if you
346 want the body to be like Scheme's `catch' --- a thunk.
348 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
349 contains the Scheme procedure to invoke as the body, and the tag
353 scm_body_thunk (void *body_data
)
355 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
357 return scm_call_0 (c
->body_proc
);
361 /* This is a handler function you can pass to scm_internal_catch if
362 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
363 applies a handler procedure to (TAG ARGS ...).
365 If the user does a throw to this catch, this function runs a
366 handler procedure written in Scheme. HANDLER_DATA is a pointer to
367 an SCM variable holding the Scheme procedure object to invoke. It
368 ought to be a pointer to an automatic variable (i.e., one living on
369 the stack), or the procedure object should be otherwise protected
372 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
374 SCM
*handler_proc_p
= (SCM
*) handler_data
;
376 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
379 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
380 catches all throws that the handler might emit itself. The handler
381 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
389 hbpca_body (void *body_data
)
391 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
392 return scm_apply_0 (data
->proc
, data
->args
);
396 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
398 SCM
*handler_proc_p
= (SCM
*) handler_data
;
399 struct hbpca_data data
;
400 data
.proc
= *handler_proc_p
;
401 data
.args
= scm_cons (tag
, throw_args
);
403 return scm_internal_catch (SCM_BOOL_T
,
405 scm_handle_by_message_noexit
, NULL
);
408 /* Derive the an exit status from the arguments to (quit ...). */
410 scm_exit_status (SCM args
)
412 if (!SCM_NULL_OR_NIL_P (args
))
414 SCM cqa
= SCM_CAR (args
);
416 if (scm_is_integer (cqa
))
417 return (scm_to_int (cqa
));
418 else if (scm_is_false (cqa
))
426 handler_message (void *handler_data
, SCM tag
, SCM args
)
428 char *prog_name
= (char *) handler_data
;
429 SCM p
= scm_current_error_port ();
431 if (scm_ilength (args
) == 4)
433 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
434 SCM subr
= SCM_CAR (args
);
435 SCM message
= SCM_CADR (args
);
436 SCM parts
= SCM_CADDR (args
);
437 SCM rest
= SCM_CADDDR (args
);
439 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
443 if (scm_is_eq (tag
, scm_arg_type_key
)
444 || scm_is_eq (tag
, scm_out_of_range_key
))
447 highlights
= SCM_EOL
;
449 scm_puts ("Backtrace:\n", p
);
450 scm_display_backtrace_with_highlights (stack
, p
,
451 SCM_BOOL_F
, SCM_BOOL_F
,
455 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
462 scm_puts (prog_name
, p
);
465 scm_puts ("uncaught throw to ", p
);
466 scm_prin1 (tag
, p
, 0);
468 scm_prin1 (args
, p
, 1);
474 /* This is a handler function to use if you want scheme to print a
475 message and die. Useful for dealing with throws to uncaught keys
478 At boot time, we establish a catch-all that uses this as its handler.
479 1) If the user wants something different, they can use (catch #t
480 ...) to do what they like.
481 2) Outside the context of a read-eval-print loop, there isn't
482 anything else good to do; libguile should not assume the existence
483 of a read-eval-print loop.
484 3) Given that we shouldn't do anything complex, it's much more
485 robust to do it in C code.
487 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
488 message header to print; if zero, we use "guile" instead. That
489 text is followed by a colon, then the message described by ARGS. */
491 /* Dirk:FIXME:: The name of the function should make clear that the
492 * application gets terminated.
496 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
498 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
499 exit (scm_exit_status (args
));
501 handler_message (handler_data
, tag
, args
);
502 scm_i_pthread_exit (NULL
);
504 /* this point not reached, but suppress gcc warning about no return value
505 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
506 to be the case on cygwin for instance) */
511 /* This is just like scm_handle_by_message, but it doesn't exit; it
512 just returns #f. It's useful in cases where you don't really know
513 enough about the body to handle things in a better way, but don't
514 want to let throws fall off the bottom of the wind list. */
516 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
518 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
519 exit (scm_exit_status (args
));
521 handler_message (handler_data
, tag
, args
);
528 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
530 scm_ithrow (tag
, args
, 1);
531 return SCM_UNSPECIFIED
; /* never returns */
536 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
538 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
539 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
540 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
541 "exceptions matching @var{key}. If thunk throws to the symbol\n"
542 "@var{key}, then @var{handler} is invoked this way:\n"
544 "(handler key args ...)\n"
547 "@var{key} is a symbol or @code{#t}.\n"
549 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
550 "normally, that is the return value of @code{catch}.\n"
552 "Handler is invoked outside the scope of its own @code{catch}.\n"
553 "If @var{handler} again throws to the same key, a new handler\n"
554 "from further up the call chain is invoked.\n"
556 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
557 "match this call to @code{catch}.\n"
559 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
560 "an exception that matches @var{key}, Guile calls the\n"
561 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
562 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
563 "be a procedure with the same signature as @var{handler}, that\n"
564 "is @code{(lambda (key . args))}. It is typically used to save\n"
565 "the stack at the point where the exception occurred, but can also\n"
566 "query other parts of the dynamic state at that point, such as\n"
569 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
570 "If it exits normally, Guile unwinds the stack and dynamic context\n"
571 "and then calls the normal (third argument) handler. If it exits\n"
572 "non-locally, that exit determines the continuation.")
573 #define FUNC_NAME s_scm_catch_with_pre_unwind_handler
575 struct scm_body_thunk_data c
;
577 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
578 key
, SCM_ARG1
, FUNC_NAME
);
583 /* scm_c_catch takes care of all the mechanics of setting up a catch
584 key; we tell it to call scm_body_thunk to run the body, and
585 scm_handle_by_proc to deal with any throws to this catch. The
586 former receives a pointer to c, telling it how to behave. The
587 latter receives a pointer to HANDLER, so it knows who to
589 return scm_c_catch (key
,
591 scm_handle_by_proc
, &handler
,
592 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
593 &pre_unwind_handler
);
597 /* The following function exists to provide backwards compatibility
598 for the C scm_catch API. Otherwise we could just change
599 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
601 scm_catch (SCM key
, SCM thunk
, SCM handler
)
603 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
607 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
608 (SCM key
, SCM thunk
, SCM handler
),
609 "Add @var{handler} to the dynamic context as a throw handler\n"
610 "for key @var{key}, then invoke @var{thunk}.")
611 #define FUNC_NAME s_scm_with_throw_handler
613 struct scm_body_thunk_data c
;
615 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
616 key
, SCM_ARG1
, FUNC_NAME
);
621 /* scm_c_with_throw_handler takes care of the mechanics of setting
622 up a throw handler; we tell it to call scm_body_thunk to run the
623 body, and scm_handle_by_proc to deal with any throws to this
624 handler. The former receives a pointer to c, telling it how to
625 behave. The latter receives a pointer to HANDLER, so it knows
627 return scm_c_with_throw_handler (key
,
629 scm_handle_by_proc
, &handler
,
634 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
635 (SCM key
, SCM thunk
, SCM handler
),
636 "This behaves exactly like @code{catch}, except that it does\n"
637 "not unwind the stack before invoking @var{handler}.\n"
638 "If the @var{handler} procedure returns normally, Guile\n"
639 "rethrows the same exception again to the next innermost catch,\n"
640 "lazy-catch or throw handler. If the @var{handler} exits\n"
641 "non-locally, that exit determines the continuation.")
642 #define FUNC_NAME s_scm_lazy_catch
644 struct scm_body_thunk_data c
;
646 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
647 key
, SCM_ARG1
, FUNC_NAME
);
652 /* scm_internal_lazy_catch takes care of all the mechanics of
653 setting up a lazy catch key; we tell it to call scm_body_thunk to
654 run the body, and scm_handle_by_proc to deal with any throws to
655 this catch. The former receives a pointer to c, telling it how
656 to behave. The latter receives a pointer to HANDLER, so it knows
658 return scm_internal_lazy_catch (key
,
660 scm_handle_by_proc
, &handler
);
668 static void toggle_pre_unwind_running (void *data
)
670 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
671 pre_unwind
->running
= !pre_unwind
->running
;
674 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
676 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
677 "@var{handler}. \n\n"
678 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
680 "If there is no handler at all, Guile prints an error and then exits.")
681 #define FUNC_NAME s_scm_throw
683 SCM_VALIDATE_SYMBOL (1, key
);
684 return scm_ithrow (key
, args
, 1);
689 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
691 SCM jmpbuf
= SCM_UNDEFINED
;
694 SCM dynpair
= SCM_UNDEFINED
;
697 if (scm_i_critical_section_level
)
703 We have much better routines for displaying Scheme, but we're
704 already inside a pernicious error, and it's unlikely that they
705 are available to us. We try to print something useful anyway,
706 so users don't need a debugger to find out what went wrong.
708 fprintf (stderr
, "throw from within critical section.\n");
709 if (scm_is_symbol (key
))
710 fprintf (stderr
, "error key: %s\n", scm_i_symbol_chars (key
));
713 for (; scm_is_pair (s
); s
= scm_cdr (s
), i
++)
714 if (scm_is_string (scm_car (s
)))
715 fprintf (stderr
, "argument %d: %s\n", i
, scm_i_string_chars (scm_car (s
)));
722 /* Search the wind list for an appropriate catch.
723 "Waiter, please bring us the wind list." */
724 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
726 dynpair
= SCM_CAR (winds
);
727 if (scm_is_pair (dynpair
))
729 SCM this_key
= SCM_CAR (dynpair
);
731 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
733 jmpbuf
= SCM_CDR (dynpair
);
735 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
739 struct pre_unwind_data
*c
=
740 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
748 /* If we didn't find anything, print a message and abort the process
749 right here. If you don't want this, establish a catch-all around
750 any code that might throw up. */
751 if (scm_is_null (winds
))
753 scm_handle_by_message (NULL
, key
, args
);
757 /* If the wind list is malformed, bail. */
758 if (!scm_is_pair (winds
))
761 for (wind_goal
= scm_i_dynwinds ();
762 (!scm_is_pair (SCM_CAR (wind_goal
))
763 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
764 wind_goal
= SCM_CDR (wind_goal
))
767 /* Is this a throw handler (or lazy catch)? In a wind list entry
768 for a throw handler or lazy catch, the key is bound to a
769 pre_unwind_data smob, not a jmpbuf. */
770 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
772 struct pre_unwind_data
*c
=
773 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
776 /* For old-style lazy-catch behaviour, we unwind the dynamic
777 context before invoking the handler. */
780 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
781 - scm_ilength (wind_goal
)));
782 SCM_CRITICAL_SECTION_START
;
783 handle
= scm_i_dynwinds ();
784 scm_i_set_dynwinds (SCM_CDR (handle
));
785 SCM_CRITICAL_SECTION_END
;
788 /* Call the handler, with framing to set the pre-unwind
789 structure's running field while the handler is running, so we
790 can avoid recursing into the same handler again. Note that
791 if the handler returns normally, the running flag stays
792 set until some kind of non-local jump occurs. */
793 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
794 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
796 SCM_F_WIND_EXPLICITLY
);
797 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
798 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
800 /* There is deliberately no scm_dynwind_end call here. This
801 means that the unwind handler (toggle_pre_unwind_running)
802 stays in place until a non-local exit occurs, and will then
803 reset the pre-unwind structure's running flag. For sample
804 code where this makes a difference, see the "again but with
805 two chained throw handlers" test case in exceptions.test. */
807 /* If the handler returns, rethrow the same key and args. */
811 /* Otherwise, it's a normal catch. */
812 else if (SCM_JMPBUFP (jmpbuf
))
814 struct pre_unwind_data
* pre_unwind
;
815 struct jmp_buf_and_retval
* jbr
;
817 /* Before unwinding anything, run the pre-unwind handler if
818 there is one, and if it isn't already running. */
819 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
820 if (pre_unwind
->handler
&& !pre_unwind
->running
)
822 /* Use framing to detect and avoid possible reentry into
823 this handler, which could otherwise cause an infinite
825 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
826 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
828 SCM_F_WIND_EXPLICITLY
);
829 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
831 SCM_F_WIND_EXPLICITLY
);
832 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
836 /* Now unwind and jump. */
837 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
838 - scm_ilength (wind_goal
)));
839 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
840 jbr
->throw_tag
= key
;
842 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
843 longjmp (*JBJMPBUF (jmpbuf
), 1);
846 /* Otherwise, it's some random piece of junk. */
855 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
856 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
858 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
859 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
861 #include "libguile/throw.x"