Re: Backtrace and enhanced catch

[Neil Jerram]

Neil Jerram <address@hidden> writes:

> We can solve both problems by merging the semantics of catch and
> lazy-catch into a single form, an enhanced catch:
>
>  -- Scheme Procedure: catch key thunk handler [lazy-handler]

The main part of this patch is appended below, and I would appreciate
any comments that anyone may have before I finish it off (by
deprecating the old APIs, replacing uses of lazy-catch, and so on).

One point is that I have removed the "SCM_API" from the declaration of
scm_i_with_continuation_barrier.  My understanding is that
scm_i_with_continuation_barrier (like scm_i_* functions in general) is
a libguile-internal function and so does not need to be exported from
the libguile DLL in a Windows build (which is what SCM_API is for).

With this patch, I get the following results running g.scm with and
without --debug ...

address@hidden:~$ guile-local --debug g.scm
Backtrace:
In unknown file:
   ?: 0* [primitive-load "g.scm"]
In g.scm:
   8: 1* [g #<procedure f (x)>]
   6: 2  [f]

g.scm:6:3: In procedure f in expression (x):
g.scm:6:3: Wrong number of arguments to #<procedure f (x)>
address@hidden:~$ guile-local g.scm
ERROR: Wrong number of arguments to #<procedure f (x)>
address@hidden:~$ 

... which I believe is what is wanted.

Regards,
        Neil

cvs diff: Diffing libguile
Index: libguile/continuations.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/continuations.c,v
retrieving revision 1.60
diff -u -u -r1.60 continuations.c
--- libguile/continuations.c    23 May 2005 19:57:20 -0000      1.60
+++ libguile/continuations.c    14 Jan 2006 12:43:30 -0000
@@ -312,7 +312,9 @@
 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 lazy_handler,
+                                void *lazy_handler_data)
 {
   SCM_STACKITEM stack_item;
   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
@@ -333,9 +335,10 @@
   /* Call FUNC inside a catch all.  This is now guaranteed to return
      directly and exactly once.
   */
-  result = scm_internal_catch (SCM_BOOL_T,
-                              body, body_data,
-                              handler, handler_data);
+  result = scm_c_catch (SCM_BOOL_T,
+                       body, body_data,
+                       handler, handler_data,
+                       lazy_handler, lazy_handler_data);
 
   /* Return to old continuation root.
    */
@@ -364,7 +367,6 @@
 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 @@
   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 @@
 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 @@
   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
 
Index: libguile/continuations.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/continuations.h,v
retrieving revision 1.34
diff -u -u -r1.34 continuations.h
--- libguile/continuations.h    23 May 2005 19:57:20 -0000      1.34
+++ libguile/continuations.h    14 Jan 2006 12:43:30 -0000
@@ -92,10 +92,12 @@
 SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
 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);
+SCM scm_i_with_continuation_barrier (scm_t_catch_body body,
+                                    void *body_data,
+                                    scm_t_catch_handler handler,
+                                    void *handler_data,
+                                    scm_t_catch_handler lazy_handler,
+                                    void *lazy_handler_data);
 
 SCM_API void scm_init_continuations (void);
 
Index: libguile/root.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/root.c,v
retrieving revision 1.78
diff -u -u -r1.78 root.c
--- libguile/root.c     23 May 2005 19:57:21 -0000      1.78
+++ libguile/root.c     14 Jan 2006 12:43:31 -0000
@@ -121,7 +121,8 @@
 
   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_frame_end ();
 
Index: libguile/throw.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/throw.c,v
retrieving revision 1.107
diff -u -u -r1.107 throw.c
--- libguile/throw.c    23 May 2005 19:57:21 -0000      1.107
+++ libguile/throw.c    14 Jan 2006 12:43:32 -0000
@@ -54,6 +54,8 @@
 #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_JBLAZY(x)           ((struct lazy_catch *) SCM_CELL_WORD_3 (x))
+#define SCM_SETJBLAZY(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 @@
 }
 
 
-/* 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,25 @@
   SCM retval;
 };
 
+/* This is the structure we use to store lazy handling information for
+   a regular catch, and put on the wind list for a lazy catch.  It
+   stores the lazy 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 to run the "eager" catch handler,
+   because the same C frame runs both the body and the handler.)  */
+
+struct lazy_catch {
+  scm_t_catch_handler handler;
+  void *handler_data;
+};
 
-/* 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.
+
+/* 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 +155,26 @@
    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 lazy_handler, void *lazy_handler_data)
 {
   struct jmp_buf_and_retval jbr;
   SCM jmpbuf;
   SCM answer;
+  struct lazy_catch lazy;
 
   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 ());
+
+  lazy.handler = lazy_handler;
+  lazy.handler_data = lazy_handler_data;
+  SCM_SETJBLAZY(jmpbuf, &lazy);
+
   if (setjmp (jbr.buf))
     {
       SCM throw_tag;
@@ -179,6 +205,17 @@
   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) */
@@ -186,19 +223,6 @@
 /* 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,
@@ -490,8 +514,8 @@
 
 /* the Scheme-visible CATCH and LAZY-CATCH functions */
 
-SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
-           (SCM key, SCM thunk, SCM handler),
+SCM_DEFINE (scm_catch_with_lazy_handler, "catch", 3, 1, 0,
+           (SCM key, SCM thunk, SCM handler, SCM lazy_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 +533,19 @@
            "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}.")
-#define FUNC_NAME s_scm_catch
+           "match this call to @code{catch}.\n"
+           "\n"
+           "If a @var{lazy-handler} is given and @var{thunk} throws an\n"
+           "exception that matches @var{key}, Guile calls the\n"
+           "@var{lazy-handler} before unwinding the dynamic state and\n"
+           "invoking the main @var{handler}.  @var{lazy-handler} should\n"
+           "be a procedure with the same signature as @var{handler}, that\n"
+           "is @code{(lambda (key . args))}, and should return normally, in\n"
+           "other words not call @code{throw} or a continuation.  It is\n"
+           "typically used to save the stack at the point where the\n"
+           "exception occurred, but can also query other parts of the\n"
+           "dynamic state at that point, such as fluid values.")
+#define FUNC_NAME s_scm_catch_with_lazy_handler
 {
   struct scm_body_thunk_data c;
 
@@ -520,17 +555,29 @@
   c.tag = key;
   c.body_proc = thunk;
 
-  /* scm_internal_catch takes care of all the mechanics of setting up
-     a catch key; we tell it to call scm_body_thunk to run the body,
-     and scm_handle_by_proc to deal with any throws to this catch.
-     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_internal_catch (key,
-                            scm_body_thunk, &c, 
-                            scm_handle_by_proc, &handler);
+  /* scm_c_catch takes care of all the mechanics of setting up a catch
+     key; we tell it to call scm_body_thunk to run the body, and
+     scm_handle_by_proc to deal with any throws to this catch.  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_catch (key,
+                     scm_body_thunk, &c, 
+                     scm_handle_by_proc, &handler,
+                     SCM_UNBNDP (lazy_handler) ? NULL : scm_handle_by_proc,
+                     &lazy_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_lazy_handler" above to "scm_catch". */
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+  return scm_catch_with_lazy_handler (key, thunk, handler, SCM_UNDEFINED);
+}
+
 
 SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
            (SCM key, SCM thunk, SCM handler),
@@ -646,7 +693,16 @@
   /* Otherwise, it's a normal catch.  */
   else if (SCM_JMPBUFP (jmpbuf))
     {
+      struct lazy_catch * lazy;
       struct jmp_buf_and_retval * jbr;
+
+      /* Before unwinding anything, run the lazy handler if there is
+        one. */
+      lazy = SCM_JBLAZY (jmpbuf);
+      if (lazy->handler)
+       (lazy->handler) (lazy->handler_data, key, args);
+
+      /* 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);
Index: libguile/throw.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/throw.h,v
retrieving revision 1.26
diff -u -u -r1.26 throw.h
--- libguile/throw.h    23 May 2005 19:57:21 -0000      1.26
+++ libguile/throw.h    14 Jan 2006 12:43:32 -0000
@@ -30,6 +30,14 @@
 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 lazy_handler,
+                        void *lazy_handler_data);
+
 SCM_API SCM scm_internal_catch (SCM tag,
                                scm_t_catch_body body,
                                void *body_data,
@@ -72,6 +80,7 @@
 SCM_API SCM scm_handle_by_throw (void *, SCM, SCM);
 SCM_API int scm_exit_status (SCM args);
 
+SCM_API SCM scm_catch_with_lazy_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_lazy_catch (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);
cvs diff: Diffing libguile-ltdl
cvs diff: Diffing libguile-ltdl/upstream
cvs diff: Diffing libltdl
cvs diff: Diffing oop
cvs diff: Diffing oop/goops
cvs diff: Diffing qt
cvs diff: Diffing qt/md
cvs diff: Diffing qt/time
cvs diff: Diffing scripts
cvs diff: Diffing srfi
cvs diff: Diffing test-suite
cvs diff: Diffing test-suite/standalone
cvs diff: Diffing test-suite/tests
Index: test-suite/tests/exceptions.test
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/tests/exceptions.test,v
retrieving revision 1.11
diff -u -u -r1.11 exceptions.test
--- test-suite/tests/exceptions.test    23 May 2005 19:57:22 -0000      1.11
+++ test-suite/tests/exceptions.test    14 Jan 2006 12:43:32 -0000
@@ -60,7 +60,25 @@
       exception:wrong-num-args
       (catch 'a
        (lambda () (throw 'a))
-       (lambda (x y . rest) #f)))))
+       (lambda (x y . rest) #f))))
+
+  (with-test-prefix "with lazy handler"
+
+    (pass-if "lazy fluid state"
+      (equal? '(inner outer arg)
+       (let ((fluid-parm (make-fluid))
+            (inner-val #f))
+        (fluid-set! fluid-parm 'outer)
+        (catch 'misc-exc
+          (lambda ()
+            (with-fluids ((fluid-parm 'inner))
+              (throw 'misc-exc 'arg)))
+          (lambda (key . args)
+            (list inner-val
+                  (fluid-ref fluid-parm)
+                  (car args)))
+          (lambda (key . args)
+            (set! inner-val (fluid-ref fluid-parm)))))))))
 
 (with-test-prefix "false-if-exception"