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.

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;

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_catch_body_t body;
-     SCM a1;
+     scm_catch_handler_t handler;
-     SCM args;
+     void *data;
-     SCM handler;
 {
   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 = body (data, jmpbuf);
-	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);
       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);

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