1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
46 #include "libguile/_scm.h"
47 #include "libguile/smob.h"
48 #include "libguile/alist.h"
49 #include "libguile/eval.h"
50 #include "libguile/eq.h"
51 #include "libguile/dynwind.h"
52 #include "libguile/backtrace.h"
53 #ifdef DEBUG_EXTENSIONS
54 #include "libguile/debug.h"
56 #include "libguile/continuations.h"
57 #include "libguile/stackchk.h"
58 #include "libguile/stacks.h"
59 #include "libguile/fluids.h"
60 #include "libguile/ports.h"
61 #include "libguile/lang.h"
63 #include "libguile/validate.h"
64 #include "libguile/throw.h"
67 /* the jump buffer data structure */
68 static scm_t_bits tc16_jmpbuffer
;
70 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
72 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
73 #define ACTIVATEJB(x) \
74 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
75 #define DEACTIVATEJB(x) \
76 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
78 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
79 #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
80 #ifdef DEBUG_EXTENSIONS
81 #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
82 #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (v)))
86 jmpbuffer_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
88 scm_puts ("#<jmpbuffer ", port
);
89 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
90 scm_intprint((long) JBJMPBUF (exp
), 16, port
);
101 #ifdef DEBUG_EXTENSIONS
102 SCM_NEWSMOB2 (answer
, tc16_jmpbuffer
, 0, 0);
104 SCM_NEWSMOB (answer
, tc16_jmpbuffer
, 0);
106 SETJBJMPBUF(answer
, (jmp_buf *)0);
107 DEACTIVATEJB(answer
);
114 /* scm_internal_catch (the guts of catch) */
116 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
118 jmp_buf buf
; /* must be first */
124 /* scm_internal_catch is the guts of catch. It handles all the
125 mechanics of setting up a catch target, invoking the catch body,
126 and perhaps invoking the handler if the body does a throw.
128 The function is designed to be usable from C code, but is general
129 enough to implement all the semantics Guile Scheme expects from
132 TAG is the catch tag. Typically, this is a symbol, but this
133 function doesn't actually care about that.
135 BODY is a pointer to a C function which runs the body of the catch;
136 this is the code you can throw from. We call it like this:
139 BODY_DATA is just the BODY_DATA argument we received; we pass it
140 through to BODY as its first argument. The caller can make
141 BODY_DATA point to anything useful that BODY might need.
143 HANDLER is a pointer to a C function to deal with a throw to TAG,
144 should one occur. We call it like this:
145 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
147 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
148 same idea as BODY_DATA above.
149 THROWN_TAG is the tag that the user threw to; usually this is
150 TAG, but it could be something else if TAG was #t (i.e., a
151 catch-all), or the user threw to a jmpbuf.
152 THROW_ARGS is the list of arguments the user passed to the THROW
153 function, after the tag.
155 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
156 is just a pointer we pass through to HANDLER. We don't actually
157 use either of those pointers otherwise ourselves. The idea is
158 that, if our caller wants to communicate something to BODY or
159 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
160 HANDLER can then use. Think of it as a way to make BODY and
161 HANDLER closures, not just functions; MUMBLE_DATA points to the
164 Of course, it's up to the caller to make sure that any data a
165 MUMBLE_DATA needs is protected from GC. A common way to do this is
166 to make MUMBLE_DATA a pointer to data stored in an automatic
167 structure variable; since the collector must scan the stack for
168 references anyway, this assures that any references in MUMBLE_DATA
172 scm_internal_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
174 struct jmp_buf_and_retval jbr
;
178 jmpbuf
= make_jmpbuf ();
180 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
181 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
182 #ifdef DEBUG_EXTENSIONS
183 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
185 if (setjmp (jbr
.buf
))
190 #ifdef STACK_CHECKING
191 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
194 DEACTIVATEJB (jmpbuf
);
195 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
197 throw_args
= jbr
.retval
;
198 throw_tag
= jbr
.throw_tag
;
199 jbr
.throw_tag
= SCM_EOL
;
200 jbr
.retval
= SCM_EOL
;
201 answer
= handler (handler_data
, throw_tag
, throw_args
);
206 answer
= body (body_data
);
208 DEACTIVATEJB (jmpbuf
);
209 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
217 /* scm_internal_lazy_catch (the guts of lazy catching) */
219 /* The smob tag for lazy_catch smobs. */
220 static scm_t_bits tc16_lazy_catch
;
222 /* This is the structure we put on the wind list for a lazy catch. It
223 stores the handler function to call, and the data pointer to pass
224 through to it. It's not a Scheme closure, but it is a function
225 with data, so the term "closure" is appropriate in its broader
228 (We don't need anything like this in the "eager" catch code,
229 because the same C frame runs both the body and the handler.) */
231 scm_t_catch_handler handler
;
235 /* Strictly speaking, we could just pass a zero for our print
236 function, because we don't need to print them. They should never
237 appear in normal data structures, only in the wind list. However,
238 it might be nice for debugging someday... */
240 lazy_catch_print (SCM closure
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
242 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (closure
);
245 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
246 (long) c
->handler
, (long) c
->handler_data
);
247 scm_puts (buf
, port
);
253 /* Given a pointer to a lazy catch structure, return a smob for it,
254 suitable for inclusion in the wind list. ("Ah yes, a Château
255 Gollombiere '72, non?"). */
257 make_lazy_catch (struct lazy_catch
*c
)
259 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
262 #define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
265 /* Exactly like scm_internal_catch, except:
266 - It does not unwind the stack (this is the major difference).
267 - The handler is not allowed to return. */
269 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
271 SCM lazy_catch
, answer
;
275 c
.handler_data
= handler_data
;
276 lazy_catch
= make_lazy_catch (&c
);
279 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
282 answer
= (*body
) (body_data
);
285 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
292 /* scm_internal_stack_catch
293 Use this one if you want debugging information to be stored in
294 scm_the_last_stack_fluid_var on error. */
297 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
300 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var
),
301 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
302 /* Throw the error */
303 return scm_throw (tag
, throw_args
);
309 scm_t_catch_body body
;
314 cwss_body (void *data
)
316 struct cwss_data
*d
= data
;
317 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
321 scm_internal_stack_catch (SCM tag
,
322 scm_t_catch_body body
,
324 scm_t_catch_handler handler
,
331 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
336 /* body and handler functions for use with any of the above catch variants */
338 /* This is a body function you can pass to scm_internal_catch if you
339 want the body to be like Scheme's `catch' --- a thunk.
341 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
342 contains the Scheme procedure to invoke as the body, and the tag
346 scm_body_thunk (void *body_data
)
348 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
350 return scm_call_0 (c
->body_proc
);
354 /* This is a handler function you can pass to scm_internal_catch if
355 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
356 applies a handler procedure to (TAG ARGS ...).
358 If the user does a throw to this catch, this function runs a
359 handler procedure written in Scheme. HANDLER_DATA is a pointer to
360 an SCM variable holding the Scheme procedure object to invoke. It
361 ought to be a pointer to an automatic variable (i.e., one living on
362 the stack), or the procedure object should be otherwise protected
365 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
367 SCM
*handler_proc_p
= (SCM
*) handler_data
;
369 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
372 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
373 catches all throws that the handler might emit itself. The handler
374 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
382 hbpca_body (void *body_data
)
384 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
385 return scm_apply_0 (data
->proc
, data
->args
);
389 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
391 SCM
*handler_proc_p
= (SCM
*) handler_data
;
392 struct hbpca_data data
;
393 data
.proc
= *handler_proc_p
;
394 data
.args
= scm_cons (tag
, throw_args
);
396 return scm_internal_catch (SCM_BOOL_T
,
398 scm_handle_by_message_noexit
, NULL
);
401 /* Derive the an exit status from the arguments to (quit ...). */
403 scm_exit_status (SCM args
)
405 if (!SCM_NULL_OR_NIL_P (args
))
407 SCM cqa
= SCM_CAR (args
);
410 return (SCM_INUM (cqa
));
411 else if (SCM_FALSEP (cqa
))
419 handler_message (void *handler_data
, SCM tag
, SCM args
)
421 char *prog_name
= (char *) handler_data
;
422 SCM p
= scm_cur_errp
;
424 if (scm_ilength (args
) >= 3)
426 SCM stack
= scm_make_stack (SCM_BOOL_T
, SCM_EOL
);
427 SCM subr
= SCM_CAR (args
);
428 SCM message
= SCM_CADR (args
);
429 SCM parts
= SCM_CADDR (args
);
430 SCM rest
= SCM_CDDDR (args
);
432 if (SCM_BACKTRACE_P
&& SCM_NFALSEP (stack
))
434 scm_puts ("Backtrace:\n", p
);
435 scm_display_backtrace (stack
, p
, SCM_UNDEFINED
, SCM_UNDEFINED
);
438 scm_i_display_error (stack
, p
, subr
, message
, parts
, rest
);
445 scm_puts (prog_name
, p
);
448 scm_puts ("uncaught throw to ", p
);
449 scm_prin1 (tag
, p
, 0);
451 scm_prin1 (args
, p
, 1);
457 /* This is a handler function to use if you want scheme to print a
458 message and die. Useful for dealing with throws to uncaught keys
461 At boot time, we establish a catch-all that uses this as its handler.
462 1) If the user wants something different, they can use (catch #t
463 ...) to do what they like.
464 2) Outside the context of a read-eval-print loop, there isn't
465 anything else good to do; libguile should not assume the existence
466 of a read-eval-print loop.
467 3) Given that we shouldn't do anything complex, it's much more
468 robust to do it in C code.
470 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
471 message header to print; if zero, we use "guile" instead. That
472 text is followed by a colon, then the message described by ARGS. */
474 /* Dirk:FIXME:: The name of the function should make clear that the
475 * application gets terminated.
479 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
481 if (SCM_NFALSEP (scm_eq_p (tag
, scm_str2symbol ("quit"))))
483 exit (scm_exit_status (args
));
486 handler_message (handler_data
, tag
, args
);
491 /* This is just like scm_handle_by_message, but it doesn't exit; it
492 just returns #f. It's useful in cases where you don't really know
493 enough about the body to handle things in a better way, but don't
494 want to let throws fall off the bottom of the wind list. */
496 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
498 handler_message (handler_data
, tag
, args
);
505 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
507 scm_ithrow (tag
, args
, 1);
508 return SCM_UNSPECIFIED
; /* never returns */
513 /* the Scheme-visible CATCH and LAZY-CATCH functions */
515 SCM_DEFINE (scm_catch
, "catch", 3, 0, 0,
516 (SCM key
, SCM thunk
, SCM handler
),
517 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
518 "exceptions matching @var{key}. If thunk throws to the symbol\n"
519 "@var{key}, then @var{handler} is invoked this way:\n"
521 "(handler key args ...)\n"
524 "@var{key} is a symbol or @code{#t}.\n"
526 "@var{thunk} takes no arguments. If @var{thunk} returns\n"
527 "normally, that is the return value of @code{catch}.\n"
529 "Handler is invoked outside the scope of its own @code{catch}.\n"
530 "If @var{handler} again throws to the same key, a new handler\n"
531 "from further up the call chain is invoked.\n"
533 "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
534 "match this call to @code{catch}.")
535 #define FUNC_NAME s_scm_catch
537 struct scm_body_thunk_data c
;
539 SCM_ASSERT (SCM_SYMBOLP (key
) || SCM_EQ_P (key
, SCM_BOOL_T
),
540 key
, SCM_ARG1
, FUNC_NAME
);
545 /* scm_internal_catch takes care of all the mechanics of setting up
546 a catch key; we tell it to call scm_body_thunk to run the body,
547 and scm_handle_by_proc to deal with any throws to this catch.
548 The former receives a pointer to c, telling it how to behave.
549 The latter receives a pointer to HANDLER, so it knows who to call. */
550 return scm_internal_catch (key
,
552 scm_handle_by_proc
, &handler
);
557 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
558 (SCM key
, SCM thunk
, SCM handler
),
559 "This behaves exactly like @code{catch}, except that it does\n"
560 "not unwind the stack before invoking @var{handler}.\n"
561 "The @var{handler} procedure is not allowed to return:\n"
562 "it must throw to another catch, or otherwise exit non-locally.")
563 #define FUNC_NAME s_scm_lazy_catch
565 struct scm_body_thunk_data c
;
567 SCM_ASSERT (SCM_SYMBOLP (key
) || SCM_EQ_P (key
, SCM_BOOL_T
),
568 key
, SCM_ARG1
, FUNC_NAME
);
573 /* scm_internal_lazy_catch takes care of all the mechanics of
574 setting up a lazy catch key; we tell it to call scm_body_thunk to
575 run the body, and scm_handle_by_proc to deal with any throws to
576 this catch. The former receives a pointer to c, telling it how
577 to behave. The latter receives a pointer to HANDLER, so it knows
579 return scm_internal_lazy_catch (key
,
581 scm_handle_by_proc
, &handler
);
589 SCM_DEFINE (scm_throw
, "throw", 1, 0, 1,
591 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
592 "@var{handler}. \n\n"
593 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
595 "If there is no handler at all, Guile prints an error and then exits.")
596 #define FUNC_NAME s_scm_throw
598 SCM_VALIDATE_SYMBOL (1, key
);
599 return scm_ithrow (key
, args
, 1);
604 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
606 SCM jmpbuf
= SCM_UNDEFINED
;
609 SCM dynpair
= SCM_UNDEFINED
;
612 /* Search the wind list for an appropriate catch.
613 "Waiter, please bring us the wind list." */
614 for (winds
= scm_dynwinds
; SCM_CONSP (winds
); winds
= SCM_CDR (winds
))
616 dynpair
= SCM_CAR (winds
);
617 if (SCM_CONSP (dynpair
))
619 SCM this_key
= SCM_CAR (dynpair
);
621 if (SCM_EQ_P (this_key
, SCM_BOOL_T
) || SCM_EQ_P (this_key
, key
))
627 /* Dirk:FIXME:: This bugfix should be removed some time. */
628 /* GCC 2.95.2 has a bug in its optimizer that makes it generate
629 incorrect code sometimes. This barrier stops it from being too
631 asm volatile ("" : "=g" (winds
));
634 /* If we didn't find anything, print a message and abort the process
635 right here. If you don't want this, establish a catch-all around
636 any code that might throw up. */
637 if (SCM_NULLP (winds
))
639 scm_handle_by_message (NULL
, key
, args
);
643 /* If the wind list is malformed, bail. */
644 if (!SCM_CONSP (winds
))
647 jmpbuf
= SCM_CDR (dynpair
);
649 for (wind_goal
= scm_dynwinds
;
650 !SCM_EQ_P (SCM_CDAR (wind_goal
), jmpbuf
);
651 wind_goal
= SCM_CDR (wind_goal
))
654 /* Is a lazy catch? In wind list entries for lazy catches, the key
655 is bound to a lazy_catch smob, not a jmpbuf. */
656 if (SCM_LAZY_CATCH_P (jmpbuf
))
658 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CELL_WORD_1 (jmpbuf
);
660 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
661 - scm_ilength (wind_goal
)));
663 handle
= scm_dynwinds
;
664 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
666 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
667 scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL
);
670 /* Otherwise, it's a normal catch. */
671 else if (SCM_JMPBUFP (jmpbuf
))
673 struct jmp_buf_and_retval
* jbr
;
674 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
675 - scm_ilength (wind_goal
)));
676 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
677 jbr
->throw_tag
= key
;
679 #ifdef DEBUG_EXTENSIONS
680 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
682 longjmp (*JBJMPBUF (jmpbuf
), 1);
685 /* Otherwise, it's some random piece of junk. */
694 tc16_jmpbuffer
= scm_make_smob_type ("jmpbuffer", 0);
695 scm_set_smob_print (tc16_jmpbuffer
, jmpbuffer_print
);
697 tc16_lazy_catch
= scm_make_smob_type ("lazy-catch", 0);
698 scm_set_smob_print (tc16_lazy_catch
, lazy_catch_print
);
700 #include "libguile/throw.x"