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"
45 #include "libguile/private-options.h"
49 /* the jump buffer data structure */
50 static scm_t_bits tc16_jmpbuffer
;
52 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
54 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
55 #define ACTIVATEJB(x) \
56 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
57 #define DEACTIVATEJB(x) \
58 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
60 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
61 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
62 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
63 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
64 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
65 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
68 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
70 scm_puts ("#<jmpbuffer ", port
);
71 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
72 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
81 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
82 SETJBJMPBUF(answer
, (jmp_buf *)0);
88 /* scm_c_catch (the guts of catch) */
90 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
92 jmp_buf buf
; /* must be first */
97 /* These are the structures we use to store pre-unwind handling (aka
98 "lazy") information for a regular catch, and put on the wind list
99 for a "lazy" catch. They store the pre-unwind handler function to
100 call, and the data pointer to pass through to it. It's not a
101 Scheme closure, but it is a function with data, so the term
102 "closure" is appropriate in its broader sense.
104 (We don't need anything like this to run the normal (post-unwind)
105 catch handler, because the same C frame runs both the body and the
108 struct pre_unwind_data
{
109 scm_t_catch_handler handler
;
116 /* scm_c_catch is the guts of catch. It handles all the mechanics of
117 setting up a catch target, invoking the catch body, and perhaps
118 invoking the handler if the body does a throw.
120 The function is designed to be usable from C code, but is general
121 enough to implement all the semantics Guile Scheme expects from
124 TAG is the catch tag. Typically, this is a symbol, but this
125 function doesn't actually care about that.
127 BODY is a pointer to a C function which runs the body of the catch;
128 this is the code you can throw from. We call it like this:
131 BODY_DATA is just the BODY_DATA argument we received; we pass it
132 through to BODY as its first argument. The caller can make
133 BODY_DATA point to anything useful that BODY might need.
135 HANDLER is a pointer to a C function to deal with a throw to TAG,
136 should one occur. We call it like this:
137 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
139 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
140 same idea as BODY_DATA above.
141 THROWN_TAG is the tag that the user threw to; usually this is
142 TAG, but it could be something else if TAG was #t (i.e., a
143 catch-all), or the user threw to a jmpbuf.
144 THROW_ARGS is the list of arguments the user passed to the THROW
145 function, after the tag.
147 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
148 is just a pointer we pass through to HANDLER. We don't actually
149 use either of those pointers otherwise ourselves. The idea is
150 that, if our caller wants to communicate something to BODY or
151 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
152 HANDLER can then use. Think of it as a way to make BODY and
153 HANDLER closures, not just functions; MUMBLE_DATA points to the
156 Of course, it's up to the caller to make sure that any data a
157 MUMBLE_DATA needs is protected from GC. A common way to do this is
158 to make MUMBLE_DATA a pointer to data stored in an automatic
159 structure variable; since the collector must scan the stack for
160 references anyway, this assures that any references in MUMBLE_DATA
164 scm_c_catch (SCM tag
,
165 scm_t_catch_body body
, void *body_data
,
166 scm_t_catch_handler handler
, void *handler_data
,
167 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
169 struct jmp_buf_and_retval jbr
;
172 struct pre_unwind_data pre_unwind
;
174 jmpbuf
= make_jmpbuf ();
176 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
177 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
178 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
180 pre_unwind
.handler
= pre_unwind_handler
;
181 pre_unwind
.handler_data
= pre_unwind_handler_data
;
182 pre_unwind
.running
= 0;
183 pre_unwind
.lazy_catch_p
= 0;
184 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
186 if (setjmp (jbr
.buf
))
191 #ifdef STACK_CHECKING
192 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
194 SCM_CRITICAL_SECTION_START
;
195 DEACTIVATEJB (jmpbuf
);
196 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
197 SCM_CRITICAL_SECTION_END
;
198 throw_args
= jbr
.retval
;
199 throw_tag
= jbr
.throw_tag
;
200 jbr
.throw_tag
= SCM_EOL
;
201 jbr
.retval
= SCM_EOL
;
202 answer
= handler (handler_data
, throw_tag
, throw_args
);
207 answer
= body (body_data
);
208 SCM_CRITICAL_SECTION_START
;
209 DEACTIVATEJB (jmpbuf
);
210 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
211 SCM_CRITICAL_SECTION_END
;
217 scm_internal_catch (SCM tag
,
218 scm_t_catch_body body
, void *body_data
,
219 scm_t_catch_handler handler
, void *handler_data
)
221 return scm_c_catch(tag
,
223 handler
, handler_data
,
229 /* The smob tag for pre_unwind_data smobs. */
230 static scm_t_bits tc16_pre_unwind_data
;
232 /* Strictly speaking, we could just pass a zero for our print
233 function, because we don't need to print them. They should never
234 appear in normal data structures, only in the wind list. However,
235 it might be nice for debugging someday... */
237 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
239 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
242 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
243 (long) c
->handler
, (long) c
->handler_data
);
244 scm_puts (buf
, port
);
250 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
251 suitable for inclusion in the wind list. ("Ah yes, a Château
252 Gollombiere '72, non?"). */
254 make_pre_unwind_data (struct pre_unwind_data
*c
)
256 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
259 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
262 scm_c_with_throw_handler (SCM tag
,
263 scm_t_catch_body body
,
265 scm_t_catch_handler handler
,
269 SCM pre_unwind
, answer
;
270 struct pre_unwind_data c
;
273 c
.handler_data
= handler_data
;
275 c
.lazy_catch_p
= lazy_catch_p
;
276 pre_unwind
= make_pre_unwind_data (&c
);
278 SCM_CRITICAL_SECTION_START
;
279 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
280 SCM_CRITICAL_SECTION_END
;
282 answer
= (*body
) (body_data
);
284 SCM_CRITICAL_SECTION_START
;
285 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
286 SCM_CRITICAL_SECTION_END
;
291 /* Exactly like scm_internal_catch, except:
292 - It does not unwind the stack (this is the major difference).
293 - The handler is not allowed to return. */
295 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
297 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
301 /* scm_internal_stack_catch
302 Use this one if you want debugging information to be stored in
303 scm_the_last_stack_fluid_var on error. */
306 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
309 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
310 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
311 /* Throw the error */
312 return scm_throw (tag
, throw_args
);
318 scm_t_catch_body body
;
323 cwss_body (void *data
)
325 struct cwss_data
*d
= data
;
326 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
330 scm_internal_stack_catch (SCM tag
,
331 scm_t_catch_body body
,
333 scm_t_catch_handler handler
,
340 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
345 /* body and handler functions for use with any of the above catch variants */
347 /* This is a body function you can pass to scm_internal_catch if you
348 want the body to be like Scheme's `catch' --- a thunk.
350 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
351 contains the Scheme procedure to invoke as the body, and the tag
355 scm_body_thunk (void *body_data
)
357 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
359 return scm_call_0 (c
->body_proc
);
363 /* This is a handler function you can pass to scm_internal_catch if
364 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
365 applies a handler procedure to (TAG ARGS ...).
367 If the user does a throw to this catch, this function runs a
368 handler procedure written in Scheme. HANDLER_DATA is a pointer to
369 an SCM variable holding the Scheme procedure object to invoke. It
370 ought to be a pointer to an automatic variable (i.e., one living on
371 the stack), or the procedure object should be otherwise protected
374 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
376 SCM
*handler_proc_p
= (SCM
*) handler_data
;
378 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
381 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
382 catches all throws that the handler might emit itself. The handler
383 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
391 hbpca_body (void *body_data
)
393 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
394 return scm_apply_0 (data
->proc
, data
->args
);
398 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
400 SCM
*handler_proc_p
= (SCM
*) handler_data
;
401 struct hbpca_data data
;
402 data
.proc
= *handler_proc_p
;
403 data
.args
= scm_cons (tag
, throw_args
);
405 return scm_internal_catch (SCM_BOOL_T
,
407 scm_handle_by_message_noexit
, NULL
);
410 /* Derive the an exit status from the arguments to (quit ...). */
412 scm_exit_status (SCM args
)
414 if (!SCM_NULL_OR_NIL_P (args
))
416 SCM cqa
= SCM_CAR (args
);
418 if (scm_is_integer (cqa
))
419 return (scm_to_int (cqa
));
420 else if (scm_is_false (cqa
))
428 handler_message (void *handler_data
, SCM tag
, SCM args
)
430 char *prog_name
= (char *) handler_data
;
431 SCM p
= scm_current_error_port ();
433 if (scm_ilength (args
) == 4)
435 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
436 SCM subr
= SCM_CAR (args
);
437 SCM message
= SCM_CADR (args
);
438 SCM parts
= SCM_CADDR (args
);
439 SCM rest
= SCM_CADDDR (args
);
441 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
445 if (scm_is_eq (tag
, scm_arg_type_key
)
446 || scm_is_eq (tag
, scm_out_of_range_key
))
449 highlights
= SCM_EOL
;
451 scm_puts ("Backtrace:\n", p
);
452 scm_display_backtrace_with_highlights (stack
, p
,
453 SCM_BOOL_F
, SCM_BOOL_F
,
457 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
464 scm_puts (prog_name
, p
);
467 scm_puts ("uncaught throw to ", p
);
468 scm_prin1 (tag
, p
, 0);
470 scm_prin1 (args
, p
, 1);
476 /* This is a handler function to use if you want scheme to print a
477 message and die. Useful for dealing with throws to uncaught keys
480 At boot time, we establish a catch-all that uses this as its handler.
481 1) If the user wants something different, they can use (catch #t
482 ...) to do what they like.
483 2) Outside the context of a read-eval-print loop, there isn't
484 anything else good to do; libguile should not assume the existence
485 of a read-eval-print loop.
486 3) Given that we shouldn't do anything complex, it's much more
487 robust to do it in C code.
489 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
490 message header to print; if zero, we use "guile" instead. That
491 text is followed by a colon, then the message described by ARGS. */
493 /* Dirk:FIXME:: The name of the function should make clear that the
494 * application gets terminated.
498 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
500 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
501 exit (scm_exit_status (args
));
503 handler_message (handler_data
, tag
, args
);
504 scm_i_pthread_exit (NULL
);
506 /* this point not reached, but suppress gcc warning about no return value
507 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
508 to be the case on cygwin for instance) */
513 /* This is just like scm_handle_by_message, but it doesn't exit; it
514 just returns #f. It's useful in cases where you don't really know
515 enough about the body to handle things in a better way, but don't
516 want to let throws fall off the bottom of the wind list. */
518 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
520 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
521 exit (scm_exit_status (args
));
523 handler_message (handler_data
, tag
, args
);
530 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
532 scm_ithrow (tag
, args
, 1);
533 return SCM_UNSPECIFIED
; /* never returns */
538 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
540 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
541 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
542 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
543 "exceptions matching @var{key}. If thunk throws to the symbol\n"
544 "@var{key}, then @var{handler} is invoked this way:\n"
546 "(handler key args ...)\n"
549 "@var{key} is a symbol or @code{#t}.\n"
551 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
552 "normally, that is the return value of @code{catch}.\n"
554 "Handler is invoked outside the scope of its own @code{catch}.\n"
555 "If @var{handler} again throws to the same key, a new handler\n"
556 "from further up the call chain is invoked.\n"
558 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
559 "match this call to @code{catch}.\n"
561 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
562 "an exception that matches @var{key}, Guile calls the\n"
563 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
564 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
565 "be a procedure with the same signature as @var{handler}, that\n"
566 "is @code{(lambda (key . args))}. It is typically used to save\n"
567 "the stack at the point where the exception occurred, but can also\n"
568 "query other parts of the dynamic state at that point, such as\n"
571 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
572 "If it exits normally, Guile unwinds the stack and dynamic context\n"
573 "and then calls the normal (third argument) handler. If it exits\n"
574 "non-locally, that exit determines the continuation.")
575 #define FUNC_NAME s_scm_catch_with_pre_unwind_handler
577 struct scm_body_thunk_data c
;
579 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
580 key
, SCM_ARG1
, FUNC_NAME
);
585 /* scm_c_catch takes care of all the mechanics of setting up a catch
586 key; we tell it to call scm_body_thunk to run the body, and
587 scm_handle_by_proc to deal with any throws to this catch. The
588 former receives a pointer to c, telling it how to behave. The
589 latter receives a pointer to HANDLER, so it knows who to
591 return scm_c_catch (key
,
593 scm_handle_by_proc
, &handler
,
594 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
595 &pre_unwind_handler
);
599 /* The following function exists to provide backwards compatibility
600 for the C scm_catch API. Otherwise we could just change
601 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
603 scm_catch (SCM key
, SCM thunk
, SCM handler
)
605 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
609 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
610 (SCM key
, SCM thunk
, SCM handler
),
611 "Add @var{handler} to the dynamic context as a throw handler\n"
612 "for key @var{key}, then invoke @var{thunk}.")
613 #define FUNC_NAME s_scm_with_throw_handler
615 struct scm_body_thunk_data c
;
617 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
618 key
, SCM_ARG1
, FUNC_NAME
);
623 /* scm_c_with_throw_handler takes care of the mechanics of setting
624 up a throw handler; we tell it to call scm_body_thunk to run the
625 body, and scm_handle_by_proc to deal with any throws to this
626 handler. The former receives a pointer to c, telling it how to
627 behave. The latter receives a pointer to HANDLER, so it knows
629 return scm_c_with_throw_handler (key
,
631 scm_handle_by_proc
, &handler
,
636 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
637 (SCM key
, SCM thunk
, SCM handler
),
638 "This behaves exactly like @code{catch}, except that it does\n"
639 "not unwind the stack before invoking @var{handler}.\n"
640 "If the @var{handler} procedure returns normally, Guile\n"
641 "rethrows the same exception again to the next innermost catch,\n"
642 "lazy-catch or throw handler. If the @var{handler} exits\n"
643 "non-locally, that exit determines the continuation.")
644 #define FUNC_NAME s_scm_lazy_catch
646 struct scm_body_thunk_data c
;
648 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
649 key
, SCM_ARG1
, FUNC_NAME
);
654 /* scm_internal_lazy_catch takes care of all the mechanics of
655 setting up a lazy catch key; we tell it to call scm_body_thunk to
656 run the body, and scm_handle_by_proc to deal with any throws to
657 this catch. The former receives a pointer to c, telling it how
658 to behave. The latter receives a pointer to HANDLER, so it knows
660 return scm_internal_lazy_catch (key
,
662 scm_handle_by_proc
, &handler
);
670 static void toggle_pre_unwind_running (void *data
)
672 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
673 pre_unwind
->running
= !pre_unwind
->running
;
676 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
678 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
679 "@var{handler}. \n\n"
680 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
682 "If there is no handler at all, Guile prints an error and then exits.")
683 #define FUNC_NAME s_scm_throw
685 SCM_VALIDATE_SYMBOL (1, key
);
686 return scm_ithrow (key
, args
, 1);
691 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
693 SCM jmpbuf
= SCM_UNDEFINED
;
696 SCM dynpair
= SCM_UNDEFINED
;
699 if (scm_i_critical_section_level
)
705 We have much better routines for displaying Scheme, but we're
706 already inside a pernicious error, and it's unlikely that they
707 are available to us. We try to print something useful anyway,
708 so users don't need a debugger to find out what went wrong.
710 fprintf (stderr
, "throw from within critical section.\n");
711 if (scm_is_symbol (key
))
712 fprintf (stderr
, "error key: %s\n", scm_i_symbol_chars (key
));
715 for (; scm_is_pair (s
); s
= scm_cdr (s
), i
++)
717 char const *str
= NULL
;
718 if (scm_is_string (scm_car (s
)))
719 str
= scm_i_string_chars (scm_car (s
));
720 else if (scm_is_symbol (scm_car (s
)))
721 str
= scm_i_symbol_chars (scm_car (s
));
724 fprintf (stderr
, "argument %d: %s\n", i
, str
);
731 /* Search the wind list for an appropriate catch.
732 "Waiter, please bring us the wind list." */
733 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
735 dynpair
= SCM_CAR (winds
);
736 if (scm_is_pair (dynpair
))
738 SCM this_key
= SCM_CAR (dynpair
);
740 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
742 jmpbuf
= SCM_CDR (dynpair
);
744 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
748 struct pre_unwind_data
*c
=
749 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
757 /* If we didn't find anything, print a message and abort the process
758 right here. If you don't want this, establish a catch-all around
759 any code that might throw up. */
760 if (scm_is_null (winds
))
762 scm_handle_by_message (NULL
, key
, args
);
766 /* If the wind list is malformed, bail. */
767 if (!scm_is_pair (winds
))
770 for (wind_goal
= scm_i_dynwinds ();
771 (!scm_is_pair (SCM_CAR (wind_goal
))
772 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
773 wind_goal
= SCM_CDR (wind_goal
))
776 /* Is this a throw handler (or lazy catch)? In a wind list entry
777 for a throw handler or lazy catch, the key is bound to a
778 pre_unwind_data smob, not a jmpbuf. */
779 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
781 struct pre_unwind_data
*c
=
782 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
785 /* For old-style lazy-catch behaviour, we unwind the dynamic
786 context before invoking the handler. */
789 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
790 - scm_ilength (wind_goal
)));
791 SCM_CRITICAL_SECTION_START
;
792 handle
= scm_i_dynwinds ();
793 scm_i_set_dynwinds (SCM_CDR (handle
));
794 SCM_CRITICAL_SECTION_END
;
797 /* Call the handler, with framing to set the pre-unwind
798 structure's running field while the handler is running, so we
799 can avoid recursing into the same handler again. Note that
800 if the handler returns normally, the running flag stays
801 set until some kind of non-local jump occurs. */
802 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
803 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
805 SCM_F_WIND_EXPLICITLY
);
806 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
807 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
809 /* There is deliberately no scm_dynwind_end call here. This
810 means that the unwind handler (toggle_pre_unwind_running)
811 stays in place until a non-local exit occurs, and will then
812 reset the pre-unwind structure's running flag. For sample
813 code where this makes a difference, see the "again but with
814 two chained throw handlers" test case in exceptions.test. */
816 /* If the handler returns, rethrow the same key and args. */
820 /* Otherwise, it's a normal catch. */
821 else if (SCM_JMPBUFP (jmpbuf
))
823 struct pre_unwind_data
* pre_unwind
;
824 struct jmp_buf_and_retval
* jbr
;
826 /* Before unwinding anything, run the pre-unwind handler if
827 there is one, and if it isn't already running. */
828 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
829 if (pre_unwind
->handler
&& !pre_unwind
->running
)
831 /* Use framing to detect and avoid possible reentry into
832 this handler, which could otherwise cause an infinite
834 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
835 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
837 SCM_F_WIND_EXPLICITLY
);
838 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
840 SCM_F_WIND_EXPLICITLY
);
841 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
845 /* Now unwind and jump. */
846 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
847 - scm_ilength (wind_goal
)));
848 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
849 jbr
->throw_tag
= key
;
851 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
852 longjmp (*JBJMPBUF (jmpbuf
), 1);
855 /* Otherwise, it's some random piece of junk. */
860 /* On IA64, we #define longjmp as setcontext, and GCC appears not to
861 know that that doesn't return. */
862 return SCM_UNSPECIFIED
;
870 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
871 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
873 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
874 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
876 #include "libguile/throw.x"