diff options
author | Jim Blandy <jimb@red-bean.com> | 1996-12-21 04:48:21 +0000 |
---|---|---|
committer | Jim Blandy <jimb@red-bean.com> | 1996-12-21 04:48:21 +0000 |
commit | 816a6f06c852efd6065bf9d2a943eb6896795f8d (patch) | |
tree | e50449b0bfd5171ae8b8668ace9cf48b02291f61 | |
parent | 370312ae6e74756a825f3eeed0e227c568142f16 (diff) | |
download | guile-816a6f06c852efd6065bf9d2a943eb6896795f8d.tar.gz |
* throw.c (scm_internal_catch): Make body funcs and handler funcs
use separate data pointers, to allow them to be designed
independently and reused.
(scm_body_thunk, scm_handle_by_proc, scm_handle_by_message):
Renamed from catch_body, catch_handler, and uncaught_throw; made
generically useful.
(struct scm_catch_body_data): Renamed from catch_body_data; moved
to throw.h.
(scm_catch): Use the above.
(scm_throw): Don't bother printing a message for an uncaught
throw; we establish a default handler in init.
* throw.h (scm_internal_catch): Prototype updated.
(scm_body_thunk, scm_handle_by_proc, scm_handle_by_message): New
decls.
(struct scm_body_thunk_data): New structure, used as data
argument to scm_body_thunk.
* init.c (struct main_func_closure): New structure, packaging up
the data to pass to the user's main function.
(scm_boot_guile): Create one. Pass it to scm_boot_guile_1.
(scm_boot_guile_1): Pass it through to invoke_main_func. Use
scm_internal_catch to establish a catch-all handler, using
scm_handle_by_message. This replaces the special-case code in
scm_throw.
(invoke_main_func): Body function for scm_internal_catch; invoke
the user's main function, using the main_func_closure pointer to
decide what to pass it.
* root.c (struct cwdr_body_data): Remove handler_proc member.
(cwdr): Use scm_handle_by_proc instead of cwdr_handler.
(cwdr_handler): Removed.
-rw-r--r-- | libguile/init.c | 61 | ||||
-rw-r--r-- | libguile/root.c | 30 | ||||
-rw-r--r-- | libguile/throw.c | 142 | ||||
-rw-r--r-- | libguile/throw.h | 23 |
4 files changed, 151 insertions, 105 deletions
diff --git a/libguile/init.c b/libguile/init.c index 2bcfb76fd..f0743f129 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -261,12 +261,20 @@ typedef int setjmp_type; typedef long setjmp_type; #endif -static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, - int argc, char **argv, - void (*main_func) (void *closure, - int argc, - char **argv), - void *closure)); +/* All the data needed to invoke the main function. */ +struct main_func_closure +{ + /* the function to call */ + void (*main_func) SCM_P ((void *closure, int argc, char **argv)); + void *closure; /* dummy data to pass it */ + int argc; + char **argv; /* the argument list it should receive */ +}; + + +static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, + struct main_func_closure *closure)); +static SCM invoke_main_func SCM_P ((void *body_data, SCM jmpbuf)); /* Fire up the Guile Scheme interpreter. @@ -282,6 +290,12 @@ static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, call scm_set_program_arguments with the final list, so Scheme code will know which arguments have been processed. + scm_boot_guile establishes a catch-all catch handler which prints + an error message and exits the process. This means that Guile + exits in a coherent way when system errors occur and the user isn't + prepared to handle it. If the user doesn't like this behavior, + they can establish their own universal catcher to shadow this one. + Why must the caller do all the real work from MAIN_FUNC? The garbage collector assumes that all local variables of type SCM will be above scm_boot_guile's stack frame on the stack. If you try to @@ -302,10 +316,17 @@ scm_boot_guile (argc, argv, main_func, closure) end of the stack, and the address of one of its own local variables as the other end. */ SCM_STACKITEM dummy; + struct main_func_closure c; - return scm_boot_guile_1 (&dummy, argc, argv, main_func, closure); + c.main_func = main_func; + c.closure = closure; + c.argc = argc; + c.argv = argv; + + return scm_boot_guile_1 (&dummy, &c); } + /* Record here whether SCM_BOOT_GUILE_1 has already been called. This variable is now here and not inside SCM_BOOT_GUILE_1 so that one can tweak it. This is necessary for unexec to work. (Hey, "1-live" @@ -314,12 +335,9 @@ scm_boot_guile (argc, argv, main_func, closure) int scm_boot_guile_1_live = 0; static void -scm_boot_guile_1 (base, argc, argv, main_func, closure) +scm_boot_guile_1 (base, closure) SCM_STACKITEM *base; - int argc; - char **argv; - void (*main_func) (); - void *closure; + struct main_func_closure *closure; { static int initialized = 0; /* static int live = 0; */ @@ -436,8 +454,9 @@ scm_boot_guile_1 (base, argc, argv, main_func, closure) { scm_init_signals (); - scm_set_program_arguments (argc, argv, 0); - (*main_func) (closure, argc, argv); + scm_set_program_arguments (closure->argc, closure->argv, 0); + scm_internal_catch (SCM_BOOL_T, invoke_main_func, closure, + scm_handle_by_message, 0); } scm_restore_signals (); @@ -452,3 +471,17 @@ scm_boot_guile_1 (base, argc, argv, main_func, closure) main_func themselves. */ exit (0); } + + +static SCM +invoke_main_func (body_data, jmpbuf) + void *body_data; + SCM jmpbuf; +{ + struct main_func_closure *closure = (struct main_func_closure *) body_data; + + (*closure->main_func) (closure->closure, closure->argc, closure->argv); + + /* never reached */ + return SCM_UNDEFINED; +} diff --git a/libguile/root.c b/libguile/root.c index b79e7b72b..7546ecbd5 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -178,8 +178,8 @@ static int n_dynamic_roots = 0; /* cwdr fills out one of these structures, and then passes a pointer - to it through scm_internal_catch to the cwdr_body and cwdr_handler - functions, to tell them how to behave. + to it through scm_internal_catch to the cwdr_body function, to tell + it how to behave. A cwdr is a lot like a catch, except there is no tag (all exceptions are caught), and the body procedure takes the arguments @@ -192,15 +192,15 @@ struct cwdr_body_data { /* Scheme procedure to use as body of cwdr. */ SCM body_proc; - - /* Scheme procedure to call if a throw occurs within the cwdr. */ - SCM handler_proc; }; /* Invoke the body of a cwdr, assuming that the throw handler has already been set up. DATA points to a struct set up by cwdr that - says what proc to call, and what args to apply it to. */ + says what proc to call, and what args to apply it to. + + With a little thought, we could replace this with scm_body_thunk, + but I don't want to mess with that at the moment. */ static SCM cwdr_body SCM_P ((void *, SCM)); static SCM @@ -212,19 +212,6 @@ cwdr_body (void *data, SCM jmpbuf) } -/* Invoke the handler of a cwdr. DATA points to a struct set up by - cwdr that says what proc to call to handle the throw. */ -static SCM cwdr_handler SCM_P ((void *, SCM, SCM)); - -static SCM -cwdr_handler (void *data, SCM tag, SCM throw_args) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); -} - - static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)); /* This is the basic code for new root creation. @@ -282,9 +269,10 @@ cwdr (proc, a1, args, handler, stack_start) c.a1 = a1; c.args = args; c.body_proc = proc; - c.handler_proc = handler; - answer = scm_internal_catch (SCM_BOOL_T, cwdr_body, cwdr_handler, &c); + answer = scm_internal_catch (SCM_BOOL_T, + cwdr_body, &c, + scm_handle_by_proc, &handler); } scm_dowinds (old_winds, - scm_ilength (old_winds)); diff --git a/libguile/throw.c b/libguile/throw.c index 7e67df4da..c168f5bd7 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -152,39 +152,42 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ 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 (DATA, JMPBUF) + BODY (BODY_DATA, JMPBUF) where: - DATA is just the DATA argument we received; we pass it through - to BODY as its first argument. The caller can make DATA point - to anything useful that BODY might need. + 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 (DATA, TAG, THROW_ARGS) + HANDLER (HANDLER_DATA, TAG, THROW_ARGS) where - DATA is the DATA argument we recevied, as for BODY above. + 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. - DATA is just a pointer we pass through to BODY and (if we call it) - HANDLER. We don't actually use it otherwise ourselves. The idea - is that, if our caller wants to communicate something to BODY and - HANDLER, it can pass a pointer to it as DATA, which BODY and - HANDLER can then use. Think of it as a way to make BODY and - HANDLER closures, not just functions; DATA points to the enclosed - variables. */ + 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. */ SCM -scm_internal_catch (tag, body, handler, data) +scm_internal_catch (tag, body, body_data, handler, handler_data) SCM tag; scm_catch_body_t body; + void *body_data; scm_catch_handler_t handler; - void *data; + void *handler_data; { struct jmp_buf_and_retval jbr; SCM jmpbuf; @@ -213,12 +216,12 @@ scm_internal_catch (tag, body, handler, data) throw_tag = jbr.throw_tag; jbr.throw_tag = SCM_EOL; jbr.retval = SCM_EOL; - answer = handler (data, throw_tag, throw_args); + answer = handler (handler_data, throw_tag, throw_args); } else { ACTIVATEJB (jmpbuf); - answer = body (data, jmpbuf); + answer = body (body_data, jmpbuf); SCM_REDEFER_INTS; DEACTIVATEJB (jmpbuf); scm_dynwinds = SCM_CDR (scm_dynwinds); @@ -228,35 +231,20 @@ scm_internal_catch (tag, body, handler, data) } -/* scm_catch passes a pointer to one of these structures through to - its body and handler routines, to tell them what to do. */ -struct catch_body_data -{ - /* The tag being caught. We only use it to figure out what - arguments to pass to the body procedure; see catch_body for - details. */ - SCM tag; - - /* The Scheme procedure object constituting the catch body. - catch_body invokes this. */ - SCM body_proc; - - /* The Scheme procedure object we invoke to handle throws. */ - SCM handler_proc; -}; - +/* 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. -/* This function runs the catch body. DATA contains the Scheme - procedure to invoke. If the tag being caught is #f, then we pass - JMPBUF to the body procedure; otherwise, it gets no arguments. */ -static SCM catch_body SCM_P ((void *, SCM)); + DATA contains the Scheme procedure to invoke. If the tag being + caught is #f, then we pass JMPBUF to the body procedure; otherwise, + it gets no arguments. */ -static SCM -catch_body (data, jmpbuf) - void *data; +SCM +scm_body_thunk (body_data, jmpbuf) + void *body_data; SCM jmpbuf; { - struct catch_body_data *c = (struct catch_body_data *) data; + 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); @@ -265,19 +253,20 @@ catch_body (data, jmpbuf) } -/* If the user does a throw to this catch, this function runs the - handler. DATA says which Scheme procedure object to invoke. */ -static SCM catch_handler SCM_P ((void *, SCM, SCM)); - -static SCM -catch_handler (data, tag, throw_args) - void *data; +/* 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, 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; { - struct catch_body_data *c = (struct catch_body_data *) data; + SCM *handler_proc_p = (SCM *) handler_data; - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); + return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL); } @@ -288,7 +277,7 @@ scm_catch (tag, thunk, handler) SCM thunk; SCM handler; { - struct catch_body_data c; + struct scm_body_thunk_data c; SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) @@ -297,14 +286,15 @@ scm_catch (tag, thunk, handler) c.tag = tag; c.body_proc = thunk; - c.handler_proc = handler; /* scm_internal_catch takes care of all the mechanics of setting up - a catch tag; we tell it to call catch_body to run the body, and - catch_handler to deal with any throws to this catch. Both those - functions receive the pointer to c, which tells them the details - of how to behave. */ - return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c); + 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); @@ -328,34 +318,46 @@ scm_lazy_catch (tag, thunk, handler) return answer; } -/* The user has thrown to an uncaught key --- print a message and die. +/* The user has thrown to an uncaught key --- print a message and die. + 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; + 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 (! 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_gen_puts (scm_regular_string, "guile: ", p); scm_display_error_message (message, parts, p); } else { - scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); - scm_prin1 (key, p, 0); + 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); @@ -417,9 +419,11 @@ scm_ithrow (key, args, noreturn) } } - /* If we didn't find anything, print a message and exit Guile. */ + /* 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) - uncaught_throw (key, args); + abort (); if (SCM_IMP (winds) || SCM_NCONSP (winds)) abort (); diff --git a/libguile/throw.h b/libguile/throw.h index 83d8e946d..26c0d9aa3 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -54,8 +54,29 @@ typedef SCM (*scm_catch_handler_t) SCM_P ((void *data, extern SCM scm_internal_catch SCM_P ((SCM tag, scm_catch_body_t body, + void *body_data, scm_catch_handler_t handler, - void *data)); + void *handler_data)); + +/* The first argument to scm_body_thunk should be a pointer to one of + these. See the implementation of catch in throw.c. */ +struct scm_body_thunk_data +{ + /* The tag being caught. We only use it to figure out what + arguments to pass to the body procedure; see scm_catch_thunk_body for + details. */ + SCM tag; + + /* The Scheme procedure object constituting the catch body. + scm_body_by_proc invokes this. */ + SCM body_proc; +}; + +extern SCM scm_body_thunk SCM_P ((void *, SCM)); + + +extern SCM scm_handle_by_proc SCM_P ((void *, SCM, SCM)); +extern SCM scm_handle_by_message SCM_P ((void *, SCM, SCM)); extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); |