diff options
Diffstat (limited to 'libguile/throw.c')
-rw-r--r-- | libguile/throw.c | 584 |
1 files changed, 481 insertions, 103 deletions
diff --git a/libguile/throw.c b/libguile/throw.c index a84d7e92e..60e0c13e7 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -42,41 +42,56 @@ #include <stdio.h> #include "_scm.h" +#include "genio.h" +#include "smob.h" +#include "alist.h" +#include "eval.h" +#include "eq.h" +#include "dynwind.h" +#include "backtrace.h" +#ifdef DEBUG_EXTENSIONS +#include "debug.h" +#endif +#include "continuations.h" +#include "stackchk.h" - - +#include "throw.h" -/* {Catch and Throw} - */ + +/* the jump buffer data structure */ static int scm_tc16_jmpbuffer; -SCM scm_bad_throw_vcell; - #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) -#define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L)) -#define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L)) +#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) +#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) -#ifdef DEBUG_EXTENSIONS -#define JBSCM_DFRAME(O) ((debug_frame*)SCM_CAR (SCM_CDR (O)) ) -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) -#define SETJBSCM_DFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X) -#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) -#else +#ifndef DEBUG_EXTENSIONS #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) #define SETJBJMPBUF SCM_SETCDR +#else +#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) +#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) +#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) +#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) + +static scm_sizet freejb SCM_P ((SCM jbsmob)); + +static scm_sizet +freejb (jbsmob) + SCM jbsmob; +{ + scm_must_free ((char *) SCM_CDR (jbsmob)); + return sizeof (scm_cell); +} #endif -#ifdef __STDC__ -static int -printjb (SCM exp, SCM port, int writing) -#else +static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -printjb (exp, port, writing) +printjb (exp, port, pstate) SCM exp; SCM port; - int writing; -#endif + scm_print_state *pstate; { scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port); @@ -85,34 +100,39 @@ printjb (exp, port, writing) return 1 ; } -/* !!! The mark function needs to be different for - * debugging support. A. Green - */ -static scm_smobfuns jbsmob = {scm_mark0, scm_free0, printjb, 0}; - -#ifdef __STDC__ -static SCM -make_jmpbuf (void) +static scm_smobfuns jbsmob = { + scm_mark0, +#ifdef DEBUG_EXTENSIONS + freejb, #else + scm_free0, +#endif + printjb, + 0 +}; + +static SCM make_jmpbuf SCM_P ((void)); static SCM make_jmpbuf () -#endif { SCM answer; SCM_NEWCELL (answer); + SCM_REDEFER_INTS; + { #ifdef DEBUG_EXTENSIONS - SCM_NEWCELL (SCM_CDR (answer)); + char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); + SCM_SETCDR (answer, (SCM) mem); #endif - SCM_DEFER_INTS; - { - SCM_CAR(answer) = scm_tc16_jmpbuffer; + SCM_SETCAR (answer, scm_tc16_jmpbuffer); SETJBJMPBUF(answer, (jmp_buf *)0); DEACTIVATEJB(answer); } - SCM_ALLOW_INTS; + SCM_REALLOW_INTS; return answer; } + +/* scm_internal_catch (the guts of catch) */ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ { @@ -121,72 +141,402 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ SCM retval; }; -SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); -#ifdef __STDC__ -SCM -scm_catch (SCM tag, SCM thunk, SCM handler) -#else + +/* scm_internal_catch is the guts of catch. It handles all the + mechanics of setting up a catch target, invoking the catch body, + and perhaps invoking the handler if the body does a throw. + + The function is designed to be usable from C code, but is general + enough to implement all the semantics Guile Scheme expects from + throw. + + TAG is the catch tag. Typically, this is a symbol, but this + function doesn't actually care about that. + + BODY is a pointer to a C function which runs the body of the catch; + this is the code you can throw from. We call it like this: + BODY (BODY_DATA, JMPBUF) + where: + BODY_DATA is just the BODY_DATA argument we received; we pass it + through to BODY as its first argument. The caller can make + BODY_DATA point to anything useful that BODY might need. + JMPBUF is the Scheme jmpbuf object corresponding to this catch, + which we have just created and initialized. + + HANDLER is a pointer to a C function to deal with a throw to TAG, + should one occur. We call it like this: + HANDLER (HANDLER_DATA, TAG, THROW_ARGS) + where + HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the + same idea as BODY_DATA above. + TAG is the tag that the user threw to; usually this is TAG, but + it could be something else if TAG was #t (i.e., a catch-all), + or the user threw to a jmpbuf. + THROW_ARGS is the list of arguments the user passed to the THROW + function. + + BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA + is just a pointer we pass through to HANDLER. We don't actually + use either of those pointers otherwise ourselves. The idea is + that, if our caller wants to communicate something to BODY or + HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and + HANDLER can then use. Think of it as a way to make BODY and + HANDLER closures, not just functions; MUMBLE_DATA points to the + enclosed variables. + + Of course, it's up to the caller to make sure that any data a + MUMBLE_DATA needs is protected from GC. A common way to do this is + to make MUMBLE_DATA a pointer to data stored in an automatic + structure variable; since the collector must scan the stack for + references anyway, this assures that any references in MUMBLE_DATA + will be found. */ + SCM -scm_catch (tag, thunk, handler) +scm_internal_catch (tag, body, body_data, handler, handler_data) SCM tag; - SCM thunk; - SCM handler; -#endif + scm_catch_body_t body; + void *body_data; + scm_catch_handler_t handler; + void *handler_data; { struct jmp_buf_and_retval jbr; SCM jmpbuf; SCM answer; - SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_catch); jmpbuf = make_jmpbuf (); answer = SCM_EOL; scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); SETJBJMPBUF(jmpbuf, &jbr.buf); #ifdef DEBUG_EXTENSIONS - SETJBSCM_DFRAME(jmpbuf, last_debug_info_frame); + SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); #endif if (setjmp (jbr.buf)) { SCM throw_tag; SCM throw_args; - SCM_DEFER_INTS; +#ifdef STACK_CHECKING + scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; +#endif + SCM_REDEFER_INTS; DEACTIVATEJB (jmpbuf); scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_ALLOW_INTS; + SCM_REALLOW_INTS; throw_args = jbr.retval; throw_tag = jbr.throw_tag; jbr.throw_tag = SCM_EOL; jbr.retval = SCM_EOL; - answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL); + answer = handler (handler_data, throw_tag, throw_args); } else { ACTIVATEJB (jmpbuf); - answer = scm_apply (thunk, - ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL), - SCM_EOL); - SCM_DEFER_INTS; + answer = body (body_data, jmpbuf); + SCM_REDEFER_INTS; DEACTIVATEJB (jmpbuf); scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_ALLOW_INTS; + SCM_REALLOW_INTS; } return answer; } -static char s_throw[]; -#ifdef __STDC__ + +/* scm_internal_lazy_catch (the guts of lazy catching) */ + +/* The smob tag for lazy_catch smobs. */ +static long tc16_lazy_catch; + +/* This is the structure we put on the wind list for a lazy catch. It + stores the handler function to call, and the data pointer to pass + through to it. It's not a Scheme closure, but it is a function + with data, so the term "closure" is appropriate in its broader + sense. + + (We don't need anything like this in the "eager" catch code, + because the same C frame runs both the body and the handler.) */ +struct lazy_catch { + scm_catch_handler_t handler; + void *handler_data; +}; + +/* Strictly speaking, we could just pass a zero for our print + function, because we don't need to print them. They should never + appear in normal data structures, only in the wind list. However, + it might be nice for debugging someday... */ +static int +print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate) +{ + struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (closure); + char buf[200]; + + sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>", + (long) c->handler, (long) c->handler_data); + scm_gen_puts (scm_regular_string, buf, port); + + return 1; +} + +static scm_smobfuns lazy_catch_funs = { + scm_mark0, scm_free0, print_lazy_catch, 0 +}; + + +/* Given a pointer to a lazy catch structure, return a smob for it, + suitable for inclusion in the wind list. ("Ah yes, a Château + Gollombiere '72, non?"). */ +static SCM +make_lazy_catch (struct lazy_catch *c) +{ + SCM smob; + + SCM_NEWCELL (smob); + SCM_SETCDR (smob, c); + SCM_SETCAR (smob, tc16_lazy_catch); + + return smob; +} + +#define SCM_LAZY_CATCH_P(obj) \ + (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch)) + + +/* Exactly like scm_internal_catch, except: + - It does not unwind the stack (this is the major difference). + - If handler returns, its value is returned from the throw. + - BODY always receives #f as its JMPBUF argument (since there's no + jmpbuf associated with a lazy catch, because we don't unwind the + stack.) */ +SCM +scm_internal_lazy_catch (tag, body, body_data, handler, handler_data) + SCM tag; + scm_catch_body_t body; + void *body_data; + scm_catch_handler_t handler; + void *handler_data; +{ + SCM lazy_catch, answer; + struct lazy_catch c; + + c.handler = handler; + c.handler_data = handler_data; + lazy_catch = make_lazy_catch (&c); + + SCM_REDEFER_INTS; + scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds); + SCM_REALLOW_INTS; + + answer = (*body) (body_data, SCM_BOOL_F); + + SCM_REDEFER_INTS; + scm_dynwinds = SCM_CDR (scm_dynwinds); + SCM_REALLOW_INTS; + + return answer; +} + + + +/* body and handler functions for use with either of the above */ + +/* This is a body function you can pass to scm_internal_catch if you + want the body to be like Scheme's `catch' --- a thunk, or a + function of one argument if the tag is #f. + + BODY_DATA is a pointer to a scm_body_thunk_data structure, which + contains the Scheme procedure to invoke as the body, and the tag + we're catching. If the tag is #f, then we pass JMPBUF (created by + scm_internal_catch) to the body procedure; otherwise, the body gets + no arguments. */ + SCM -scm_ithrow (SCM key, SCM args, int noreturn) -#else +scm_body_thunk (body_data, jmpbuf) + void *body_data; + SCM jmpbuf; +{ + struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data; + + if (c->tag == SCM_BOOL_F) + return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL); + else + return scm_apply (c->body_proc, SCM_EOL, SCM_EOL); +} + + +/* This is a handler function you can pass to scm_internal_catch if + you want the handler to act like Scheme's catch --- call a + procedure with the tag and the throw arguments. + + If the user does a throw to this catch, this function runs a + handler procedure written in Scheme. HANDLER_DATA is a pointer to + an SCM variable holding the Scheme procedure object to invoke. It + ought to be a pointer to an automatic variable (i.e., one living on + the stack), or the procedure object should be otherwise protected + from GC. */ +SCM +scm_handle_by_proc (handler_data, tag, throw_args) + void *handler_data; + SCM tag; + SCM throw_args; +{ + SCM *handler_proc_p = (SCM *) handler_data; + + return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL); +} + + +/* This is a handler function to use if you want scheme to print a + message and die. Useful for dealing with throws to uncaught keys + at the top level. + + At boot time, we establish a catch-all that uses this as its handler. + 1) If the user wants something different, they can use (catch #t + ...) to do what they like. + 2) Outside the context of a read-eval-print loop, there isn't + anything else good to do; libguile should not assume the existence + of a read-eval-print loop. + 3) Given that we shouldn't do anything complex, it's much more + robust to do it in C code. + + HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a + message header to print; if zero, we use "guile" instead. That + text is followed by a colon, then the message described by ARGS. */ + +SCM +scm_handle_by_message (handler_data, tag, args) + void *handler_data; + SCM tag; + SCM args; +{ + char *prog_name = (char *) handler_data; + SCM p = scm_def_errp; + + if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit"))))) + exit (scm_exit_status (args)); + + if (! prog_name) + prog_name = "guile"; + + scm_gen_puts (scm_regular_string, prog_name, p); + scm_gen_puts (scm_regular_string, ": ", p); + + if (scm_ilength (args) >= 3) + { + SCM message = SCM_CADR (args); + SCM parts = SCM_CADDR (args); + + scm_display_error_message (message, parts, p); + } + else + { + scm_gen_puts (scm_regular_string, "uncaught throw to ", p); + scm_prin1 (tag, p, 0); + scm_gen_puts (scm_regular_string, ": ", p); + scm_prin1 (args, p, 1); + scm_gen_putc ('\n', p); + } + + exit (2); +} + + +/* Derive the an exit status from the arguments to (quit ...). */ +int +scm_exit_status (args) + SCM args; +{ + if (SCM_NNULLP (args)) + { + SCM cqa = SCM_CAR (args); + + if (SCM_INUMP (cqa)) + return (SCM_INUM (cqa)); + else if (SCM_FALSEP (cqa)) + return 1; + } + return 0; +} + + + + +/* the Scheme-visible CATCH and LAZY-CATCH functions */ + +SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); +SCM +scm_catch (tag, thunk, handler) + SCM tag; + SCM thunk; + SCM handler; +{ + struct scm_body_thunk_data c; + + SCM_ASSERT ((tag == SCM_BOOL_F) + || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) + || (tag == SCM_BOOL_T), + tag, SCM_ARG1, s_catch); + + c.tag = tag; + c.body_proc = thunk; + + /* scm_internal_catch takes care of all the mechanics of setting up + a catch tag; we tell it to call scm_body_thunk to run the body, + and scm_handle_by_proc to deal with any throws to this catch. + The former receives a pointer to c, telling it how to behave. + The latter receives a pointer to HANDLER, so it knows who to call. */ + return scm_internal_catch (tag, + scm_body_thunk, &c, + scm_handle_by_proc, &handler); +} + + +SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); +SCM +scm_lazy_catch (tag, thunk, handler) + SCM tag; + SCM thunk; + SCM handler; +{ + struct scm_body_thunk_data c; + + SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) + || (tag == SCM_BOOL_T), + tag, SCM_ARG1, s_lazy_catch); + + c.tag = tag; + c.body_proc = thunk; + + /* scm_internal_lazy_catch takes care of all the mechanics of + setting up a lazy catch tag; we tell it to call scm_body_thunk to + run the body, and scm_handle_by_proc to deal with any throws to + this catch. The former receives a pointer to c, telling it how + to behave. The latter receives a pointer to HANDLER, so it knows + who to call. */ + return scm_internal_lazy_catch (tag, + scm_body_thunk, &c, + scm_handle_by_proc, &handler); +} + + + +/* throwing */ + +SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); +SCM +scm_throw (key, args) + SCM key; + SCM args; +{ + /* May return if handled by lazy catch. */ + return scm_ithrow (key, args, 1); +} + + SCM scm_ithrow (key, args, noreturn) SCM key; SCM args; int noreturn; -#endif { SCM jmpbuf; SCM wind_goal; @@ -205,28 +555,43 @@ scm_ithrow (key, args, noreturn) } else { - SCM dynpair; - SCM hook; + SCM dynpair = SCM_UNDEFINED; + SCM winds; if (noreturn) { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw); + SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, + s_throw); } else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key))) return SCM_UNSPECIFIED; - dynpair = scm_sloppy_assq (key, scm_dynwinds); + /* Search the wind list for an appropriate catch. + "Waiter, please bring us the wind list." */ + for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds)) + { + if (! SCM_CONSP (winds)) + abort (); - if (dynpair == SCM_BOOL_F) - dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds); + dynpair = SCM_CAR (winds); + if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair)) + { + SCM this_key = SCM_CAR (dynpair); - hook = SCM_CDR (scm_bad_throw_vcell); - if ((dynpair == SCM_BOOL_F) - && (SCM_BOOL_T == scm_procedure_p (hook))) - { - SCM answer; - answer = scm_apply (hook, scm_cons (key, args), SCM_EOL); + if (this_key == SCM_BOOL_T || this_key == key) + break; + } } + + /* If we didn't find anything, abort. scm_boot_guile should + have established a catch-all, but obviously things are + thoroughly screwed up. */ + if (winds == SCM_EOL) + abort (); + + /* If the wind list is malformed, bail. */ + if (SCM_IMP (winds) || SCM_NCONSP (winds)) + abort (); if (dynpair != SCM_BOOL_F) jmpbuf = SCM_CDR (dynpair); @@ -238,54 +603,67 @@ scm_ithrow (key, args, noreturn) { scm_exitval = scm_cons (key, args); scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); +#ifdef DEBUG_EXTENSIONS + scm_last_debug_frame = SCM_DFRAME (scm_rootcont); +#endif longjmp (SCM_JMPBUF (scm_rootcont), 1); } } } -#ifdef DEBUG_EXTENSIONS - last_debug_info_frame = JBSCM_DFRAME (jmpbuf); -#endif for (wind_goal = scm_dynwinds; SCM_CDAR (wind_goal) != jmpbuf; wind_goal = SCM_CDR (wind_goal)) ; - { - struct jmp_buf_and_retval * jbr; - jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); - jbr->throw_tag = key; - jbr->retval = args; - } - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - longjmp (*JBJMPBUF (jmpbuf), 1); -} + /* Is a lazy catch? In wind list entries for lazy catches, the key + is bound to a lazy_catch smob, not a jmpbuf. */ + if (SCM_LAZY_CATCH_P (jmpbuf)) + { + struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (jmpbuf); + SCM oldwinds = scm_dynwinds; + SCM handle, answer; + scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds) + - scm_ilength (wind_goal))); + SCM_REDEFER_INTS; + handle = scm_dynwinds; + scm_dynwinds = SCM_CDR (scm_dynwinds); + SCM_REALLOW_INTS; + answer = (c->handler) (c->handler_data, key, args); + SCM_REDEFER_INTS; + SCM_SETCDR (handle, scm_dynwinds); + scm_dynwinds = handle; + SCM_REALLOW_INTS; + scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds) + - scm_ilength (oldwinds))); + return answer; + } -SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); -#ifdef __STDC__ -SCM -scm_throw (SCM key, SCM args) -#else -SCM -scm_throw (key, args) - SCM key; - SCM args; + /* Otherwise, it's a normal catch. */ + else if (SCM_JMPBUFP (jmpbuf)) + { + struct jmp_buf_and_retval * jbr; + scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds) + - scm_ilength (wind_goal))); + jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); + jbr->throw_tag = key; + jbr->retval = args; + } + + /* Otherwise, it's some random piece of junk. */ + else + abort (); + +#ifdef DEBUG_EXTENSIONS + scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); #endif -{ - scm_ithrow (key, args, 1); - return SCM_BOOL_F; /* never really returns */ + longjmp (*JBJMPBUF (jmpbuf), 1); } -#ifdef __STDC__ -void -scm_init_throw (void) -#else void scm_init_throw () -#endif { scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); - scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", SCM_BOOL_F); + tc16_lazy_catch = scm_newsmob (&lazy_catch_funs); #include "throw.x" } - |