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

* throw.c (scm_internal_catch): Make body funcs and handler funcs

Browse source 
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.
This commit is contained in:
Jim Blandy 1996-12-21 04:48:21 +00:00
parent 370312ae6e
commit 816a6f06c8
4 changed files with 151 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

61
libguile/init.c
View file

@ -261,12 +261,20 @@ typedef int setjmp_type;
typedef long setjmp_type; typedef long setjmp_type;
#endif #endif
static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, /* All the data needed to invoke the main function. */
int argc, char **argv, struct main_func_closure
void (*main_func) (void *closure, {
int argc, /* the function to call */
char **argv), void (*main_func) SCM_P ((void *closure, int argc, char **argv));
void *closure)); 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. /* 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 call scm_set_program_arguments with the final list, so Scheme code
will know which arguments have been processed. 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 Why must the caller do all the real work from MAIN_FUNC? The
garbage collector assumes that all local variables of type SCM will 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 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 end of the stack, and the address of one of its own local
variables as the other end. */ variables as the other end. */
SCM_STACKITEM dummy; 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 /* 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 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" 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; int scm_boot_guile_1_live = 0;
static void static void
scm_boot_guile_1 (base, argc, argv, main_func, closure) scm_boot_guile_1 (base, closure)
SCM_STACKITEM *base; SCM_STACKITEM *base;
int argc; struct main_func_closure *closure;
char **argv;
void (*main_func) ();
void *closure;
{ {
static int initialized = 0; static int initialized = 0;
/* static int live = 0; */ /* static int live = 0; */
@ -436,8 +454,9 @@ scm_boot_guile_1 (base, argc, argv, main_func, closure)
{ {
scm_init_signals (); scm_init_signals ();
scm_set_program_arguments (argc, argv, 0); scm_set_program_arguments (closure->argc, closure->argv, 0);
(*main_func) (closure, argc, argv); scm_internal_catch (SCM_BOOL_T, invoke_main_func, closure,
scm_handle_by_message, 0);
} }
scm_restore_signals (); scm_restore_signals ();
@ -452,3 +471,17 @@ scm_boot_guile_1 (base, argc, argv, main_func, closure)
main_func themselves. */ main_func themselves. */
exit (0); 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;
}

30
libguile/root.c
View file

@ -178,8 +178,8 @@ static int n_dynamic_roots = 0;
/* cwdr fills out one of these structures, and then passes a pointer /* 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 to it through scm_internal_catch to the cwdr_body function, to tell
functions, to tell them how to behave. it how to behave.
A cwdr is a lot like a catch, except there is no tag (all A cwdr is a lot like a catch, except there is no tag (all
exceptions are caught), and the body procedure takes the arguments 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. */ /* Scheme procedure to use as body of cwdr. */
SCM body_proc; 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 /* 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 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 cwdr_body SCM_P ((void *, SCM));
static 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)); 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. /* This is the basic code for new root creation.
@ -282,9 +269,10 @@ cwdr (proc, a1, args, handler, stack_start)
c.a1 = a1; c.a1 = a1;
c.args = args; c.args = args;
c.body_proc = proc; 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)); scm_dowinds (old_winds, - scm_ilength (old_winds));

142
libguile/throw.c
View file

@ -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; 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: this is the code you can throw from. We call it like this:
BODY (DATA, JMPBUF) BODY (BODY_DATA, JMPBUF)
where: where:
DATA is just the DATA argument we received; we pass it through BODY_DATA is just the BODY_DATA argument we received; we pass it
to BODY as its first argument. The caller can make DATA point through to BODY as its first argument. The caller can make
to anything useful that BODY might need. BODY_DATA point to anything useful that BODY might need.
JMPBUF is the Scheme jmpbuf object corresponding to this catch, JMPBUF is the Scheme jmpbuf object corresponding to this catch,
which we have just created and initialized. which we have just created and initialized.
HANDLER is a pointer to a C function to deal with a throw to TAG, HANDLER is a pointer to a C function to deal with a throw to TAG,
should one occur. We call it like this: should one occur. We call it like this:
HANDLER (DATA, TAG, THROW_ARGS) HANDLER (HANDLER_DATA, TAG, THROW_ARGS)
where 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 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), it could be something else if TAG was #t (i.e., a catch-all),
or the user threw to a jmpbuf. or the user threw to a jmpbuf.
THROW_ARGS is the list of arguments the user passed to the THROW THROW_ARGS is the list of arguments the user passed to the THROW
function. function.
DATA is just a pointer we pass through to BODY and (if we call it) BODY_DATA is just a pointer we pass through to BODY.
HANDLER. We don't actually use it otherwise ourselves. The idea HANDLER_DATA is just a pointer we pass through to HANDLER.
is that, if our caller wants to communicate something to BODY and We don't actually use either of those pointers otherwise ourselves.
HANDLER, it can pass a pointer to it as DATA, which BODY and The idea is that, if our caller wants to communicate something to
HANDLER can then use. Think of it as a way to make BODY and BODY or HANDLER, it can pass a pointer to it as MUMBLE_DATA, which
HANDLER closures, not just functions; DATA points to the enclosed BODY and HANDLER can then use. Think of it as a way to make BODY
variables. */ and HANDLER closures, not just functions; MUMBLE_DATA points to the
enclosed variables. */
SCM SCM
scm_internal_catch (tag, body, handler, data) scm_internal_catch (tag, body, body_data, handler, handler_data)
SCM tag; SCM tag;
scm_catch_body_t body; scm_catch_body_t body;
void *body_data;
scm_catch_handler_t handler; scm_catch_handler_t handler;
void *data; void *handler_data;
{ {
struct jmp_buf_and_retval jbr; struct jmp_buf_and_retval jbr;
SCM jmpbuf; SCM jmpbuf;
@ -213,12 +216,12 @@ scm_internal_catch (tag, body, handler, data)
throw_tag = jbr.throw_tag; throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL; jbr.throw_tag = SCM_EOL;
jbr.retval = SCM_EOL; jbr.retval = SCM_EOL;
answer = handler (data, throw_tag, throw_args); answer = handler (handler_data, throw_tag, throw_args);
} }
else else
{ {
ACTIVATEJB (jmpbuf); ACTIVATEJB (jmpbuf);
answer = body (data, jmpbuf); answer = body (body_data, jmpbuf);
SCM_REDEFER_INTS; SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf); DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds); 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 /* This is a body function you can pass to scm_internal_catch if you
its body and handler routines, to tell them what to do. */ want the body to be like Scheme's `catch' --- a thunk, or a
struct catch_body_data function of one argument if the tag is #f.
{
/* 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. DATA contains the Scheme procedure to invoke. If the tag being
catch_body invokes this. */ caught is #f, then we pass JMPBUF to the body procedure; otherwise,
SCM body_proc; it gets no arguments. */
/* The Scheme procedure object we invoke to handle throws. */ SCM
SCM handler_proc; scm_body_thunk (body_data, jmpbuf)
}; void *body_data;
/* 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));
static SCM
catch_body (data, jmpbuf)
void *data;
SCM jmpbuf; 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) if (c->tag == SCM_BOOL_F)
return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL); 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 /* If the user does a throw to this catch, this function runs a
handler. DATA says which Scheme procedure object to invoke. */ handler procedure written in Scheme. HANDLER_DATA is a pointer to
static SCM catch_handler SCM_P ((void *, SCM, SCM)); an SCM variable holding the Scheme procedure object to invoke. It
ought to be a pointer to an automatic, or the procedure object
static SCM should be otherwise protected from GC. */
catch_handler (data, tag, throw_args) SCM
void *data; scm_handle_by_proc (handler_data, tag, throw_args)
void *handler_data;
SCM tag; SCM tag;
SCM throw_args; 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 thunk;
SCM handler; SCM handler;
{ {
struct catch_body_data c; struct scm_body_thunk_data c;
SCM_ASSERT ((tag == SCM_BOOL_F) SCM_ASSERT ((tag == SCM_BOOL_F)
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
@ -297,14 +286,15 @@ scm_catch (tag, thunk, handler)
c.tag = tag; c.tag = tag;
c.body_proc = thunk; c.body_proc = thunk;
c.handler_proc = handler;
/* scm_internal_catch takes care of all the mechanics of setting up /* 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 a catch tag; we tell it to call scm_body_thunk to run the body,
catch_handler to deal with any throws to this catch. Both those and scm_handle_by_proc to deal with any throws to this catch.
functions receive the pointer to c, which tells them the details The former receives a pointer to c, telling it how to behave.
of how to behave. */ The latter receives a pointer to HANDLER, so it knows who to call. */
return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c); 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); 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; 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 1) If the user wants something different, they can use (catch #t
...) to do what they like. ...) to do what they like.
2) Outside the context of a read-eval-print loop, there isn't 2) Outside the context of a read-eval-print loop, there isn't
anything else good to do; libguile should not assume the existence anything else good to do; libguile should not assume the existence
of a read-eval-print loop. of a read-eval-print loop.
3) Given that we shouldn't do anything complex, it's much more 3) Given that we shouldn't do anything complex, it's much more
robust to do it in C code. */ robust to do it in C code.
static SCM uncaught_throw SCM_P ((SCM key, SCM args));
static SCM HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
uncaught_throw (key, args) message header to print; if zero, we use "guile" instead. That
SCM key; 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; SCM args;
{ {
char *prog_name = (char *) handler_data;
SCM p = scm_def_errp; 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) if (scm_ilength (args) >= 3)
{ {
SCM message = SCM_CADR (args); SCM message = SCM_CADR (args);
SCM parts = SCM_CADDR (args); SCM parts = SCM_CADDR (args);
scm_gen_puts (scm_regular_string, "guile: ", p);
scm_display_error_message (message, parts, p); scm_display_error_message (message, parts, p);
} }
else else
{ {
scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); scm_gen_puts (scm_regular_string, "uncaught throw to ", p);
scm_prin1 (key, p, 0); scm_prin1 (tag, p, 0);
scm_gen_puts (scm_regular_string, ": ", p); scm_gen_puts (scm_regular_string, ": ", p);
scm_prin1 (args, p, 1); scm_prin1 (args, p, 1);
scm_gen_putc ('\n', p); 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) if (winds == SCM_EOL)
uncaught_throw (key, args); abort ();
if (SCM_IMP (winds) || SCM_NCONSP (winds)) if (SCM_IMP (winds) || SCM_NCONSP (winds))
abort (); abort ();

23
libguile/throw.h
View file

@ -54,8 +54,29 @@ typedef SCM (*scm_catch_handler_t) SCM_P ((void *data,
extern SCM scm_internal_catch SCM_P ((SCM tag, extern SCM scm_internal_catch SCM_P ((SCM tag,
scm_catch_body_t body, scm_catch_body_t body,
void *body_data,
scm_catch_handler_t handler, 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_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler));