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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
27 #include "libguile/_scm.h"
28 #include "libguile/async.h"
29 #include "libguile/smob.h"
30 #include "libguile/alist.h"
31 #include "libguile/eval.h"
32 #include "libguile/eq.h"
33 #include "libguile/dynwind.h"
34 #include "libguile/backtrace.h"
35 #include "libguile/debug.h"
36 #include "libguile/continuations.h"
37 #include "libguile/stackchk.h"
38 #include "libguile/stacks.h"
39 #include "libguile/fluids.h"
40 #include "libguile/ports.h"
41 #include "libguile/lang.h"
42 #include "libguile/validate.h"
43 #include "libguile/throw.h"
44 #include "libguile/init.h"
45 #include "libguile/strings.h"
46 #include "libguile/vm.h"
48 #include "libguile/private-options.h"
52 /* the jump buffer data structure */
53 static scm_t_bits tc16_jmpbuffer
;
55 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
57 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
58 #define ACTIVATEJB(x) \
59 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
60 #define DEACTIVATEJB(x) \
61 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
63 #define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
64 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
65 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
66 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
67 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
68 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
71 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
73 scm_puts ("#<jmpbuffer ", port
);
74 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
75 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
84 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
85 SETJBJMPBUF(answer
, (scm_i_jmp_buf
*)0);
91 /* scm_c_catch (the guts of catch) */
93 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
95 scm_i_jmp_buf buf
; /* must be first */
100 /* These are the structures we use to store pre-unwind handling (aka
101 "lazy") information for a regular catch, and put on the wind list
102 for a "lazy" catch. They store the pre-unwind handler function to
103 call, and the data pointer to pass through to it. It's not a
104 Scheme closure, but it is a function with data, so the term
105 "closure" is appropriate in its broader sense.
107 (We don't need anything like this to run the normal (post-unwind)
108 catch handler, because the same C frame runs both the body and the
111 struct pre_unwind_data
{
112 scm_t_catch_handler handler
;
119 /* scm_c_catch is the guts of catch. It handles all the mechanics of
120 setting up a catch target, invoking the catch body, and perhaps
121 invoking the handler if the body does a throw.
123 The function is designed to be usable from C code, but is general
124 enough to implement all the semantics Guile Scheme expects from
127 TAG is the catch tag. Typically, this is a symbol, but this
128 function doesn't actually care about that.
130 BODY is a pointer to a C function which runs the body of the catch;
131 this is the code you can throw from. We call it like this:
134 BODY_DATA is just the BODY_DATA argument we received; we pass it
135 through to BODY as its first argument. The caller can make
136 BODY_DATA point to anything useful that BODY might need.
138 HANDLER is a pointer to a C function to deal with a throw to TAG,
139 should one occur. We call it like this:
140 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
142 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
143 same idea as BODY_DATA above.
144 THROWN_TAG is the tag that the user threw to; usually this is
145 TAG, but it could be something else if TAG was #t (i.e., a
146 catch-all), or the user threw to a jmpbuf.
147 THROW_ARGS is the list of arguments the user passed to the THROW
148 function, after the tag.
150 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
151 is just a pointer we pass through to HANDLER. We don't actually
152 use either of those pointers otherwise ourselves. The idea is
153 that, if our caller wants to communicate something to BODY or
154 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
155 HANDLER can then use. Think of it as a way to make BODY and
156 HANDLER closures, not just functions; MUMBLE_DATA points to the
159 Of course, it's up to the caller to make sure that any data a
160 MUMBLE_DATA needs is protected from GC. A common way to do this is
161 to make MUMBLE_DATA a pointer to data stored in an automatic
162 structure variable; since the collector must scan the stack for
163 references anyway, this assures that any references in MUMBLE_DATA
167 scm_c_catch (SCM tag
,
168 scm_t_catch_body body
, void *body_data
,
169 scm_t_catch_handler handler
, void *handler_data
,
170 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
172 struct jmp_buf_and_retval jbr
;
176 SCM
*sp
= NULL
, *fp
= NULL
; /* to reset the vm */
177 struct pre_unwind_data pre_unwind
;
180 if (SCM_NFALSEP (vm
))
182 sp
= SCM_VM_DATA (vm
)->sp
;
183 fp
= SCM_VM_DATA (vm
)->fp
;
186 jmpbuf
= make_jmpbuf ();
188 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
189 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
190 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
192 pre_unwind
.handler
= pre_unwind_handler
;
193 pre_unwind
.handler_data
= pre_unwind_handler_data
;
194 pre_unwind
.running
= 0;
195 pre_unwind
.lazy_catch_p
= 0;
196 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
198 if (SCM_I_SETJMP (jbr
.buf
))
203 #ifdef STACK_CHECKING
204 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
206 SCM_CRITICAL_SECTION_START
;
207 DEACTIVATEJB (jmpbuf
);
208 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
209 SCM_CRITICAL_SECTION_END
;
210 throw_args
= jbr
.retval
;
211 throw_tag
= jbr
.throw_tag
;
212 jbr
.throw_tag
= SCM_EOL
;
213 jbr
.retval
= SCM_EOL
;
214 if (SCM_NFALSEP (vm
))
216 SCM_VM_DATA (vm
)->sp
= sp
;
217 SCM_VM_DATA (vm
)->fp
= fp
;
218 #ifdef VM_ENABLE_STACK_NULLING
219 /* see vm.c -- you'll have to enable this manually */
221 (SCM_VM_DATA (vm
)->stack_size
222 - (sp
+ 1 - SCM_VM_DATA (vm
)->stack_base
)) * sizeof(SCM
));
225 else if (SCM_NFALSEP ((vm
= scm_the_vm ())))
227 /* oof, it's possible this catch was called before the vm was
228 booted... yick. anyway, try to reset the vm stack. */
229 SCM_VM_DATA (vm
)->sp
= SCM_VM_DATA (vm
)->stack_base
- 1;
230 SCM_VM_DATA (vm
)->fp
= NULL
;
231 #ifdef VM_ENABLE_STACK_NULLING
232 /* see vm.c -- you'll have to enable this manually */
233 memset (SCM_VM_DATA (vm
)->stack_base
, 0,
234 SCM_VM_DATA (vm
)->stack_size
* sizeof(SCM
));
238 answer
= handler (handler_data
, throw_tag
, throw_args
);
243 answer
= body (body_data
);
244 SCM_CRITICAL_SECTION_START
;
245 DEACTIVATEJB (jmpbuf
);
246 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
247 SCM_CRITICAL_SECTION_END
;
253 scm_internal_catch (SCM tag
,
254 scm_t_catch_body body
, void *body_data
,
255 scm_t_catch_handler handler
, void *handler_data
)
257 return scm_c_catch(tag
,
259 handler
, handler_data
,
265 /* The smob tag for pre_unwind_data smobs. */
266 static scm_t_bits tc16_pre_unwind_data
;
268 /* Strictly speaking, we could just pass a zero for our print
269 function, because we don't need to print them. They should never
270 appear in normal data structures, only in the wind list. However,
271 it might be nice for debugging someday... */
273 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
275 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
278 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
279 (long) c
->handler
, (long) c
->handler_data
);
280 scm_puts (buf
, port
);
286 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
287 suitable for inclusion in the wind list. ("Ah yes, a Château
288 Gollombiere '72, non?"). */
290 make_pre_unwind_data (struct pre_unwind_data
*c
)
292 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
295 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
298 scm_c_with_throw_handler (SCM tag
,
299 scm_t_catch_body body
,
301 scm_t_catch_handler handler
,
305 SCM pre_unwind
, answer
;
306 struct pre_unwind_data c
;
309 c
.handler_data
= handler_data
;
311 c
.lazy_catch_p
= lazy_catch_p
;
312 pre_unwind
= make_pre_unwind_data (&c
);
314 SCM_CRITICAL_SECTION_START
;
315 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
316 SCM_CRITICAL_SECTION_END
;
318 answer
= (*body
) (body_data
);
320 SCM_CRITICAL_SECTION_START
;
321 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
322 SCM_CRITICAL_SECTION_END
;
327 /* Exactly like scm_internal_catch, except:
328 - It does not unwind the stack (this is the major difference).
329 - The handler is not allowed to return. */
331 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
333 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
337 /* scm_internal_stack_catch
338 Use this one if you want debugging information to be stored in
339 scm_the_last_stack_fluid_var on error. */
342 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
345 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
346 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
347 /* Throw the error */
348 return scm_throw (tag
, throw_args
);
354 scm_t_catch_body body
;
359 cwss_body (void *data
)
361 struct cwss_data
*d
= data
;
362 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
366 scm_internal_stack_catch (SCM tag
,
367 scm_t_catch_body body
,
369 scm_t_catch_handler handler
,
376 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
381 /* body and handler functions for use with any of the above catch variants */
383 /* This is a body function you can pass to scm_internal_catch if you
384 want the body to be like Scheme's `catch' --- a thunk.
386 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
387 contains the Scheme procedure to invoke as the body, and the tag
391 scm_body_thunk (void *body_data
)
393 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
395 return scm_call_0 (c
->body_proc
);
399 /* This is a handler function you can pass to scm_internal_catch if
400 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
401 applies a handler procedure to (TAG ARGS ...).
403 If the user does a throw to this catch, this function runs a
404 handler procedure written in Scheme. HANDLER_DATA is a pointer to
405 an SCM variable holding the Scheme procedure object to invoke. It
406 ought to be a pointer to an automatic variable (i.e., one living on
407 the stack), or the procedure object should be otherwise protected
410 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
412 SCM
*handler_proc_p
= (SCM
*) handler_data
;
414 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
417 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
418 catches all throws that the handler might emit itself. The handler
419 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
427 hbpca_body (void *body_data
)
429 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
430 return scm_apply_0 (data
->proc
, data
->args
);
434 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
436 SCM
*handler_proc_p
= (SCM
*) handler_data
;
437 struct hbpca_data data
;
438 data
.proc
= *handler_proc_p
;
439 data
.args
= scm_cons (tag
, throw_args
);
441 return scm_internal_catch (SCM_BOOL_T
,
443 scm_handle_by_message_noexit
, NULL
);
446 /* Derive the an exit status from the arguments to (quit ...). */
448 scm_exit_status (SCM args
)
450 if (!SCM_NULL_OR_NIL_P (args
))
452 SCM cqa
= SCM_CAR (args
);
454 if (scm_is_integer (cqa
))
455 return (scm_to_int (cqa
));
456 else if (scm_is_false (cqa
))
464 handler_message (void *handler_data
, SCM tag
, SCM args
)
466 char *prog_name
= (char *) handler_data
;
467 SCM p
= scm_current_error_port ();
469 if (scm_ilength (args
) == 4)
471 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
472 SCM subr
= SCM_CAR (args
);
473 SCM message
= SCM_CADR (args
);
474 SCM parts
= SCM_CADDR (args
);
475 SCM rest
= SCM_CADDDR (args
);
477 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
481 if (scm_is_eq (tag
, scm_arg_type_key
)
482 || scm_is_eq (tag
, scm_out_of_range_key
))
485 highlights
= SCM_EOL
;
487 scm_puts ("Backtrace:\n", p
);
488 scm_display_backtrace_with_highlights (stack
, p
,
489 SCM_BOOL_F
, SCM_BOOL_F
,
493 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
500 scm_puts (prog_name
, p
);
503 scm_puts ("uncaught throw to ", p
);
504 scm_prin1 (tag
, p
, 0);
506 scm_prin1 (args
, p
, 1);
512 /* This is a handler function to use if you want scheme to print a
513 message and die. Useful for dealing with throws to uncaught keys
516 At boot time, we establish a catch-all that uses this as its handler.
517 1) If the user wants something different, they can use (catch #t
518 ...) to do what they like.
519 2) Outside the context of a read-eval-print loop, there isn't
520 anything else good to do; libguile should not assume the existence
521 of a read-eval-print loop.
522 3) Given that we shouldn't do anything complex, it's much more
523 robust to do it in C code.
525 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
526 message header to print; if zero, we use "guile" instead. That
527 text is followed by a colon, then the message described by ARGS. */
529 /* Dirk:FIXME:: The name of the function should make clear that the
530 * application gets terminated.
534 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
536 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
537 exit (scm_exit_status (args
));
539 handler_message (handler_data
, tag
, args
);
540 scm_i_pthread_exit (NULL
);
542 /* this point not reached, but suppress gcc warning about no return value
543 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
544 to be the case on cygwin for instance) */
549 /* This is just like scm_handle_by_message, but it doesn't exit; it
550 just returns #f. It's useful in cases where you don't really know
551 enough about the body to handle things in a better way, but don't
552 want to let throws fall off the bottom of the wind list. */
554 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
556 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
557 exit (scm_exit_status (args
));
559 handler_message (handler_data
, tag
, args
);
566 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
568 scm_ithrow (tag
, args
, 1);
569 return SCM_UNSPECIFIED
; /* never returns */
574 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
576 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
577 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
578 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
579 "exceptions matching @var{key}. If thunk throws to the symbol\n"
580 "@var{key}, then @var{handler} is invoked this way:\n"
582 "(handler key args ...)\n"
585 "@var{key} is a symbol or @code{#t}.\n"
587 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
588 "normally, that is the return value of @code{catch}.\n"
590 "Handler is invoked outside the scope of its own @code{catch}.\n"
591 "If @var{handler} again throws to the same key, a new handler\n"
592 "from further up the call chain is invoked.\n"
594 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
595 "match this call to @code{catch}.\n"
597 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
598 "an exception that matches @var{key}, Guile calls the\n"
599 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
600 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
601 "be a procedure with the same signature as @var{handler}, that\n"
602 "is @code{(lambda (key . args))}. It is typically used to save\n"
603 "the stack at the point where the exception occurred, but can also\n"
604 "query other parts of the dynamic state at that point, such as\n"
607 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
608 "If it exits normally, Guile unwinds the stack and dynamic context\n"
609 "and then calls the normal (third argument) handler. If it exits\n"
610 "non-locally, that exit determines the continuation.")
611 #define FUNC_NAME s_scm_catch_with_pre_unwind_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_catch takes care of all the mechanics of setting up a catch
622 key; we tell it to call scm_body_thunk to run the body, and
623 scm_handle_by_proc to deal with any throws to this catch. The
624 former receives a pointer to c, telling it how to behave. The
625 latter receives a pointer to HANDLER, so it knows who to
627 return scm_c_catch (key
,
629 scm_handle_by_proc
, &handler
,
630 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
631 &pre_unwind_handler
);
635 /* The following function exists to provide backwards compatibility
636 for the C scm_catch API. Otherwise we could just change
637 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
639 scm_catch (SCM key
, SCM thunk
, SCM handler
)
641 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
645 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
646 (SCM key
, SCM thunk
, SCM handler
),
647 "Add @var{handler} to the dynamic context as a throw handler\n"
648 "for key @var{key}, then invoke @var{thunk}.")
649 #define FUNC_NAME s_scm_with_throw_handler
651 struct scm_body_thunk_data c
;
653 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
654 key
, SCM_ARG1
, FUNC_NAME
);
659 /* scm_c_with_throw_handler takes care of the mechanics of setting
660 up a throw handler; we tell it to call scm_body_thunk to run the
661 body, and scm_handle_by_proc to deal with any throws to this
662 handler. The former receives a pointer to c, telling it how to
663 behave. The latter receives a pointer to HANDLER, so it knows
665 return scm_c_with_throw_handler (key
,
667 scm_handle_by_proc
, &handler
,
672 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
673 (SCM key
, SCM thunk
, SCM handler
),
674 "This behaves exactly like @code{catch}, except that it does\n"
675 "not unwind the stack before invoking @var{handler}.\n"
676 "If the @var{handler} procedure returns normally, Guile\n"
677 "rethrows the same exception again to the next innermost catch,\n"
678 "lazy-catch or throw handler. If the @var{handler} exits\n"
679 "non-locally, that exit determines the continuation.")
680 #define FUNC_NAME s_scm_lazy_catch
682 struct scm_body_thunk_data c
;
684 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
685 key
, SCM_ARG1
, FUNC_NAME
);
690 /* scm_internal_lazy_catch takes care of all the mechanics of
691 setting up a lazy catch key; we tell it to call scm_body_thunk to
692 run the body, and scm_handle_by_proc to deal with any throws to
693 this catch. The former receives a pointer to c, telling it how
694 to behave. The latter receives a pointer to HANDLER, so it knows
696 return scm_internal_lazy_catch (key
,
698 scm_handle_by_proc
, &handler
);
706 static void toggle_pre_unwind_running (void *data
)
708 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
709 pre_unwind
->running
= !pre_unwind
->running
;
712 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
714 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
715 "@var{handler}. \n\n"
716 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
718 "If there is no handler at all, Guile prints an error and then exits.")
719 #define FUNC_NAME s_scm_throw
721 SCM_VALIDATE_SYMBOL (1, key
);
722 return scm_ithrow (key
, args
, 1);
727 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
729 SCM jmpbuf
= SCM_UNDEFINED
;
732 SCM dynpair
= SCM_UNDEFINED
;
735 if (scm_i_critical_section_level
)
741 We have much better routines for displaying Scheme, but we're
742 already inside a pernicious error, and it's unlikely that they
743 are available to us. We try to print something useful anyway,
744 so users don't need a debugger to find out what went wrong.
746 fprintf (stderr
, "throw from within critical section.\n");
747 if (scm_is_symbol (key
))
749 if (scm_i_is_narrow_symbol (key
))
750 fprintf (stderr
, "error key: %s\n", scm_i_symbol_chars (key
));
752 ulc_fprintf (stderr
, "error key: %llU\n", scm_i_symbol_wide_chars (key
));
755 for (; scm_is_pair (s
); s
= scm_cdr (s
), i
++)
757 char const *str
= NULL
;
758 if (scm_is_string (scm_car (s
)))
759 str
= scm_i_string_chars (scm_car (s
));
760 else if (scm_is_symbol (scm_car (s
)))
761 str
= scm_i_symbol_chars (scm_car (s
));
764 fprintf (stderr
, "argument %d: %s\n", i
, str
);
771 /* Search the wind list for an appropriate catch.
772 "Waiter, please bring us the wind list." */
773 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
775 dynpair
= SCM_CAR (winds
);
776 if (scm_is_pair (dynpair
))
778 SCM this_key
= SCM_CAR (dynpair
);
780 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
782 jmpbuf
= SCM_CDR (dynpair
);
784 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
788 struct pre_unwind_data
*c
=
789 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
797 /* If we didn't find anything, print a message and abort the process
798 right here. If you don't want this, establish a catch-all around
799 any code that might throw up. */
800 if (scm_is_null (winds
))
802 scm_handle_by_message (NULL
, key
, args
);
806 /* If the wind list is malformed, bail. */
807 if (!scm_is_pair (winds
))
810 for (wind_goal
= scm_i_dynwinds ();
811 (!scm_is_pair (SCM_CAR (wind_goal
))
812 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
813 wind_goal
= SCM_CDR (wind_goal
))
816 /* Is this a throw handler (or lazy catch)? In a wind list entry
817 for a throw handler or lazy catch, the key is bound to a
818 pre_unwind_data smob, not a jmpbuf. */
819 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
821 struct pre_unwind_data
*c
=
822 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
825 /* For old-style lazy-catch behaviour, we unwind the dynamic
826 context before invoking the handler. */
829 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
830 - scm_ilength (wind_goal
)));
831 SCM_CRITICAL_SECTION_START
;
832 handle
= scm_i_dynwinds ();
833 scm_i_set_dynwinds (SCM_CDR (handle
));
834 SCM_CRITICAL_SECTION_END
;
837 /* Call the handler, with framing to set the pre-unwind
838 structure's running field while the handler is running, so we
839 can avoid recursing into the same handler again. Note that
840 if the handler returns normally, the running flag stays
841 set until some kind of non-local jump occurs. */
842 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
843 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
845 SCM_F_WIND_EXPLICITLY
);
846 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
847 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
849 /* There is deliberately no scm_dynwind_end call here. This
850 means that the unwind handler (toggle_pre_unwind_running)
851 stays in place until a non-local exit occurs, and will then
852 reset the pre-unwind structure's running flag. For sample
853 code where this makes a difference, see the "again but with
854 two chained throw handlers" test case in exceptions.test. */
856 /* If the handler returns, rethrow the same key and args. */
860 /* Otherwise, it's a normal catch. */
861 else if (SCM_JMPBUFP (jmpbuf
))
863 struct pre_unwind_data
* pre_unwind
;
864 struct jmp_buf_and_retval
* jbr
;
866 /* Before unwinding anything, run the pre-unwind handler if
867 there is one, and if it isn't already running. */
868 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
869 if (pre_unwind
->handler
&& !pre_unwind
->running
)
871 /* Use framing to detect and avoid possible reentry into
872 this handler, which could otherwise cause an infinite
874 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
875 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
877 SCM_F_WIND_EXPLICITLY
);
878 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
880 SCM_F_WIND_EXPLICITLY
);
881 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
885 /* Now unwind and jump. */
886 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
887 - scm_ilength (wind_goal
)));
888 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
889 jbr
->throw_tag
= key
;
891 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
892 SCM_I_LONGJMP (*JBJMPBUF (jmpbuf
), 1);
895 /* Otherwise, it's some random piece of junk. */
900 /* On IA64, we #define longjmp as setcontext, and GCC appears not to
901 know that that doesn't return. */
902 return SCM_UNSPECIFIED
;
910 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
911 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
913 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
914 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
916 #include "libguile/throw.x"