summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJim Blandy <jimb@red-bean.com>1996-12-09 02:15:17 +0000
committerJim Blandy <jimb@red-bean.com>1996-12-09 02:15:17 +0000
commit650fa1abe5ebcbef3653f7267238ef3a9cc9847c (patch)
treeaa2d636901febdfa2fb2679a6890f289557cd144
parent10f74a138bc3bb3a7c473a97acf394d7d3c84eb9 (diff)
downloadguile-650fa1abe5ebcbef3653f7267238ef3a9cc9847c.tar.gz
Add new interface to catch/throw, usable from C as well as
Scheme. * throw.h (scm_catch_body_t, scm_catch_handler_t): New types. (scm_internal_catch): New function, replaces... (scm_catch_apply): Deleted. * throw.c (scm_catch_apply): Deleted; replaced with a more general mechanism which is a bit more code, but can be used nicely from C and implement the Scheme semantics as well. (scm_internal_catch): This is the replacement; it's named after the analogous function in Emacs. (scm_catch): Reimplemented in terms of the above. (struct catch_body_data, catch_body, catch_handler): New functions, used by scm_catch. * root.c (cwdr): Reimplemented in terms of scm_internal_catch. (struct cwdr_body_data, cwdr_body, cwdr_handler): New functions; support for new cwdr.
-rw-r--r--libguile/root.c76
-rw-r--r--libguile/throw.c129
-rw-r--r--libguile/throw.h10
3 files changed, 196 insertions, 19 deletions
diff --git a/libguile/root.c b/libguile/root.c
index 81310f684..b79e7b72b 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -158,19 +158,80 @@ scm_make_root (parent)
* the process is somehow exitted).
*/
+/* Some questions about cwdr:
+
+ Couldn't the body just be a closure? Do we really need to pass
+ args through to it?
+
+ The semantics are a lot like catch's; in fact, we call
+ scm_internal_catch to take care of that part of things. Wouldn't
+ it be cleaner to say that uncaught throws just disappear into the
+ ether (or print a message to stderr), and let the caller use catch
+ themselves if they want to?
+
+ -JimB */
+
#if 0
SCM scm_exitval; /* INUM with return value */
#endif
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.
+
+ A cwdr is a lot like a catch, except there is no tag (all
+ exceptions are caught), and the body procedure takes the arguments
+ 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 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. */
+static SCM cwdr_body SCM_P ((void *, SCM));
+
+static SCM
+cwdr_body (void *data, SCM jmpbuf)
+{
+ struct cwdr_body_data *c = (struct cwdr_body_data *) data;
+
+ return scm_apply (c->body_proc, c->a1, c->args);
+}
+
+
+/* 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.
*
* WARNING! The order of actions in this routine is in many ways
* critical. E. g., it is essential that an error doesn't leave Guile
- * in a messed up state.
- */
+ * in a messed up state. */
static SCM
cwdr (proc, a1, args, handler, stack_start)
@@ -215,7 +276,16 @@ cwdr (proc, a1, args, handler, stack_start)
#endif
/* Catch all errors. */
- answer = scm_catch_apply (SCM_BOOL_T, proc, a1, args, handler);
+ {
+ struct cwdr_body_data c;
+
+ 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);
+ }
scm_dowinds (old_winds, - scm_ilength (old_winds));
SCM_REDEFER_INTS;
diff --git a/libguile/throw.c b/libguile/throw.c
index 988531212..4bed62442 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -137,13 +137,53 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
SCM retval;
};
+
+/* scm_internal_catch is the guts of catch. It handles all the
+ mechanics of setting up a catch target, invoking the catch body,
+ and perhaps invoking the handler if the body does a throw.
+
+ The function is designed to be usable from C code, but is general
+ enough to implement all the semantics Guile Scheme expects from
+ throw.
+
+ TAG is the catch tag. Typically, this is a symbol, but this
+ function doesn't actually care about that.
+
+ 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)
+ 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.
+ 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)
+ where
+ DATA is the DATA argument we recevied, as for BODY 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. */
+
SCM
-scm_catch_apply (tag, proc, a1, args, handler)
+scm_internal_catch (tag, body, handler, data)
SCM tag;
- SCM proc;
- SCM a1;
- SCM args;
- SCM handler;
+ scm_catch_body_t body;
+ scm_catch_handler_t handler;
+ void *data;
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
@@ -172,19 +212,12 @@ scm_catch_apply (tag, proc, a1, args, handler)
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
jbr.retval = SCM_EOL;
- answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL);
+ answer = handler (data, throw_tag, throw_args);
}
else
{
ACTIVATEJB (jmpbuf);
- if (tag == SCM_BOOL_F)
- answer = scm_apply (proc,
- SCM_NULLP (a1)
- ? scm_cons (jmpbuf, SCM_EOL)
- : scm_cons2 (jmpbuf, a1, args),
- SCM_EOL);
- else
- answer = scm_apply (proc, a1, args);
+ answer = body (data, jmpbuf);
SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
@@ -193,6 +226,60 @@ scm_catch_apply (tag, proc, a1, args, handler)
return answer;
}
+
+/* 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 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;
+{
+ struct catch_body_data *c = (struct catch_body_data *) data;
+
+ if (c->tag == SCM_BOOL_F)
+ return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
+ else
+ return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+}
+
+
+/* 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;
+ SCM tag;
+ SCM throw_args;
+{
+ struct catch_body_data *c = (struct catch_body_data *) data;
+
+ return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL);
+}
+
+
SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
SCM
scm_catch (tag, thunk, handler)
@@ -200,11 +287,23 @@ scm_catch (tag, thunk, handler)
SCM thunk;
SCM handler;
{
+ struct catch_body_data c;
+
SCM_ASSERT ((tag == SCM_BOOL_F)
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|| (tag == SCM_BOOL_T),
tag, SCM_ARG1, s_catch);
- return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, 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);
}
SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
diff --git a/libguile/throw.h b/libguile/throw.h
index 3f41495bd..83d8e946d 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -48,7 +48,15 @@
-extern SCM scm_catch_apply SCM_P ((SCM tag, SCM proc, SCM a1, SCM args, SCM handler));
+typedef SCM (*scm_catch_body_t) SCM_P ((void *data, SCM jmpbuf));
+typedef SCM (*scm_catch_handler_t) SCM_P ((void *data,
+ SCM tag, SCM throw_args));
+
+extern SCM scm_internal_catch SCM_P ((SCM tag,
+ scm_catch_body_t body,
+ scm_catch_handler_t handler,
+ void *data));
+
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_ithrow SCM_P ((SCM key, SCM args, int noreturn));