* throw.h (scm_c_catch, scm_c_with_throw_handler,

scm_catch_with_pre_unwind_handler, scm_with_throw_handler): New.

* throw.c (SCM_JBPREUNWIND, SCM_SETJBPREUNWIND): New.
(struct pre_unwind_data): New, replaces struct lazy_catch.
(scm_c_catch): New, replaces scm_internal_catch as the primary
catch API for C code; adds pre-unwind handler support.
(scm_internal_catch): Now just a wrapper for scm_c_catch, for back
compatibility.
(tc16_pre_unwind_data, pre_unwind_data_print,
make_pre_unwind_data, SCM_PRE_UNWIND_DATA_P): Renamed from
"lazy_catch" equivalents.
(scm_c_with_throw_handler): New, replaces scm_internal_lazy_catch
as the primary C API for a "lazy" catch.
(scm_internal_lazy_catch): Now just a wrapper for
scm_c_with_throw_handler, for back compatibility.
(scm_catch_with_pre_unwind_handler): Renamed from scm_catch; adds
pre-unwind handler support.
(scm_catch): Now just a wrapper for
scm_catch_with_pre_unwind_handler, for back compatibility.
(scm_with_throw_handler): New.
(scm_lazy_catch): Update comment to say that the handler can
return, and what happens if it does.
(toggle_pre_unwind_running): New.
(scm_ithrow): When identifying the throw target, take running
flags into account.  In general, change naming of things from
"lazy_catch" to "pre_unwind".  When throwing to a throw handler,
don't unwind the dynamic context first.  Add dynwind framing to
manage the running flag of a throw handler.  If a lazy catch or
throw handler returns, rethrow the same exception again.  Add
pre-unwind support to the normal catch case (SCM_JMPBUFP).

* root.c (scm_internal_cwdr): Add NULL args to
scm_i_with_continuation_barrier call.

* dynwind.c: Change comment mentioning lazy-catch to mention
pre-unwind data and throw handler also.

* continuations.h (scm_i_with_continuation_barrier): Add
pre-unwind handler args.

* continuations.c (scm_i_with_continuation_barrier): Add
pre-unwind handler args, and pass on to scm_c_catch (changed from
scm_internal_catch).
(c_handler): Remove scm_handle_by_message_noexit call.
(scm_c_with_continuation_barrier): Call
scm_i_with_continuation_barrier with scm_handle_by_message_noexit
as the pre-unwind handler.
(scm_handler): Remove scm_handle_by_message_noexit call.
(s_scm_with_continuation_barrier): Call
scm_i_with_continuation_barrier with scm_handle_by_message_noexit
as the pre-unwind handler.

libguile/ChangeLog

@@ -1,3 +1,58 @@
+2006-02-04  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* throw.h (scm_c_catch, scm_c_with_throw_handler,
+	scm_catch_with_pre_unwind_handler, scm_with_throw_handler): New.
+
+	* throw.c (SCM_JBPREUNWIND, SCM_SETJBPREUNWIND): New.
+	(struct pre_unwind_data): New, replaces struct lazy_catch.
+	(scm_c_catch): New, replaces scm_internal_catch as the primary
+	catch API for C code; adds pre-unwind handler support.
+	(scm_internal_catch): Now just a wrapper for scm_c_catch, for back
+	compatibility.
+	(tc16_pre_unwind_data, pre_unwind_data_print,
+	make_pre_unwind_data, SCM_PRE_UNWIND_DATA_P): Renamed from
+	"lazy_catch" equivalents.
+	(scm_c_with_throw_handler): New, replaces scm_internal_lazy_catch
+	as the primary C API for a "lazy" catch.
+	(scm_internal_lazy_catch): Now just a wrapper for
+	scm_c_with_throw_handler, for back compatibility.
+	(scm_catch_with_pre_unwind_handler): Renamed from scm_catch; adds
+	pre-unwind handler support.
+	(scm_catch): Now just a wrapper for
+	scm_catch_with_pre_unwind_handler, for back compatibility.
+	(scm_with_throw_handler): New.
+	(scm_lazy_catch): Update comment to say that the handler can
+	return, and what happens if it does.
+	(toggle_pre_unwind_running): New.
+	(scm_ithrow): When identifying the throw target, take running
+	flags into account.  In general, change naming of things from
+	"lazy_catch" to "pre_unwind".  When throwing to a throw handler,
+	don't unwind the dynamic context first.  Add dynwind framing to
+	manage the running flag of a throw handler.  If a lazy catch or
+	throw handler returns, rethrow the same exception again.  Add
+	pre-unwind support to the normal catch case (SCM_JMPBUFP).
+
+	* root.c (scm_internal_cwdr): Add NULL args to
+	scm_i_with_continuation_barrier call.
+
+	* dynwind.c: Change comment mentioning lazy-catch to mention
+	pre-unwind data and throw handler also.
+
+	* continuations.h (scm_i_with_continuation_barrier): Add
+	pre-unwind handler args.
+
+	* continuations.c (scm_i_with_continuation_barrier): Add
+	pre-unwind handler args, and pass on to scm_c_catch (changed from
+	scm_internal_catch).
+	(c_handler): Remove scm_handle_by_message_noexit call.
+	(scm_c_with_continuation_barrier): Call
+	scm_i_with_continuation_barrier with scm_handle_by_message_noexit
+	as the pre-unwind handler.
+	(scm_handler): Remove scm_handle_by_message_noexit call.
+	(s_scm_with_continuation_barrier): Call
+	scm_i_with_continuation_barrier with scm_handle_by_message_noexit
+	as the pre-unwind handler.
+
 2006-02-03  Kevin Ryde  <user42@zip.com.au>
 
 	* list.c, list.h (scm_list): Restore this function for use from C.

libguile/continuations.c

@@ -312,7 +312,9 @@ SCM
 scm_i_with_continuation_barrier (scm_t_catch_body body,
 				 void *body_data,
 				 scm_t_catch_handler handler,
-				 void *handler_data)
+				 void *handler_data,
+				 scm_t_catch_handler pre_unwind_handler,
+				 void *pre_unwind_handler_data)
 {
   SCM_STACKITEM stack_item;
   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
@@ -333,9 +335,10 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
   /* Call FUNC inside a catch all.  This is now guaranteed to return
      directly and exactly once.
   */
-  result = scm_internal_catch (SCM_BOOL_T,
+  result = scm_c_catch (SCM_BOOL_T,
-			       body, body_data,
+			body, body_data,
-			       handler, handler_data);
+			handler, handler_data,
+			pre_unwind_handler, pre_unwind_handler_data);
 
   /* Return to old continuation root.
    */
@@ -364,7 +367,6 @@ static SCM
 c_handler (void *d, SCM tag, SCM args)
 {
   struct c_data *data = (struct c_data *)d;
-  scm_handle_by_message_noexit (NULL, tag, args);
   data->result = NULL;
   return SCM_UNSPECIFIED;
 }
@@ -376,7 +378,8 @@ scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
   c_data.func = func;
   c_data.data = data;
   scm_i_with_continuation_barrier (c_body, &c_data,
-				   c_handler, &c_data);
+				   c_handler, &c_data,
+				   scm_handle_by_message_noexit, NULL);
   return c_data.result;
 }
 
@@ -394,7 +397,6 @@ scm_body (void *d)
 static SCM
 scm_handler (void *d, SCM tag, SCM args)
 {
-  scm_handle_by_message_noexit (NULL, tag, args);
   return SCM_BOOL_F;
 }
 
@@ -415,7 +417,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
   struct scm_data scm_data;
   scm_data.proc = proc;
   return scm_i_with_continuation_barrier (scm_body, &scm_data,
-					  scm_handler, &scm_data);
+					  scm_handler, &scm_data,
+					  scm_handle_by_message_noexit, NULL);
 }
 #undef FUNC_NAME
 

libguile/continuations.h

@@ -95,7 +95,9 @@ SCM_API SCM scm_with_continuation_barrier (SCM proc);
 SCM_API SCM scm_i_with_continuation_barrier (scm_t_catch_body body,
 					     void *body_data,
 					     scm_t_catch_handler handler,
-					     void *handler_data);
+					     void *handler_data,
+					     scm_t_catch_handler pre_unwind_handler,
+					     void *pre_unwind_handler_data);
 
 SCM_API void scm_init_continuations (void);
 

libguile/dynwind.c

@@ -38,7 +38,7 @@
    #<winder>
    (enter-proc . leave-proc)     dynamic-wind
    (tag . jmpbuf)                catch
-   (tag . lazy-catch)            lazy-catch
+   (tag . pre-unwind-data)       throw-handler / lazy-catch
      tag is either a symbol or a boolean
 
 */

libguile/root.c

@@ -121,7 +121,8 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data,
 
   my_handler_data.run_handler = 0;
   answer = scm_i_with_continuation_barrier (body, body_data,
-					    cwdr_handler, &my_handler_data);
+					    cwdr_handler, &my_handler_data,
+					    NULL, NULL);
 
   scm_dynwind_end ();
 

libguile/throw.c

@@ -54,6 +54,8 @@ static scm_t_bits tc16_jmpbuffer;
 #define SETJBJMPBUF(x, v)        (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
 #define SCM_JBDFRAME(x)         ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
 #define SCM_SETJBDFRAME(x, v)    (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
+#define SCM_JBPREUNWIND(x)      ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
 
 static int
 jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
@@ -80,7 +82,7 @@ make_jmpbuf (void)
 }
 
 
-/* scm_internal_catch (the guts of catch) */
+/* scm_c_catch (the guts of catch) */
 
 struct jmp_buf_and_retval	/* use only on the stack, in scm_catch */
 {
@@ -89,10 +91,28 @@ struct jmp_buf_and_retval	/* use only on the stack, in scm_catch */
   SCM retval;
 };
 
+/* These are the structures we use to store pre-unwind handling (aka
+   "lazy") information for a regular catch, and put on the wind list
+   for a "lazy" catch.  They store the pre-unwind handler function to
+   call, and the data pointer to pass through to it.  It's not a
+   Scheme closure, but it is a function with data, so the term
+   "closure" is appropriate in its broader sense.
 
-/* scm_internal_catch is the guts of catch.  It handles all the
+   (We don't need anything like this to run the normal (post-unwind)
-   mechanics of setting up a catch target, invoking the catch body,
+   catch handler, because the same C frame runs both the body and the
-   and perhaps invoking the handler if the body does a throw.
+   handler.)  */
+
+struct pre_unwind_data {
+  scm_t_catch_handler handler;
+  void *handler_data;
+  int running;
+  int lazy_catch_p;
+};
+
+
+/* scm_c_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
@@ -138,17 +158,28 @@ struct jmp_buf_and_retval	/* use only on the stack, in scm_catch */
    will be found.  */
 
 SCM
-scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+scm_c_catch (SCM tag,
+	     scm_t_catch_body body, void *body_data,
+	     scm_t_catch_handler handler, void *handler_data,
+	     scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
 {
   struct jmp_buf_and_retval jbr;
   SCM jmpbuf;
   SCM answer;
+  struct pre_unwind_data pre_unwind;
 
   jmpbuf = make_jmpbuf ();
   answer = SCM_EOL;
   scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
   SETJBJMPBUF(jmpbuf, &jbr.buf);
   SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
+
+  pre_unwind.handler = pre_unwind_handler;
+  pre_unwind.handler_data = pre_unwind_handler_data;
+  pre_unwind.running = 0;
+  pre_unwind.lazy_catch_p = 0;
+  SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
+
   if (setjmp (jbr.buf))
     {
       SCM throw_tag;
@@ -179,37 +210,33 @@ scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch
   return answer;
 }
 
+SCM
+scm_internal_catch (SCM tag,
+		    scm_t_catch_body body, void *body_data,
+		    scm_t_catch_handler handler, void *handler_data)
+{
+  return scm_c_catch(tag,
+		     body, body_data,
+		     handler, handler_data,
+		     NULL, NULL);
+}
+
 
 
-/* scm_internal_lazy_catch (the guts of lazy catching) */
+/* The smob tag for pre_unwind_data smobs.  */
-
+static scm_t_bits tc16_pre_unwind_data;
-/* The smob tag for lazy_catch smobs.  */
-static scm_t_bits tc16_lazy_catch;
-
-/* This is the structure we put on the wind list for a lazy catch.  It
-   stores the handler function to call, and the data pointer to pass
-   through to it.  It's not a Scheme closure, but it is a function
-   with data, so the term "closure" is appropriate in its broader
-   sense.
-
-   (We don't need anything like this in the "eager" catch code,
-   because the same C frame runs both the body and the handler.)  */
-struct lazy_catch {
-  scm_t_catch_handler handler;
-  void *handler_data;
-};
 
 /* Strictly speaking, we could just pass a zero for our print
    function, because we don't need to print them.  They should never
    appear in normal data structures, only in the wind list.  However,
    it might be nice for debugging someday... */
 static int
-lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
+pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
-  struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
+  struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
   char buf[200];
 
-  sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
+  sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
 	   (long) c->handler, (long) c->handler_data);
   scm_puts (buf, port);
 
@@ -217,33 +244,36 @@ lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
 }
 
 
-/* Given a pointer to a lazy catch structure, return a smob for it,
+/* Given a pointer to a pre_unwind_data structure, return a smob for it,
    suitable for inclusion in the wind list.  ("Ah yes, a Château
    Gollombiere '72, non?").  */
 static SCM
-make_lazy_catch (struct lazy_catch *c)
+make_pre_unwind_data (struct pre_unwind_data *c)
 {
-  SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
+  SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
 }
 
-#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
+#define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
 
-
-/* Exactly like scm_internal_catch, except:
-   - It does not unwind the stack (this is the major difference).
-   - The handler is not allowed to return.  */
 SCM
-scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+scm_c_with_throw_handler (SCM tag,
+			  scm_t_catch_body body,
+			  void *body_data,
+			  scm_t_catch_handler handler,
+			  void *handler_data,
+			  int lazy_catch_p)
 {
-  SCM lazy_catch, answer;
+  SCM pre_unwind, answer;
-  struct lazy_catch c;
+  struct pre_unwind_data c;
 
   c.handler = handler;
   c.handler_data = handler_data;
-  lazy_catch = make_lazy_catch (&c);
+  c.running = 0;
+  c.lazy_catch_p = lazy_catch_p;
+  pre_unwind = make_pre_unwind_data (&c);
 
   SCM_CRITICAL_SECTION_START;
-  scm_i_set_dynwinds (scm_acons (tag, lazy_catch, scm_i_dynwinds ()));
+  scm_i_set_dynwinds (scm_acons (tag, pre_unwind, scm_i_dynwinds ()));
   SCM_CRITICAL_SECTION_END;
 
   answer = (*body) (body_data);
@@ -255,6 +285,15 @@ scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_
   return answer;
 }
 
+/* Exactly like scm_internal_catch, except:
+   - It does not unwind the stack (this is the major difference).
+   - The handler is not allowed to return.  */
+SCM
+scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+{
+  return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 1);
+}
+
 
 /* scm_internal_stack_catch
    Use this one if you want debugging information to be stored in
@@ -488,10 +527,10 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
 
 
 
-/* the Scheme-visible CATCH and LAZY-CATCH functions */
+/* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
 
-SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
+SCM_DEFINE (scm_catch_with_pre_unwind_handler, "catch", 3, 1, 0,
-	    (SCM key, SCM thunk, SCM handler),
+	    (SCM key, SCM thunk, SCM handler, SCM pre_unwind_handler),
 	    "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
 	    "exceptions matching @var{key}.  If thunk throws to the symbol\n"
 	    "@var{key}, then @var{handler} is invoked this way:\n"
@@ -509,8 +548,23 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
 	    "from further up the call chain is invoked.\n"
 	    "\n"
 	    "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
-	    "match this call to @code{catch}.")
+	    "match this call to @code{catch}.\n"
-#define FUNC_NAME s_scm_catch
+	    "\n"
+	    "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
+	    "an exception that matches @var{key}, Guile calls the\n"
+	    "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
+	    "invoking the main @var{handler}.  @var{pre-unwind-handler} should\n"
+	    "be a procedure with the same signature as @var{handler}, that\n"
+	    "is @code{(lambda (key . args))}.  It is typically used to save\n"
+	    "the stack at the point where the exception occurred, but can also\n"
+	    "query other parts of the dynamic state at that point, such as\n"
+	    "fluid values.\n"
+	    "\n"
+	    "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
+	    "If it exits normally, Guile unwinds the stack and dynamic context\n"
+	    "and then calls the normal (third argument) handler.  If it exits\n"
+	    "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_catch_with_pre_unwind_handler
 {
   struct scm_body_thunk_data c;
 
@@ -520,24 +574,65 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
   c.tag = key;
   c.body_proc = thunk;
 
-  /* scm_internal_catch takes care of all the mechanics of setting up
+  /* scm_c_catch takes care of all the mechanics of setting up a catch
-     a catch key; we tell it to call scm_body_thunk to run the body,
+     key; we tell it to call scm_body_thunk to run the body, and
-     and scm_handle_by_proc to deal with any throws to this catch.
+     scm_handle_by_proc to deal with any throws to this catch.  The
-     The former receives a pointer to c, telling it how to behave.
+     former receives a pointer to c, telling it how to behave.  The
-     The latter receives a pointer to HANDLER, so it knows who to call.  */
+     latter receives a pointer to HANDLER, so it knows who to
-  return scm_internal_catch (key,
+     call.  */
-			     scm_body_thunk, &c, 
+  return scm_c_catch (key,
-			     scm_handle_by_proc, &handler);
+		      scm_body_thunk, &c, 
+		      scm_handle_by_proc, &handler,
+		      SCM_UNBNDP (pre_unwind_handler) ? NULL : scm_handle_by_proc,
+		      &pre_unwind_handler);
 }
 #undef FUNC_NAME
 
+/* The following function exists to provide backwards compatibility
+   for the C scm_catch API.  Otherwise we could just change
+   "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+  return scm_catch_with_pre_unwind_handler (key, thunk, handler, SCM_UNDEFINED);
+}
+
+
+SCM_DEFINE (scm_with_throw_handler, "with-throw-handler", 3, 0, 0,
+	    (SCM key, SCM thunk, SCM handler),
+	    "Add @var{handler} to the dynamic context as a throw handler\n"
+	    "for key @var{key}, then invoke @var{thunk}.")
+#define FUNC_NAME s_scm_with_throw_handler
+{
+  struct scm_body_thunk_data c;
+
+  SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+	      key, SCM_ARG1, FUNC_NAME);
+
+  c.tag = key;
+  c.body_proc = thunk;
+
+  /* scm_c_with_throw_handler takes care of the mechanics of setting
+     up a throw handler; we tell it to call scm_body_thunk to run the
+     body, and scm_handle_by_proc to deal with any throws to this
+     handler.  The former receives a pointer to c, telling it how to
+     behave.  The latter receives a pointer to HANDLER, so it knows
+     who to call.  */
+  return scm_c_with_throw_handler (key,
+				   scm_body_thunk, &c, 
+				   scm_handle_by_proc, &handler,
+				   0);
+}
+#undef FUNC_NAME
 
 SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
 	    (SCM key, SCM thunk, SCM handler),
 	    "This behaves exactly like @code{catch}, except that it does\n"
 	    "not unwind the stack before invoking @var{handler}.\n"
-	    "The @var{handler} procedure is not allowed to return:\n"
+	    "If the @var{handler} procedure returns normally, Guile\n"
-	    "it must throw to another catch, or otherwise exit non-locally.")
+	    "rethrows the same exception again to the next innermost catch,\n"
+	    "lazy-catch or throw handler.  If the @var{handler} exits\n"
+	    "non-locally, that exit determines the continuation.")
 #define FUNC_NAME s_scm_lazy_catch
 {
   struct scm_body_thunk_data c;
@@ -564,6 +659,12 @@ SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
 
 /* throwing */
 
+static void toggle_pre_unwind_running (void *data)
+{
+  struct pre_unwind_data *pre_unwind = (struct pre_unwind_data *)data;
+  pre_unwind->running = !pre_unwind->running;
+}
+
 SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
            (SCM key, SCM args),
 	    "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
@@ -593,6 +694,8 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
       abort ();
     }
 
+ rethrow:
+
   /* Search the wind list for an appropriate catch.
      "Waiter, please bring us the wind list." */
   for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
@@ -603,7 +706,19 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
 	  SCM this_key = SCM_CAR (dynpair);
 
 	  if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
-	    break;
+	    {
+	      jmpbuf = SCM_CDR (dynpair);
+
+	      if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
+		break;
+	      else
+		{
+		  struct pre_unwind_data *c =
+		    (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+		  if (!c->running)
+		    break;
+		}
+	    }
 	}
     }
 
@@ -619,34 +734,82 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
   /* If the wind list is malformed, bail.  */
   if (!scm_is_pair (winds))
     abort ();
-      
-  jmpbuf = SCM_CDR (dynpair);
   
   for (wind_goal = scm_i_dynwinds ();
        !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf);
        wind_goal = SCM_CDR (wind_goal))
     ;
 
-  /* Is a lazy catch?  In wind list entries for lazy catches, the key
+  /* Is this a throw handler (or lazy catch)?  In a wind list entry
-     is bound to a lazy_catch smob, not a jmpbuf.  */
+     for a throw handler or lazy catch, the key is bound to a
-  if (SCM_LAZY_CATCH_P (jmpbuf))
+     pre_unwind_data smob, not a jmpbuf.  */
+  if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
     {
-      struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
+      struct pre_unwind_data *c =
+	(struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
       SCM handle, answer;
-      scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
+
-			       - scm_ilength (wind_goal)));
+      /* For old-style lazy-catch behaviour, we unwind the dynamic
-      SCM_CRITICAL_SECTION_START;
+	 context before invoking the handler. */
-      handle = scm_i_dynwinds ();
+      if (c->lazy_catch_p)
-      scm_i_set_dynwinds (SCM_CDR (handle));
+	{
-      SCM_CRITICAL_SECTION_END;
+	  scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
+				   - scm_ilength (wind_goal)));
+	  SCM_CRITICAL_SECTION_START;
+	  handle = scm_i_dynwinds ();
+	  scm_i_set_dynwinds (SCM_CDR (handle));
+	  SCM_CRITICAL_SECTION_END;
+	}
+
+      /* Call the handler, with framing to set the pre-unwind
+	 structure's running field while the handler is running, so we
+	 can avoid recursing into the same handler again.  Note that
+	 if the handler returns normally, the running flag stays
+	 set until some kind of non-local jump occurs. */
+      scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+      scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+				  c,
+				  SCM_F_WIND_EXPLICITLY);
+      scm_dynwind_unwind_handler (toggle_pre_unwind_running, c, 0);
       answer = (c->handler) (c->handler_data, key, args);
-      scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL);
+
+      /* There is deliberately no scm_dynwind_end call here.  This
+	 means that the unwind handler (toggle_pre_unwind_running)
+	 stays in place until a non-local exit occurs, and will then
+	 reset the pre-unwind structure's running flag.  For sample
+	 code where this makes a difference, see the "again but with
+	 two chained throw handlers" test case in exceptions.test.  */
+
+      /* If the handler returns, rethrow the same key and args. */
+      goto rethrow;
     }
 
   /* Otherwise, it's a normal catch.  */
   else if (SCM_JMPBUFP (jmpbuf))
     {
+      struct pre_unwind_data * pre_unwind;
       struct jmp_buf_and_retval * jbr;
+
+      /* Before unwinding anything, run the pre-unwind handler if
+	 there is one, and if it isn't already running. */
+      pre_unwind = SCM_JBPREUNWIND (jmpbuf);
+      if (pre_unwind->handler && !pre_unwind->running)
+	{
+	  /* Use framing to detect and avoid possible reentry into
+	     this handler, which could otherwise cause an infinite
+	     loop. */
+	  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+	  scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+				      pre_unwind,
+				      SCM_F_WIND_EXPLICITLY);
+	  scm_dynwind_unwind_handler (toggle_pre_unwind_running,
+				      pre_unwind,
+				      SCM_F_WIND_EXPLICITLY);
+	  (pre_unwind->handler) (pre_unwind->handler_data, key, args);
+	  scm_dynwind_end ();
+	}
+
+      /* Now unwind and jump. */
       scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
 			       - scm_ilength (wind_goal)));
       jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
@@ -668,8 +831,8 @@ scm_init_throw ()
   tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
   scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
 
-  tc16_lazy_catch = scm_make_smob_type ("lazy-catch", 0);
+  tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
-  scm_set_smob_print (tc16_lazy_catch, lazy_catch_print);
+  scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
 
 #include "libguile/throw.x"
 }

libguile/throw.h

@@ -30,6 +30,21 @@ typedef SCM (*scm_t_catch_body) (void *data);
 typedef SCM (*scm_t_catch_handler) (void *data,
                                     SCM tag, SCM throw_args);
 
+SCM_API SCM scm_c_catch (SCM tag,
+			 scm_t_catch_body body,
+			 void *body_data,
+			 scm_t_catch_handler handler,
+			 void *handler_data,
+			 scm_t_catch_handler pre_unwind_handler,
+			 void *pre_unwind_handler_data);
+
+SCM_API SCM scm_c_with_throw_handler (SCM tag,
+				      scm_t_catch_body body,
+				      void *body_data,
+				      scm_t_catch_handler handler,
+				      void *handler_data,
+				      int lazy_catch_p);
+
 SCM_API SCM scm_internal_catch (SCM tag,
 				scm_t_catch_body body,
 				void *body_data,
@@ -72,7 +87,9 @@ SCM_API SCM scm_handle_by_message_noexit (void *, SCM, SCM);
 SCM_API SCM scm_handle_by_throw (void *, SCM, SCM);
 SCM_API int scm_exit_status (SCM args);
 
+SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM handler, SCM lazy_handler);
 SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
+SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);