1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 #include "libguile/_scm.h"
23 #include "libguile/smob.h"
24 #include "libguile/alist.h"
25 #include "libguile/eval.h"
26 #include "libguile/eq.h"
27 #include "libguile/dynwind.h"
28 #include "libguile/backtrace.h"
29 #ifdef DEBUG_EXTENSIONS
30 #include "libguile/debug.h"
32 #include "libguile/continuations.h"
33 #include "libguile/stackchk.h"
34 #include "libguile/stacks.h"
35 #include "libguile/fluids.h"
36 #include "libguile/ports.h"
37 #include "libguile/lang.h"
39 #include "libguile/validate.h"
40 #include "libguile/throw.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), (v)))
56 #ifdef DEBUG_EXTENSIONS
57 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
58 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (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_intprint((long) JBJMPBUF (exp
), 16, port
);
77 #ifdef DEBUG_EXTENSIONS
78 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
80 SCM_NEWSMOB (answer
, tc16_jmpbuffer
, 0);
82 SETJBJMPBUF(answer
, (jmp_buf *)0);
90 /* scm_internal_catch (the guts of catch) */
92 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
94 jmp_buf buf
; /* must be first */
100 /* scm_internal_catch is the guts of catch. It handles all the
101 mechanics of setting up a catch target, invoking the catch body,
102 and perhaps invoking the handler if the body does a throw.
104 The function is designed to be usable from C code, but is general
105 enough to implement all the semantics Guile Scheme expects from
108 TAG is the catch tag. Typically, this is a symbol, but this
109 function doesn't actually care about that.
111 BODY is a pointer to a C function which runs the body of the catch;
112 this is the code you can throw from. We call it like this:
115 BODY_DATA is just the BODY_DATA argument we received; we pass it
116 through to BODY as its first argument. The caller can make
117 BODY_DATA point to anything useful that BODY might need.
119 HANDLER is a pointer to a C function to deal with a throw to TAG,
120 should one occur. We call it like this:
121 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
123 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
124 same idea as BODY_DATA above.
125 THROWN_TAG is the tag that the user threw to; usually this is
126 TAG, but it could be something else if TAG was #t (i.e., a
127 catch-all), or the user threw to a jmpbuf.
128 THROW_ARGS is the list of arguments the user passed to the THROW
129 function, after the tag.
131 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
132 is just a pointer we pass through to HANDLER. We don't actually
133 use either of those pointers otherwise ourselves. The idea is
134 that, if our caller wants to communicate something to BODY or
135 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
136 HANDLER can then use. Think of it as a way to make BODY and
137 HANDLER closures, not just functions; MUMBLE_DATA points to the
140 Of course, it's up to the caller to make sure that any data a
141 MUMBLE_DATA needs is protected from GC. A common way to do this is
142 to make MUMBLE_DATA a pointer to data stored in an automatic
143 structure variable; since the collector must scan the stack for
144 references anyway, this assures that any references in MUMBLE_DATA
148 scm_internal_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
150 struct jmp_buf_and_retval jbr
;
154 jmpbuf
= make_jmpbuf ();
156 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
157 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
158 #ifdef DEBUG_EXTENSIONS
159 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
161 if (setjmp (jbr
.buf
))
166 #ifdef STACK_CHECKING
167 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
170 DEACTIVATEJB (jmpbuf
);
171 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
173 throw_args
= jbr
.retval
;
174 throw_tag
= jbr
.throw_tag
;
175 jbr
.throw_tag
= SCM_EOL
;
176 jbr
.retval
= SCM_EOL
;
177 answer
= handler (handler_data
, throw_tag
, throw_args
);
182 answer
= body (body_data
);
184 DEACTIVATEJB (jmpbuf
);
185 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
193 /* scm_internal_lazy_catch (the guts of lazy catching) */
195 /* The smob tag for lazy_catch smobs. */
196 static scm_t_bits tc16_lazy_catch
;
198 /* This is the structure we put on the wind list for a lazy catch. It
199 stores the handler function to call, and the data pointer to pass
200 through to it. It's not a Scheme closure, but it is a function
201 with data, so the term "closure" is appropriate in its broader
204 (We don't need anything like this in the "eager" catch code,
205 because the same C frame runs both the body and the handler.) */
207 scm_t_catch_handler handler
;
211 /* Strictly speaking, we could just pass a zero for our print
212 function, because we don't need to print them. They should never
213 appear in normal data structures, only in the wind list. However,
214 it might be nice for debugging someday... */
216 lazy_catch_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
218 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (closure
);
221 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
222 (long) c
->handler
, (long) c
->handler_data
);
223 scm_puts (buf
, port
);
229 /* Given a pointer to a lazy catch structure, return a smob for it,
230 suitable for inclusion in the wind list. ("Ah yes, a Château
231 Gollombiere '72, non?"). */
233 make_lazy_catch (struct lazy_catch
*c
)
235 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
238 #define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
241 /* Exactly like scm_internal_catch, except:
242 - It does not unwind the stack (this is the major difference).
243 - The handler is not allowed to return. */
245 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
247 SCM lazy_catch
, answer
;
251 c
.handler_data
= handler_data
;
252 lazy_catch
= make_lazy_catch (&c
);
255 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
258 answer
= (*body
) (body_data
);
261 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
268 /* scm_internal_stack_catch
269 Use this one if you want debugging information to be stored in
270 scm_the_last_stack_fluid_var on error. */
273 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
276 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
277 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
278 /* Throw the error */
279 return scm_throw (tag
, throw_args
);
285 scm_t_catch_body body
;
290 cwss_body (void *data
)
292 struct cwss_data
*d
= data
;
293 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
297 scm_internal_stack_catch (SCM tag
,
298 scm_t_catch_body body
,
300 scm_t_catch_handler handler
,
307 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
312 /* body and handler functions for use with any of the above catch variants */
314 /* This is a body function you can pass to scm_internal_catch if you
315 want the body to be like Scheme's `catch' --- a thunk.
317 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
318 contains the Scheme procedure to invoke as the body, and the tag
322 scm_body_thunk (void *body_data
)
324 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
326 return scm_call_0 (c
->body_proc
);
330 /* This is a handler function you can pass to scm_internal_catch if
331 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
332 applies a handler procedure to (TAG ARGS ...).
334 If the user does a throw to this catch, this function runs a
335 handler procedure written in Scheme. HANDLER_DATA is a pointer to
336 an SCM variable holding the Scheme procedure object to invoke. It
337 ought to be a pointer to an automatic variable (i.e., one living on
338 the stack), or the procedure object should be otherwise protected
341 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
343 SCM
*handler_proc_p
= (SCM
*) handler_data
;
345 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
348 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
349 catches all throws that the handler might emit itself. The handler
350 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
358 hbpca_body (void *body_data
)
360 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
361 return scm_apply_0 (data
->proc
, data
->args
);
365 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
367 SCM
*handler_proc_p
= (SCM
*) handler_data
;
368 struct hbpca_data data
;
369 data
.proc
= *handler_proc_p
;
370 data
.args
= scm_cons (tag
, throw_args
);
372 return scm_internal_catch (SCM_BOOL_T
,
374 scm_handle_by_message_noexit
, NULL
);
377 /* Derive the an exit status from the arguments to (quit ...). */
379 scm_exit_status (SCM args
)
381 if (!SCM_NULL_OR_NIL_P (args
))
383 SCM cqa
= SCM_CAR (args
);
386 return (SCM_INUM (cqa
));
387 else if (SCM_FALSEP (cqa
))
395 handler_message (void *handler_data
, SCM tag
, SCM args
)
397 char *prog_name
= (char *) handler_data
;
398 SCM p
= scm_cur_errp
;
400 if (scm_ilength (args
) >= 3)
402 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
403 SCM subr
= SCM_CAR (args
);
404 SCM message
= SCM_CADR (args
);
405 SCM parts
= SCM_CADDR (args
);
406 SCM rest
= SCM_CDDDR (args
);
408 if (SCM_BACKTRACE_P
&& SCM_NFALSEP (stack
))
410 scm_puts ("Backtrace:\n", p
);
411 scm_display_backtrace (stack
, p
, SCM_UNDEFINED
, SCM_UNDEFINED
);
414 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
421 scm_puts (prog_name
, p
);
424 scm_puts ("uncaught throw to ", p
);
425 scm_prin1 (tag
, p
, 0);
427 scm_prin1 (args
, p
, 1);
433 /* This is a handler function to use if you want scheme to print a
434 message and die. Useful for dealing with throws to uncaught keys
437 At boot time, we establish a catch-all that uses this as its handler.
438 1) If the user wants something different, they can use (catch #t
439 ...) to do what they like.
440 2) Outside the context of a read-eval-print loop, there isn't
441 anything else good to do; libguile should not assume the existence
442 of a read-eval-print loop.
443 3) Given that we shouldn't do anything complex, it's much more
444 robust to do it in C code.
446 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
447 message header to print; if zero, we use "guile" instead. That
448 text is followed by a colon, then the message described by ARGS. */
450 /* Dirk:FIXME:: The name of the function should make clear that the
451 * application gets terminated.
455 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
457 if (SCM_NFALSEP (scm_eq_p (tag
, scm_str2symbol ("quit"))))
459 exit (scm_exit_status (args
));
462 handler_message (handler_data
, tag
, args
);
467 /* This is just like scm_handle_by_message, but it doesn't exit; it
468 just returns #f. It's useful in cases where you don't really know
469 enough about the body to handle things in a better way, but don't
470 want to let throws fall off the bottom of the wind list. */
472 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
474 handler_message (handler_data
, tag
, args
);
481 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
483 scm_ithrow (tag
, args
, 1);
484 return SCM_UNSPECIFIED
; /* never returns */
489 /* the Scheme-visible CATCH and LAZY-CATCH functions */
491 SCM_DEFINE (scm_catch
, "catch", 3, 0, 0,
492 (SCM key
, SCM thunk
, SCM handler
),
493 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
494 "exceptions matching @var{key}. If thunk throws to the symbol\n"
495 "@var{key}, then @var{handler} is invoked this way:\n"
497 "(handler key args ...)\n"
500 "@var{key} is a symbol or @code{#t}.\n"
502 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
503 "normally, that is the return value of @code{catch}.\n"
505 "Handler is invoked outside the scope of its own @code{catch}.\n"
506 "If @var{handler} again throws to the same key, a new handler\n"
507 "from further up the call chain is invoked.\n"
509 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
510 "match this call to @code{catch}.")
511 #define FUNC_NAME s_scm_catch
513 struct scm_body_thunk_data c
;
515 SCM_ASSERT (SCM_SYMBOLP (key
) || SCM_EQ_P (key
, SCM_BOOL_T
),
516 key
, SCM_ARG1
, FUNC_NAME
);
521 /* scm_internal_catch takes care of all the mechanics of setting up
522 a catch key; we tell it to call scm_body_thunk to run the body,
523 and scm_handle_by_proc to deal with any throws to this catch.
524 The former receives a pointer to c, telling it how to behave.
525 The latter receives a pointer to HANDLER, so it knows who to call. */
526 return scm_internal_catch (key
,
528 scm_handle_by_proc
, &handler
);
533 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
534 (SCM key
, SCM thunk
, SCM handler
),
535 "This behaves exactly like @code{catch}, except that it does\n"
536 "not unwind the stack before invoking @var{handler}.\n"
537 "The @var{handler} procedure is not allowed to return:\n"
538 "it must throw to another catch, or otherwise exit non-locally.")
539 #define FUNC_NAME s_scm_lazy_catch
541 struct scm_body_thunk_data c
;
543 SCM_ASSERT (SCM_SYMBOLP (key
) || SCM_EQ_P (key
, SCM_BOOL_T
),
544 key
, SCM_ARG1
, FUNC_NAME
);
549 /* scm_internal_lazy_catch takes care of all the mechanics of
550 setting up a lazy catch key; we tell it to call scm_body_thunk to
551 run the body, and scm_handle_by_proc to deal with any throws to
552 this catch. The former receives a pointer to c, telling it how
553 to behave. The latter receives a pointer to HANDLER, so it knows
555 return scm_internal_lazy_catch (key
,
557 scm_handle_by_proc
, &handler
);
565 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
567 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
568 "@var{handler}. \n\n"
569 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
571 "If there is no handler at all, Guile prints an error and then exits.")
572 #define FUNC_NAME s_scm_throw
574 SCM_VALIDATE_SYMBOL (1, key
);
575 return scm_ithrow (key
, args
, 1);
580 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
582 SCM jmpbuf
= SCM_UNDEFINED
;
585 SCM dynpair
= SCM_UNDEFINED
;
588 /* Search the wind list for an appropriate catch.
589 "Waiter, please bring us the wind list." */
590 for (winds
= scm_dynwinds
; SCM_CONSP (winds
); winds
= SCM_CDR (winds
))
592 dynpair
= SCM_CAR (winds
);
593 if (SCM_CONSP (dynpair
))
595 SCM this_key
= SCM_CAR (dynpair
);
597 if (SCM_EQ_P (this_key
, SCM_BOOL_T
) || SCM_EQ_P (this_key
, key
))
603 /* Dirk:FIXME:: This bugfix should be removed some time. */
604 /* GCC 2.95.2 has a bug in its optimizer that makes it generate
605 incorrect code sometimes. This barrier stops it from being too
607 asm volatile ("" : "=g" (winds
));
610 /* If we didn't find anything, print a message and abort the process
611 right here. If you don't want this, establish a catch-all around
612 any code that might throw up. */
613 if (SCM_NULLP (winds
))
615 scm_handle_by_message (NULL
, key
, args
);
619 /* If the wind list is malformed, bail. */
620 if (!SCM_CONSP (winds
))
623 jmpbuf
= SCM_CDR (dynpair
);
625 for (wind_goal
= scm_dynwinds
;
626 !SCM_EQ_P (SCM_CDAR (wind_goal
), jmpbuf
);
627 wind_goal
= SCM_CDR (wind_goal
))
630 /* Is a lazy catch? In wind list entries for lazy catches, the key
631 is bound to a lazy_catch smob, not a jmpbuf. */
632 if (SCM_LAZY_CATCH_P (jmpbuf
))
634 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (jmpbuf
);
636 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
637 - scm_ilength (wind_goal
)));
639 handle
= scm_dynwinds
;
640 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
642 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
643 scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL
);
646 /* Otherwise, it's a normal catch. */
647 else if (SCM_JMPBUFP (jmpbuf
))
649 struct jmp_buf_and_retval
* jbr
;
650 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
651 - scm_ilength (wind_goal
)));
652 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
653 jbr
->throw_tag
= key
;
655 #ifdef DEBUG_EXTENSIONS
656 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
658 longjmp (*JBJMPBUF (jmpbuf
), 1);
661 /* Otherwise, it's some random piece of junk. */
670 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
671 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
673 tc16_lazy_catch
= scm_make_smob_type ("lazy-catch", 0);
674 scm_set_smob_print (tc16_lazy_catch
, lazy_catch_print
);
676 #include "libguile/throw.x"