mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +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

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