mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

* root.c: Establish a reliable catch-all handler for the new root.

Browse source 
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.
This commit is contained in:
Jim Blandy 1997-06-23 04:34:34 +00:00
parent eb1e924e07
commit f032b8a8a9
3 changed files with 87 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

39
libguile/root.c
View file

@ -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));

100
libguile/throw.c
View file

@ -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;
}

1
libguile/throw.h
View file

@ -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));