X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/898a256f9156643b4ceb275776372ee4380b8df1..19b27fa236d0a5e20a01443070a4bcffe025af05:/libguile/throw.c diff --git a/libguile/throw.c b/libguile/throw.c index 2b527c16a..b3f9ed1d0 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -12,7 +12,8 @@ * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,8 +37,11 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ + * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,83 +50,73 @@ #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 "stacks.h" +#include "fluids.h" +#include "validate.h" #include "throw.h" -/* {Catch and Throw} - */ +/* the jump buffer data structure */ static int scm_tc16_jmpbuffer; -#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) -#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) -#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) -#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) +#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer)) + +#define JBACTIVE(OBJ) (SCM_UNPACK_CAR (OBJ) & (1L << 16L)) +#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) +#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) #ifndef DEBUG_EXTENSIONS -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) +#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) ) #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)); +#define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) ) +#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) ) +#define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X)) +#define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X) static scm_sizet -freejb (jbsmob) - SCM jbsmob; +freejb (SCM jbsmob) { scm_must_free ((char *) SCM_CDR (jbsmob)); return sizeof (scm_cell); } #endif -static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -printjb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +printjb (SCM exp, SCM port, scm_print_state *pstate) { - scm_gen_puts (scm_regular_string, "#', port); + scm_puts ("#', port); return 1 ; } -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 () +make_jmpbuf (void) { SCM answer; - SCM_NEWCELL (answer); SCM_REDEFER_INTS; { #ifdef DEBUG_EXTENSIONS char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); - SCM_SETCDR (answer, (SCM) mem); #endif - SCM_SETCAR (answer, scm_tc16_jmpbuffer); +#ifdef DEBUG_EXTENSIONS + SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, mem); +#else + SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0); +#endif SETJBJMPBUF(answer, (jmp_buf *)0); DEACTIVATEJB(answer); } @@ -130,6 +124,9 @@ make_jmpbuf () return answer; } + +/* scm_internal_catch (the guts of catch) */ + struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ { jmp_buf buf; /* must be first */ @@ -137,13 +134,56 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ SCM retval; }; + +/* 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) + 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. + + 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, THROWN_TAG, THROW_ARGS) + where + HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the + same idea as BODY_DATA above. + THROWN_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, after the tag. + + 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_apply (tag, proc, a1, args, handler) - SCM tag; - SCM proc; - SCM a1; - SCM args; - SCM handler; +scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data) { struct jmp_buf_and_retval jbr; SCM jmpbuf; @@ -172,19 +212,12 @@ scm_catch_apply (tag, proc, a1, args, handler) 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); - if (tag == SCM_BOOL_F) - answer = scm_apply (proc, - SCM_NULLP (a1) - ? scm_cons (jmpbuf, SCM_EOL) - : scm_cons2 (jmpbuf, a1, args), - SCM_EOL); - else - answer = scm_apply (proc, a1, args); + answer = body (body_data); SCM_REDEFER_INTS; DEACTIVATEJB (jmpbuf); scm_dynwinds = SCM_CDR (scm_dynwinds); @@ -193,154 +226,484 @@ scm_catch_apply (tag, proc, a1, args, handler) return answer; } -SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); + + +/* 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, "#", + (long) c->handler, (long) c->handler_data); + scm_puts (buf, port); + + return 1; +} + + +/* 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_RETURN_NEWSMOB (tc16_lazy_catch, c); +} + +#define SCM_LAZY_CATCH_P(obj) \ + (SCM_NIMP (obj) && (SCM_UNPACK_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. */ SCM -scm_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; +scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data) { - SCM_ASSERT ((tag == SCM_BOOL_F) - || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_catch); - return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler); + 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_REDEFER_INTS; + scm_dynwinds = SCM_CDR (scm_dynwinds); + SCM_REALLOW_INTS; + + return answer; +} + + +/* scm_internal_stack_catch + Use this one if you want debugging information to be stored in + scm_the_last_stack_fluid on error. */ + +static SCM +ss_handler (void *data, SCM tag, SCM throw_args) +{ + /* Save the stack */ + scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid), + scm_make_stack (scm_cons (SCM_BOOL_T, SCM_EOL))); + /* Throw the error */ + return scm_throw (tag, throw_args); +} + +struct cwss_data +{ + SCM tag; + scm_catch_body_t body; + void *data; +}; + +static SCM +cwss_body (void *data) +{ + struct cwss_data *d = data; + return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL); } -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; +scm_internal_stack_catch (SCM tag, + scm_catch_body_t body, + void *body_data, + scm_catch_handler_t handler, + void *handler_data) { - SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_lazy_catch); - scm_dynwinds = scm_acons (tag, handler, scm_dynwinds); - return scm_apply (thunk, SCM_EOL, SCM_EOL); + struct cwss_data d; + d.tag = tag; + d.body = body; + d.data = body_data; + return scm_internal_catch (tag, cwss_body, &d, handler, handler_data); } -/* The user has thrown to an uncaught key --- print a message and die. + + +/* body and handler functions for use with any of the above catch variants */ + +/* 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. + + 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. */ + +SCM +scm_body_thunk (void *body_data) +{ + struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data; + + 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: (throw TAG ARGS ...) + applies a handler procedure to (TAG ARGS ...). + + 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 (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); +} + +/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but + catches all throws that the handler might emit itself. The handler + used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */ + +struct hbpca_data { + SCM proc; + SCM args; +}; + +static SCM +hbpca_body (void *body_data) +{ + struct hbpca_data *data = (struct hbpca_data *)body_data; + return scm_apply (data->proc, data->args, SCM_EOL); +} + +SCM +scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args) +{ + SCM *handler_proc_p = (SCM *) handler_data; + struct hbpca_data data; + data.proc = *handler_proc_p; + data.args = scm_cons (tag, throw_args); + + return scm_internal_catch (SCM_BOOL_T, + hbpca_body, &data, + scm_handle_by_message_noexit, NULL); +} + +/* Derive the an exit status from the arguments to (quit ...). */ +int +scm_exit_status (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; +} + + +static void +handler_message (void *handler_data, SCM tag, SCM args) +{ + char *prog_name = (char *) handler_data; + SCM p = scm_cur_errp; + + if (scm_ilength (args) >= 3) + { + SCM stack = scm_make_stack (SCM_LIST1 (SCM_BOOL_T)); + SCM subr = SCM_CAR (args); + SCM message = SCM_CADR (args); + SCM parts = SCM_CADDR (args); + SCM rest = SCM_CDDDR (args); + + if (SCM_BACKTRACE_P && SCM_NFALSEP (stack)) + { + scm_puts ("Backtrace:\n", p); + scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED); + scm_newline (p); + } + scm_display_error (stack, p, subr, message, parts, rest); + } + else + { + if (! prog_name) + prog_name = "guile"; + + scm_puts (prog_name, p); + scm_puts (": ", p); + + scm_puts ("uncaught throw to ", p); + scm_prin1 (tag, p, 0); + scm_puts (": ", p); + scm_prin1 (args, p, 1); + scm_putc ('\n', p); + } +} + + +/* 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. */ -static SCM uncaught_throw SCM_P ((SCM key, SCM args)); -static SCM -uncaught_throw (key, args) - SCM key; - SCM args; + 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 (void *handler_data, SCM tag, SCM args) { - SCM p = scm_def_errp; - scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); - scm_prin1 (key, p, 0); - scm_gen_puts (scm_regular_string, ": ", p); - scm_prin1 (args, p, 1); - scm_gen_putc ('\n', p); - + if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit"))))) + { + exit (scm_exit_status (args)); + } + + handler_message (handler_data, tag, args); + /* try to flush the error message first before the rest of the + ports: if any throw error, it currently causes a bus + exception. */ exit (2); } -static char s_throw[]; +/* This is just like scm_handle_by_message, but it doesn't exit; it + just returns #f. It's useful in cases where you don't really know + enough about the body to handle things in a better way, but don't + want to let throws fall off the bottom of the wind list. */ SCM -scm_ithrow (key, args, noreturn) - SCM key; - SCM args; - int noreturn; +scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args) { - SCM jmpbuf; + handler_message (handler_data, tag, args); + + return SCM_BOOL_F; +} + + +SCM +scm_handle_by_throw (void *handler_data, SCM tag, SCM args) +{ + scm_ithrow (tag, args, 1); + return SCM_UNSPECIFIED; /* never returns */ +} + + + +/* the Scheme-visible CATCH and LAZY-CATCH functions */ + +SCM_DEFINE (scm_catch, "catch", 3, 0, 0, + (SCM tag, SCM thunk, SCM handler), + "Invoke @var{thunk} in the dynamic context of @var{handler} for\n" + "exceptions matching @var{key}. If thunk throws to the symbol @var{key},\n" + "then @var{handler} is invoked this way:\n\n" + "@example\n" + "(handler key args ...)\n" + "@end example\n\n" + "@var{key} is a symbol or #t.\n\n" + "@var{thunk} takes no arguments. If @var{thunk} returns normally, that\n" + "is the return value of @code{catch}.\n\n" + "Handler is invoked outside the scope of its own @code{catch}. If\n" + "@var{handler} again throws to the same key, a new handler from further\n" + "up the call chain is invoked.\n\n" + "If the key is @code{#t}, then a throw to @emph{any} symbol will match\n" + "this call to @code{catch}.") +#define FUNC_NAME s_scm_catch +{ + struct scm_body_thunk_data c; + + SCM_ASSERT (SCM_SYMBOLP(tag) || tag == SCM_BOOL_T, + tag, SCM_ARG1, FUNC_NAME); + + 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); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, + (SCM tag, SCM thunk, SCM handler), + "") +#define FUNC_NAME s_scm_lazy_catch +{ + struct scm_body_thunk_data c; + + SCM_ASSERT (SCM_SYMBOLP(tag) || (tag == SCM_BOOL_T), + tag, SCM_ARG1, FUNC_NAME); + + 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); +} +#undef FUNC_NAME + + + +/* throwing */ + +SCM_DEFINE (scm_throw, "throw", 1, 0, 1, + (SCM key, SCM args), + "Invoke the catch form matching @var{key}, passing @var{args} to the\n" + "@var{handler}. \n\n" + "@var{key} is a symbol. It will match catches of the same symbol or of\n" + "#t.\n\n" + "If there is no handler at all, an error is signaled.") +#define FUNC_NAME s_scm_throw +{ + SCM_VALIDATE_SYMBOL (1,key); + /* May return if handled by lazy catch. */ + return scm_ithrow (key, args, 1); +} +#undef FUNC_NAME + +SCM +scm_ithrow (SCM key, SCM args, int noreturn) +{ + SCM jmpbuf = SCM_UNDEFINED; SCM wind_goal; - if (SCM_NIMP (key) && SCM_JMPBUFP (key)) - { - jmpbuf = key; - if (noreturn) - { - SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf, - "throw to dynamically inactive catch", - s_throw); - } - else if (!JBACTIVE (jmpbuf)) - return SCM_UNSPECIFIED; - } - else - { - SCM dynpair; - SCM winds; + SCM dynpair = SCM_UNDEFINED; + SCM winds; - if (noreturn) - { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, - s_throw); - } - else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key))) - return SCM_UNSPECIFIED; + /* 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 (); - /* 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)) + dynpair = SCM_CAR (winds); + if (SCM_CONSP (dynpair)) { - if (! SCM_CONSP (winds)) - abort (); - - dynpair = SCM_CAR (winds); - if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair)) - { - SCM this_key = SCM_CAR (dynpair); + SCM this_key = SCM_CAR (dynpair); - if (this_key == SCM_BOOL_T || this_key == key) - break; - } + if (this_key == SCM_BOOL_T || this_key == key) + break; } + } - /* If we didn't find anything, print a message and exit Guile. */ - if (winds == SCM_EOL) - uncaught_throw (key, args); + /* 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 (SCM_IMP (winds) || SCM_NCONSP (winds)) - 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); + if (dynpair != SCM_BOOL_F) + jmpbuf = SCM_CDR (dynpair); + else + { + if (!noreturn) + return SCM_UNSPECIFIED; else { - if (!noreturn) - return SCM_UNSPECIFIED; - else - { - scm_exitval = scm_cons (key, args); - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); + 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); + scm_last_debug_frame = SCM_DFRAME (scm_rootcont); #endif - longjmp (SCM_JMPBUF (scm_rootcont), 1); - } + longjmp (SCM_JMPBUF (scm_rootcont), 1); } } + for (wind_goal = scm_dynwinds; SCM_CDAR (wind_goal) != jmpbuf; wind_goal = SCM_CDR (wind_goal)) ; - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - if (!SCM_JMPBUFP (jmpbuf)) + + /* 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; - return scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL); + 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; } - else + + /* 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 @@ -348,20 +711,26 @@ scm_ithrow (key, args, noreturn) } -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); -} - - void scm_init_throw () { - scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); + scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer", +#ifdef DEBUG_EXTENSIONS + sizeof (scm_cell), + NULL, /* mark */ + freejb, +#else + 0, + NULL, /* mark */ + NULL, +#endif + printjb, + NULL); + + tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0, + NULL, + NULL, + print_lazy_catch, + NULL); #include "throw.x" }