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
26 #include "libguile/_scm.h"
27 #include "libguile/async.h"
28 #include "libguile/smob.h"
29 #include "libguile/alist.h"
30 #include "libguile/eval.h"
31 #include "libguile/eq.h"
32 #include "libguile/dynwind.h"
33 #include "libguile/backtrace.h"
34 #include "libguile/debug.h"
35 #include "libguile/continuations.h"
36 #include "libguile/stackchk.h"
37 #include "libguile/stacks.h"
38 #include "libguile/fluids.h"
39 #include "libguile/ports.h"
40 #include "libguile/lang.h"
41 #include "libguile/validate.h"
42 #include "libguile/throw.h"
43 #include "libguile/init.h"
44 #include "libguile/strings.h"
45 #include "libguile/vm.h"
47 #include "libguile/private-options.h"
51 /* the jump buffer data structure */
52 static scm_t_bits tc16_jmpbuffer
;
54 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
56 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
57 #define ACTIVATEJB(x) \
58 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
59 #define DEACTIVATEJB(x) \
60 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
62 #define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
63 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
64 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
65 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
66 #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
67 #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
70 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
72 scm_puts ("#<jmpbuffer ", port
);
73 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
74 scm_uintprint((scm_t_bits
) JBJMPBUF (exp
), 16, port
);
83 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
84 SETJBJMPBUF(answer
, (scm_i_jmp_buf
*)0);
90 /* scm_c_catch (the guts of catch) */
92 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
94 scm_i_jmp_buf buf
; /* must be first */
99 /* These are the structures we use to store pre-unwind handling (aka
100 "lazy") information for a regular catch, and put on the wind list
101 for a "lazy" catch. They store the pre-unwind handler function to
102 call, and the data pointer to pass through to it. It's not a
103 Scheme closure, but it is a function with data, so the term
104 "closure" is appropriate in its broader sense.
106 (We don't need anything like this to run the normal (post-unwind)
107 catch handler, because the same C frame runs both the body and the
110 struct pre_unwind_data
{
111 scm_t_catch_handler handler
;
118 /* scm_c_catch is the guts of catch. It handles all the mechanics of
119 setting up a catch target, invoking the catch body, and perhaps
120 invoking the handler if the body does a throw.
122 The function is designed to be usable from C code, but is general
123 enough to implement all the semantics Guile Scheme expects from
126 TAG is the catch tag. Typically, this is a symbol, but this
127 function doesn't actually care about that.
129 BODY is a pointer to a C function which runs the body of the catch;
130 this is the code you can throw from. We call it like this:
133 BODY_DATA is just the BODY_DATA argument we received; we pass it
134 through to BODY as its first argument. The caller can make
135 BODY_DATA point to anything useful that BODY might need.
137 HANDLER is a pointer to a C function to deal with a throw to TAG,
138 should one occur. We call it like this:
139 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
141 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
142 same idea as BODY_DATA above.
143 THROWN_TAG is the tag that the user threw to; usually this is
144 TAG, but it could be something else if TAG was #t (i.e., a
145 catch-all), or the user threw to a jmpbuf.
146 THROW_ARGS is the list of arguments the user passed to the THROW
147 function, after the tag.
149 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
150 is just a pointer we pass through to HANDLER. We don't actually
151 use either of those pointers otherwise ourselves. The idea is
152 that, if our caller wants to communicate something to BODY or
153 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
154 HANDLER can then use. Think of it as a way to make BODY and
155 HANDLER closures, not just functions; MUMBLE_DATA points to the
158 Of course, it's up to the caller to make sure that any data a
159 MUMBLE_DATA needs is protected from GC. A common way to do this is
160 to make MUMBLE_DATA a pointer to data stored in an automatic
161 structure variable; since the collector must scan the stack for
162 references anyway, this assures that any references in MUMBLE_DATA
166 scm_c_catch (SCM tag
,
167 scm_t_catch_body body
, void *body_data
,
168 scm_t_catch_handler handler
, void *handler_data
,
169 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
171 struct jmp_buf_and_retval jbr
;
175 SCM
*sp
= NULL
, *fp
= NULL
; /* to reset the vm */
176 struct pre_unwind_data pre_unwind
;
179 if (SCM_NFALSEP (vm
))
181 sp
= SCM_VM_DATA (vm
)->sp
;
182 fp
= SCM_VM_DATA (vm
)->fp
;
185 jmpbuf
= make_jmpbuf ();
187 scm_i_set_dynwinds (scm_acons (tag
, jmpbuf
, scm_i_dynwinds ()));
188 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
189 SCM_SETJBDFRAME(jmpbuf
, scm_i_last_debug_frame ());
191 pre_unwind
.handler
= pre_unwind_handler
;
192 pre_unwind
.handler_data
= pre_unwind_handler_data
;
193 pre_unwind
.running
= 0;
194 pre_unwind
.lazy_catch_p
= 0;
195 SCM_SETJBPREUNWIND(jmpbuf
, &pre_unwind
);
197 if (SCM_I_SETJMP (jbr
.buf
))
202 #ifdef STACK_CHECKING
203 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
205 SCM_CRITICAL_SECTION_START
;
206 DEACTIVATEJB (jmpbuf
);
207 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
208 SCM_CRITICAL_SECTION_END
;
209 throw_args
= jbr
.retval
;
210 throw_tag
= jbr
.throw_tag
;
211 jbr
.throw_tag
= SCM_EOL
;
212 jbr
.retval
= SCM_EOL
;
213 if (SCM_NFALSEP (vm
))
215 SCM_VM_DATA (vm
)->sp
= sp
;
216 SCM_VM_DATA (vm
)->fp
= fp
;
217 #ifdef VM_ENABLE_STACK_NULLING
218 /* see vm.c -- you'll have to enable this manually */
220 (SCM_VM_DATA (vm
)->stack_size
221 - (sp
+ 1 - SCM_VM_DATA (vm
)->stack_base
)) * sizeof(SCM
));
224 else if (SCM_NFALSEP ((vm
= scm_the_vm ())))
226 /* oof, it's possible this catch was called before the vm was
227 booted... yick. anyway, try to reset the vm stack. */
228 SCM_VM_DATA (vm
)->sp
= SCM_VM_DATA (vm
)->stack_base
- 1;
229 SCM_VM_DATA (vm
)->fp
= NULL
;
230 #ifdef VM_ENABLE_STACK_NULLING
231 /* see vm.c -- you'll have to enable this manually */
232 memset (SCM_VM_DATA (vm
)->stack_base
, 0,
233 SCM_VM_DATA (vm
)->stack_size
* sizeof(SCM
));
237 answer
= handler (handler_data
, throw_tag
, throw_args
);
242 answer
= body (body_data
);
243 SCM_CRITICAL_SECTION_START
;
244 DEACTIVATEJB (jmpbuf
);
245 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
246 SCM_CRITICAL_SECTION_END
;
252 scm_internal_catch (SCM tag
,
253 scm_t_catch_body body
, void *body_data
,
254 scm_t_catch_handler handler
, void *handler_data
)
256 return scm_c_catch(tag
,
258 handler
, handler_data
,
264 /* The smob tag for pre_unwind_data smobs. */
265 static scm_t_bits tc16_pre_unwind_data
;
267 /* Strictly speaking, we could just pass a zero for our print
268 function, because we don't need to print them. They should never
269 appear in normal data structures, only in the wind list. However,
270 it might be nice for debugging someday... */
272 pre_unwind_data_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
274 struct pre_unwind_data
*c
= (struct pre_unwind_data
*) SCM_CELL_WORD_1 (closure
);
277 sprintf (buf
, "#<pre-unwind-data 0x%lx 0x%lx>",
278 (long) c
->handler
, (long) c
->handler_data
);
279 scm_puts (buf
, port
);
285 /* Given a pointer to a pre_unwind_data structure, return a smob for it,
286 suitable for inclusion in the wind list. ("Ah yes, a Château
287 Gollombiere '72, non?"). */
289 make_pre_unwind_data (struct pre_unwind_data
*c
)
291 SCM_RETURN_NEWSMOB (tc16_pre_unwind_data
, c
);
294 #define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
297 scm_c_with_throw_handler (SCM tag
,
298 scm_t_catch_body body
,
300 scm_t_catch_handler handler
,
304 SCM pre_unwind
, answer
;
305 struct pre_unwind_data c
;
308 c
.handler_data
= handler_data
;
310 c
.lazy_catch_p
= lazy_catch_p
;
311 pre_unwind
= make_pre_unwind_data (&c
);
313 SCM_CRITICAL_SECTION_START
;
314 scm_i_set_dynwinds (scm_acons (tag
, pre_unwind
, scm_i_dynwinds ()));
315 SCM_CRITICAL_SECTION_END
;
317 answer
= (*body
) (body_data
);
319 SCM_CRITICAL_SECTION_START
;
320 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
321 SCM_CRITICAL_SECTION_END
;
326 /* Exactly like scm_internal_catch, except:
327 - It does not unwind the stack (this is the major difference).
328 - The handler is not allowed to return. */
330 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
332 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 1);
336 /* scm_internal_stack_catch
337 Use this one if you want debugging information to be stored in
338 scm_the_last_stack_fluid_var on error. */
341 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
344 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
345 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
346 /* Throw the error */
347 return scm_throw (tag
, throw_args
);
353 scm_t_catch_body body
;
358 cwss_body (void *data
)
360 struct cwss_data
*d
= data
;
361 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
365 scm_internal_stack_catch (SCM tag
,
366 scm_t_catch_body body
,
368 scm_t_catch_handler handler
,
375 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
380 /* body and handler functions for use with any of the above catch variants */
382 /* This is a body function you can pass to scm_internal_catch if you
383 want the body to be like Scheme's `catch' --- a thunk.
385 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
386 contains the Scheme procedure to invoke as the body, and the tag
390 scm_body_thunk (void *body_data
)
392 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
394 return scm_call_0 (c
->body_proc
);
398 /* This is a handler function you can pass to scm_internal_catch if
399 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
400 applies a handler procedure to (TAG ARGS ...).
402 If the user does a throw to this catch, this function runs a
403 handler procedure written in Scheme. HANDLER_DATA is a pointer to
404 an SCM variable holding the Scheme procedure object to invoke. It
405 ought to be a pointer to an automatic variable (i.e., one living on
406 the stack), or the procedure object should be otherwise protected
409 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
411 SCM
*handler_proc_p
= (SCM
*) handler_data
;
413 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
416 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
417 catches all throws that the handler might emit itself. The handler
418 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
426 hbpca_body (void *body_data
)
428 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
429 return scm_apply_0 (data
->proc
, data
->args
);
433 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
435 SCM
*handler_proc_p
= (SCM
*) handler_data
;
436 struct hbpca_data data
;
437 data
.proc
= *handler_proc_p
;
438 data
.args
= scm_cons (tag
, throw_args
);
440 return scm_internal_catch (SCM_BOOL_T
,
442 scm_handle_by_message_noexit
, NULL
);
445 /* Derive the an exit status from the arguments to (quit ...). */
447 scm_exit_status (SCM args
)
449 if (!SCM_NULL_OR_NIL_P (args
))
451 SCM cqa
= SCM_CAR (args
);
453 if (scm_is_integer (cqa
))
454 return (scm_to_int (cqa
));
455 else if (scm_is_false (cqa
))
463 handler_message (void *handler_data
, SCM tag
, SCM args
)
465 char *prog_name
= (char *) handler_data
;
466 SCM p
= scm_current_error_port ();
468 if (scm_ilength (args
) == 4)
470 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
471 SCM subr
= SCM_CAR (args
);
472 SCM message
= SCM_CADR (args
);
473 SCM parts
= SCM_CADDR (args
);
474 SCM rest
= SCM_CADDDR (args
);
476 if (SCM_BACKTRACE_P
&& scm_is_true (stack
))
480 if (scm_is_eq (tag
, scm_arg_type_key
)
481 || scm_is_eq (tag
, scm_out_of_range_key
))
484 highlights
= SCM_EOL
;
486 scm_puts ("Backtrace:\n", p
);
487 scm_display_backtrace_with_highlights (stack
, p
,
488 SCM_BOOL_F
, SCM_BOOL_F
,
492 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
499 scm_puts (prog_name
, p
);
502 scm_puts ("uncaught throw to ", p
);
503 scm_prin1 (tag
, p
, 0);
505 scm_prin1 (args
, p
, 1);
511 /* This is a handler function to use if you want scheme to print a
512 message and die. Useful for dealing with throws to uncaught keys
515 At boot time, we establish a catch-all that uses this as its handler.
516 1) If the user wants something different, they can use (catch #t
517 ...) to do what they like.
518 2) Outside the context of a read-eval-print loop, there isn't
519 anything else good to do; libguile should not assume the existence
520 of a read-eval-print loop.
521 3) Given that we shouldn't do anything complex, it's much more
522 robust to do it in C code.
524 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
525 message header to print; if zero, we use "guile" instead. That
526 text is followed by a colon, then the message described by ARGS. */
528 /* Dirk:FIXME:: The name of the function should make clear that the
529 * application gets terminated.
533 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
535 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
536 exit (scm_exit_status (args
));
538 handler_message (handler_data
, tag
, args
);
539 scm_i_pthread_exit (NULL
);
541 /* this point not reached, but suppress gcc warning about no return value
542 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
543 to be the case on cygwin for instance) */
548 /* This is just like scm_handle_by_message, but it doesn't exit; it
549 just returns #f. It's useful in cases where you don't really know
550 enough about the body to handle things in a better way, but don't
551 want to let throws fall off the bottom of the wind list. */
553 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
555 if (scm_is_true (scm_eq_p (tag
, scm_from_locale_symbol ("quit"))))
556 exit (scm_exit_status (args
));
558 handler_message (handler_data
, tag
, args
);
565 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
567 scm_ithrow (tag
, args
, 1);
568 return SCM_UNSPECIFIED
; /* never returns */
573 /* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
575 SCM_DEFINE (scm_catch_with_pre_unwind_handler
, "catch", 3, 1, 0,
576 (SCM key
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
),
577 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
578 "exceptions matching @var{key}. If thunk throws to the symbol\n"
579 "@var{key}, then @var{handler} is invoked this way:\n"
581 "(handler key args ...)\n"
584 "@var{key} is a symbol or @code{#t}.\n"
586 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
587 "normally, that is the return value of @code{catch}.\n"
589 "Handler is invoked outside the scope of its own @code{catch}.\n"
590 "If @var{handler} again throws to the same key, a new handler\n"
591 "from further up the call chain is invoked.\n"
593 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
594 "match this call to @code{catch}.\n"
596 "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
597 "an exception that matches @var{key}, Guile calls the\n"
598 "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
599 "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
600 "be a procedure with the same signature as @var{handler}, that\n"
601 "is @code{(lambda (key . args))}. It is typically used to save\n"
602 "the stack at the point where the exception occurred, but can also\n"
603 "query other parts of the dynamic state at that point, such as\n"
606 "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
607 "If it exits normally, Guile unwinds the stack and dynamic context\n"
608 "and then calls the normal (third argument) handler. If it exits\n"
609 "non-locally, that exit determines the continuation.")
610 #define FUNC_NAME s_scm_catch_with_pre_unwind_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_catch takes care of all the mechanics of setting up a catch
621 key; we tell it to call scm_body_thunk to run the body, and
622 scm_handle_by_proc to deal with any throws to this catch. The
623 former receives a pointer to c, telling it how to behave. The
624 latter receives a pointer to HANDLER, so it knows who to
626 return scm_c_catch (key
,
628 scm_handle_by_proc
, &handler
,
629 SCM_UNBNDP (pre_unwind_handler
) ? NULL
: scm_handle_by_proc
,
630 &pre_unwind_handler
);
634 /* The following function exists to provide backwards compatibility
635 for the C scm_catch API. Otherwise we could just change
636 "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
638 scm_catch (SCM key
, SCM thunk
, SCM handler
)
640 return scm_catch_with_pre_unwind_handler (key
, thunk
, handler
, SCM_UNDEFINED
);
644 SCM_DEFINE (scm_with_throw_handler
, "with-throw-handler", 3, 0, 0,
645 (SCM key
, SCM thunk
, SCM handler
),
646 "Add @var{handler} to the dynamic context as a throw handler\n"
647 "for key @var{key}, then invoke @var{thunk}.")
648 #define FUNC_NAME s_scm_with_throw_handler
650 struct scm_body_thunk_data c
;
652 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
653 key
, SCM_ARG1
, FUNC_NAME
);
658 /* scm_c_with_throw_handler takes care of the mechanics of setting
659 up a throw handler; we tell it to call scm_body_thunk to run the
660 body, and scm_handle_by_proc to deal with any throws to this
661 handler. The former receives a pointer to c, telling it how to
662 behave. The latter receives a pointer to HANDLER, so it knows
664 return scm_c_with_throw_handler (key
,
666 scm_handle_by_proc
, &handler
,
671 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
672 (SCM key
, SCM thunk
, SCM handler
),
673 "This behaves exactly like @code{catch}, except that it does\n"
674 "not unwind the stack before invoking @var{handler}.\n"
675 "If the @var{handler} procedure returns normally, Guile\n"
676 "rethrows the same exception again to the next innermost catch,\n"
677 "lazy-catch or throw handler. If the @var{handler} exits\n"
678 "non-locally, that exit determines the continuation.")
679 #define FUNC_NAME s_scm_lazy_catch
681 struct scm_body_thunk_data c
;
683 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
684 key
, SCM_ARG1
, FUNC_NAME
);
689 /* scm_internal_lazy_catch takes care of all the mechanics of
690 setting up a lazy catch key; we tell it to call scm_body_thunk to
691 run the body, and scm_handle_by_proc to deal with any throws to
692 this catch. The former receives a pointer to c, telling it how
693 to behave. The latter receives a pointer to HANDLER, so it knows
695 return scm_internal_lazy_catch (key
,
697 scm_handle_by_proc
, &handler
);
705 static void toggle_pre_unwind_running (void *data
)
707 struct pre_unwind_data
*pre_unwind
= (struct pre_unwind_data
*)data
;
708 pre_unwind
->running
= !pre_unwind
->running
;
711 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
713 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
714 "@var{handler}. \n\n"
715 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
717 "If there is no handler at all, Guile prints an error and then exits.")
718 #define FUNC_NAME s_scm_throw
720 SCM_VALIDATE_SYMBOL (1, key
);
721 return scm_ithrow (key
, args
, 1);
726 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
728 SCM jmpbuf
= SCM_UNDEFINED
;
731 SCM dynpair
= SCM_UNDEFINED
;
734 if (scm_i_critical_section_level
)
740 We have much better routines for displaying Scheme, but we're
741 already inside a pernicious error, and it's unlikely that they
742 are available to us. We try to print something useful anyway,
743 so users don't need a debugger to find out what went wrong.
745 fprintf (stderr
, "throw from within critical section.\n");
746 if (scm_is_symbol (key
))
747 fprintf (stderr
, "error key: %s\n", scm_i_symbol_chars (key
));
750 for (; scm_is_pair (s
); s
= scm_cdr (s
), i
++)
752 char const *str
= NULL
;
753 if (scm_is_string (scm_car (s
)))
754 str
= scm_i_string_chars (scm_car (s
));
755 else if (scm_is_symbol (scm_car (s
)))
756 str
= scm_i_symbol_chars (scm_car (s
));
759 fprintf (stderr
, "argument %d: %s\n", i
, str
);
766 /* Search the wind list for an appropriate catch.
767 "Waiter, please bring us the wind list." */
768 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
770 dynpair
= SCM_CAR (winds
);
771 if (scm_is_pair (dynpair
))
773 SCM this_key
= SCM_CAR (dynpair
);
775 if (scm_is_eq (this_key
, SCM_BOOL_T
) || scm_is_eq (this_key
, key
))
777 jmpbuf
= SCM_CDR (dynpair
);
779 if (!SCM_PRE_UNWIND_DATA_P (jmpbuf
))
783 struct pre_unwind_data
*c
=
784 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
792 /* If we didn't find anything, print a message and abort the process
793 right here. If you don't want this, establish a catch-all around
794 any code that might throw up. */
795 if (scm_is_null (winds
))
797 scm_handle_by_message (NULL
, key
, args
);
801 /* If the wind list is malformed, bail. */
802 if (!scm_is_pair (winds
))
805 for (wind_goal
= scm_i_dynwinds ();
806 (!scm_is_pair (SCM_CAR (wind_goal
))
807 || !scm_is_eq (SCM_CDAR (wind_goal
), jmpbuf
));
808 wind_goal
= SCM_CDR (wind_goal
))
811 /* Is this a throw handler (or lazy catch)? In a wind list entry
812 for a throw handler or lazy catch, the key is bound to a
813 pre_unwind_data smob, not a jmpbuf. */
814 if (SCM_PRE_UNWIND_DATA_P (jmpbuf
))
816 struct pre_unwind_data
*c
=
817 (struct pre_unwind_data
*) SCM_CELL_WORD_1 (jmpbuf
);
820 /* For old-style lazy-catch behaviour, we unwind the dynamic
821 context before invoking the handler. */
824 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
825 - scm_ilength (wind_goal
)));
826 SCM_CRITICAL_SECTION_START
;
827 handle
= scm_i_dynwinds ();
828 scm_i_set_dynwinds (SCM_CDR (handle
));
829 SCM_CRITICAL_SECTION_END
;
832 /* Call the handler, with framing to set the pre-unwind
833 structure's running field while the handler is running, so we
834 can avoid recursing into the same handler again. Note that
835 if the handler returns normally, the running flag stays
836 set until some kind of non-local jump occurs. */
837 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
838 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
840 SCM_F_WIND_EXPLICITLY
);
841 scm_dynwind_unwind_handler (toggle_pre_unwind_running
, c
, 0);
842 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
844 /* There is deliberately no scm_dynwind_end call here. This
845 means that the unwind handler (toggle_pre_unwind_running)
846 stays in place until a non-local exit occurs, and will then
847 reset the pre-unwind structure's running flag. For sample
848 code where this makes a difference, see the "again but with
849 two chained throw handlers" test case in exceptions.test. */
851 /* If the handler returns, rethrow the same key and args. */
855 /* Otherwise, it's a normal catch. */
856 else if (SCM_JMPBUFP (jmpbuf
))
858 struct pre_unwind_data
* pre_unwind
;
859 struct jmp_buf_and_retval
* jbr
;
861 /* Before unwinding anything, run the pre-unwind handler if
862 there is one, and if it isn't already running. */
863 pre_unwind
= SCM_JBPREUNWIND (jmpbuf
);
864 if (pre_unwind
->handler
&& !pre_unwind
->running
)
866 /* Use framing to detect and avoid possible reentry into
867 this handler, which could otherwise cause an infinite
869 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
870 scm_dynwind_rewind_handler (toggle_pre_unwind_running
,
872 SCM_F_WIND_EXPLICITLY
);
873 scm_dynwind_unwind_handler (toggle_pre_unwind_running
,
875 SCM_F_WIND_EXPLICITLY
);
876 (pre_unwind
->handler
) (pre_unwind
->handler_data
, key
, args
);
880 /* Now unwind and jump. */
881 scm_dowinds (wind_goal
, (scm_ilength (scm_i_dynwinds ())
882 - scm_ilength (wind_goal
)));
883 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
884 jbr
->throw_tag
= key
;
886 scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf
));
887 SCM_I_LONGJMP (*JBJMPBUF (jmpbuf
), 1);
890 /* Otherwise, it's some random piece of junk. */
895 /* On IA64, we #define longjmp as setcontext, and GCC appears not to
896 know that that doesn't return. */
897 return SCM_UNSPECIFIED
;
905 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
906 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
908 tc16_pre_unwind_data
= scm_make_smob_type ("pre-unwind-data", 0);
909 scm_set_smob_print (tc16_pre_unwind_data
, pre_unwind_data_print
);
911 #include "libguile/throw.x"