From f032b8a8a94d9e3cdc77a2afdc7f63cc3121ab0b Mon Sep 17 00:00:00 2001 From: Jim Blandy Date: Mon, 23 Jun 1997 04:34:34 +0000 Subject: [PATCH] * root.c: Establish a reliable catch-all handler for the new root. After all the Scheme handler function might signal an error too, and we don't want to lose that. (cwdr_inner_body): Renamed from cwdr_body. (cwdr_outer_body): New function, to establish the user's handler, and pass control to cwdr_inner_body. (cwdr): Establish the reliable catch-all handler here, and pass control to cwdr_outer_body. (struct cwdr_body_data): New field, handler, to allow cwdr to pass the user's handler through to cwdr_outer_body. * throw.c (scm_handle_by_message): Move guts into.... (handler_message): New static function. (scm_handle_by_message_noexit): New function. * throw.h (scm_handle_by_message_noexit): New prototype. --- libguile/root.c | 39 +++++++++++------- libguile/throw.c | 100 +++++++++++++++++++++++++++++------------------ libguile/throw.h | 1 + 3 files changed, 87 insertions(+), 53 deletions(-) diff --git a/libguile/root.c b/libguile/root.c index 82fb099b4..5d9cbc2e2 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -187,12 +187,14 @@ static int n_dynamic_roots = 0; passed to cwdr as A1 and ARGS. */ struct cwdr_body_data { - /* Arguments to pass to the cwdr body function. */ SCM a1, args; /* Scheme procedure to use as body of cwdr. */ SCM body_proc; + + /* Scheme handler function to establish. */ + SCM handler; }; @@ -202,10 +204,8 @@ struct cwdr_body_data { 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 -cwdr_body (void *data, SCM jmpbuf) +cwdr_inner_body (void *data, SCM jmpbuf) { struct cwdr_body_data *c = (struct cwdr_body_data *) data; @@ -213,7 +213,20 @@ cwdr_body (void *data, SCM jmpbuf) } -static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)); +/* Invoke the body of a cwdr, assuming that the last-ditch handler has + been established. The structure DATA points to must live on the + stack, or else it won't be found by the GC. Establish the user's + handler, and pass control to cwdr_inner_body, which will invoke the + users' body. Maybe the user has a nice body. */ +static SCM +cwdr_outer_body (void *data, SCM jmpbuf) +{ + struct cwdr_body_data *c = (struct cwdr_body_data *) data; + + return scm_internal_catch (SCM_BOOL_T, + cwdr_inner_body, &c, + scm_handle_by_proc, &c->handler); +} /* This is the basic code for new root creation. * @@ -222,12 +235,7 @@ static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM * in a messed up state. */ static SCM -cwdr (proc, a1, args, handler, stack_start) - SCM proc; - SCM a1; - SCM args; - SCM handler; - SCM_STACKITEM *stack_start; +cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start) { int old_ints_disabled = scm_ints_disabled; SCM old_rootcont, old_winds; @@ -263,17 +271,20 @@ cwdr (proc, a1, args, handler, stack_start) scm_last_debug_frame = 0; #endif - /* Catch all errors. */ + /* Catch absolutely all errors. We actually use + scm_handle_by_message_noexit here, and then install HANDLER in + cwdr_outer_body, because HANDLER might encounter errors itself. */ { struct cwdr_body_data c; c.a1 = a1; c.args = args; c.body_proc = proc; + c.handler = handler; answer = scm_internal_catch (SCM_BOOL_T, - cwdr_body, &c, - scm_handle_by_proc, &handler); + cwdr_outer_body, &c, + scm_handle_by_message_noexit, 0); } scm_dowinds (old_winds, - scm_ilength (old_winds)); diff --git a/libguile/throw.c b/libguile/throw.c index dbb98a46e..bf3af10d9 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -385,6 +385,54 @@ scm_handle_by_proc (handler_data, tag, throw_args) } +/* 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; +} + + +static void +handler_message (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_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); + } +} + + /* 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. @@ -408,55 +456,29 @@ scm_handle_by_message (handler_data, tag, args) 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); - } + handler_message (handler_data, tag, args); exit (2); } -/* Derive the an exit status from the arguments to (quit ...). */ -int -scm_exit_status (args) - SCM args; +/* 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_handle_by_message_noexit (handler_data, tag, args) + void *handler_data; + SCM tag; + 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; + handler_message (handler_data, tag, args); + + return SCM_BOOL_F; } - diff --git a/libguile/throw.h b/libguile/throw.h index 81f5fd6d9..f74b53dfd 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -83,6 +83,7 @@ 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_handle_by_message_noexit SCM_P ((void *, SCM, SCM)); extern int scm_exit_status SCM_P ((SCM args)); extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler));