Re: `trace' is broken

[Neil Jerram]

>>>>> "Neil" == Neil Jerram <address@hidden> writes:

>>>>> "Martin" == Martin Grabmueller <address@hidden> writes:
    Martin> Hello list, I was just trying out an example from the GRM,
    Martin> node `Trace' ...

    Martin> It would be really nice if we could get that working again
    Martin> before 1.6.

    Neil> Can you try the patch below?  It works for me with your
    Neil> `rev' example, but perhaps there are more difficult tests
    Neil> that you can give it.

Did anyone have any thoughts on this patch?  Should I commit it - I
guess it can't really be worse than the current situation, which is
that the design of traps is broken by the recent change not to allow
lazy-catch to return.  (Hmm... but what if we use lazy-catch plus
calling the continuation provided...?)

        Neil

(Patch updated for current CVS ...)

Index: ice-9/boot-9.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/boot-9.scm,v
retrieving revision 1.264
diff -u -r1.264 boot-9.scm
--- ice-9/boot-9.scm    2001/06/25 01:06:33     1.264
+++ ice-9/boot-9.scm    2001/06/25 22:28:35
@@ -2237,20 +2237,8 @@
   (save-stack lazy-handler-dispatch)
   (apply throw key args))
 
-(define enter-frame-handler default-lazy-handler)
-(define apply-frame-handler default-lazy-handler)
-(define exit-frame-handler default-lazy-handler)
-
 (define (lazy-handler-dispatch key . args)
-  (case key
-    ((apply-frame)
-     (apply apply-frame-handler key args))
-    ((exit-frame)
-     (apply exit-frame-handler key args))
-    ((enter-frame)
-     (apply enter-frame-handler key args))
-    (else
-     (apply default-lazy-handler key args))))
+  (apply default-lazy-handler key args))
 
 (define abort-hook (make-hook))
 
Index: ice-9/debug.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/debug.scm,v
retrieving revision 1.21
diff -u -r1.21 debug.scm
--- ice-9/debug.scm     2001/06/03 23:29:45     1.21
+++ ice-9/debug.scm     2001/06/25 22:28:35
@@ -78,9 +78,12 @@
                        (set! traced-procedures
                              (cons proc traced-procedures))))
                  args)
-       (set! apply-frame-handler trace-entry)
-       (set! exit-frame-handler trace-exit)
-       (set! trace-level 0)
+       (trap-set! apply-frame-handler trace-entry)
+       (trap-set! exit-frame-handler trace-exit)
+       ;; We used to reset `trace-level' here to 0, but this is wrong
+       ;; if `trace' itself is being traced, since `trace-exit' will
+       ;; then decrement `trace-level' to -1!  It shouldn't actually
+       ;; be necessary to set `trace-level' here at all.
        (debug-enable 'trace)
        (nameify args))))
 
Index: libguile/debug.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/debug.h,v
retrieving revision 1.40
diff -u -r1.40 debug.h
--- libguile/debug.h    2001/06/25 11:06:33     1.40
+++ libguile/debug.h    2001/06/25 22:28:39
@@ -98,13 +98,15 @@
 
 #define SCM_RESET_DEBUG_MODE \
 do {\
-  CHECK_ENTRY = SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P;\
-  CHECK_APPLY = SCM_APPLY_FRAME_P || SCM_TRACE_P;\
-  CHECK_EXIT = SCM_EXIT_FRAME_P || SCM_TRACE_P;\
+  CHECK_ENTRY = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\
+    && SCM_NFALSEP (SCM_ENTER_FRAME_HDLR);\
+  CHECK_APPLY = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\
+    && SCM_NFALSEP (SCM_APPLY_FRAME_HDLR);\
+  CHECK_EXIT = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
+    && SCM_NFALSEP (SCM_EXIT_FRAME_HDLR);\
   scm_debug_mode = SCM_DEVAL_P || CHECK_ENTRY || CHECK_APPLY || CHECK_EXIT;\
   scm_ceval_ptr = scm_debug_mode ? scm_deval : scm_ceval;\
 } while (0)
-
 
 /* {Evaluator}
  */
Index: libguile/eval.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/eval.c,v
retrieving revision 1.231
diff -u -r1.231 eval.c
--- libguile/eval.c     2001/06/25 03:30:02     1.231
+++ libguile/eval.c     2001/06/25 22:29:15
@@ -1620,18 +1620,26 @@
       {\
        SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
        SCM_SET_TRACED_FRAME (debug); \
+       SCM_TRAPS_P = 0;\
        if (SCM_CHEAPTRAPS_P)\
          {\
            tmp = scm_make_debugobj (&debug);\
-           scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 
0);\
+           scm_apply (SCM_APPLY_FRAME_HDLR,\
+                      scm_cons (scm_sym_apply_frame,\
+                                scm_cons2 (tmp, tail, SCM_EOL)),\
+                      SCM_EOL);\
          }\
        else\
          {\
             int first;\
            tmp = scm_make_continuation (&first);\
            if (first)\
-             scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 
0);\
+             scm_apply (SCM_APPLY_FRAME_HDLR,\
+                         scm_cons (scm_sym_apply_frame,\
+                                   scm_cons2 (tmp, tail, SCM_EOL)),\
+                         SCM_EOL);\
          }\
+       SCM_TRAPS_P = 1;\
       }\
 } while (0)
 #undef RETURN
@@ -1695,14 +1703,17 @@
   { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
   { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
   { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 
0 = no check)." },
-  { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T, "Show file names and line 
numbers in backtraces when not `#f'.  A value of `base' displays only base 
names, while `#t' displays full names."}
+  { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file 
names and line numbers in backtraces when not `#f'.  A value of `base' displays 
only base names, while `#t' displays full names."}
 };
 
 scm_t_option scm_evaluator_trap_table[] = {
   { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
   { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
   { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
-  { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
+  { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
+  { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler 
for enter-frame traps." },
+  { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler 
for apply-frame traps." },
+  { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler 
for exit-frame traps." }
 };
 
 SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, 
@@ -1914,10 +1925,14 @@
                  goto dispatch;
              }
          }
-       scm_ithrow (scm_sym_enter_frame,
-                   scm_cons2 (t.arg1, tail,
-                              scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
-                   0);
+       SCM_TRAPS_P = 0;
+       scm_apply (SCM_ENTER_FRAME_HDLR,
+                  scm_cons (scm_sym_enter_frame,
+                            scm_cons2 (t.arg1, tail,
+                                       scm_cons (scm_unmemocopy (x, env),
+                                                 SCM_EOL))),
+                  SCM_EOL);
+       SCM_TRAPS_P = 1;
       }
 #endif
 #if defined (USE_THREADS) || defined (DEVAL)
@@ -3231,7 +3246,12 @@
                goto ret;
              }
          }
-       scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
+       SCM_TRAPS_P = 0;
+       scm_apply (SCM_EXIT_FRAME_HDLR,
+                  scm_cons (scm_sym_exit_frame,
+                            scm_cons2 (t.arg1, proc, SCM_EOL)),
+                  SCM_EOL);
+       SCM_TRAPS_P = 1;
       }
 ret:
   scm_last_debug_frame = debug.prev;
@@ -3390,7 +3410,10 @@
          if (!first)
            goto entap;
        }
-      scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+      SCM_TRAPS_P = 0;
+      scm_apply (SCM_ENTER_FRAME_HDLR,
+                scm_cons2 (scm_sym_enter_frame, tmp, SCM_EOL), SCM_EOL);
+      SCM_TRAPS_P = 1;
     }
 entap:
   ENTER_APPLY;
@@ -3620,7 +3643,12 @@
                goto ret;
              }
          }
-       scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
+       SCM_TRAPS_P = 0;
+       scm_apply (SCM_EXIT_FRAME_HDLR,
+                  scm_cons (scm_sym_exit_frame,
+                            scm_cons2 (arg1, proc, SCM_EOL)),
+                  SCM_EOL);
+       SCM_TRAPS_P = 1;
       }
 ret:
   scm_last_debug_frame = debug.prev;
Index: libguile/eval.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/eval.h,v
retrieving revision 1.58
diff -u -r1.58 eval.h
--- libguile/eval.h     2001/06/14 19:50:43     1.58
+++ libguile/eval.h     2001/06/25 22:29:19
@@ -68,7 +68,10 @@
 #define SCM_ENTER_FRAME_P      scm_evaluator_trap_table[1].val
 #define SCM_APPLY_FRAME_P      scm_evaluator_trap_table[2].val
 #define SCM_EXIT_FRAME_P       scm_evaluator_trap_table[3].val
-#define SCM_N_EVALUATOR_TRAPS 4
+#define SCM_ENTER_FRAME_HDLR   (SCM)(scm_evaluator_trap_table[4].val)
+#define SCM_APPLY_FRAME_HDLR   (SCM)(scm_evaluator_trap_table[5].val)
+#define SCM_EXIT_FRAME_HDLR    (SCM)(scm_evaluator_trap_table[6].val)
+#define SCM_N_EVALUATOR_TRAPS 7