debugger: eval frames.

We introduce evaluation tracking frames. The backtrace
function can use these to deduce the line from which
a function is called (if called from interpreted code).
Eventually we will have analogous virtual machine
frames to do this for compiled code.

* eval.c (do_eval): If backtraces are enabled, then push
and pop an eval frame, which holds the two key pieces: the
form and environment.

* share/txr/stdlib/debug.tl ((fcall-frame loc), (fcall-frame
print-trace), (eval-frame loc), (eval-frame print-trace)):
New methods.
(print-backtrace): Loop reduced to just dispatching
frame-specific print-trace methods. It gives the previous and
next frame to each method.
The (fcall-frame print-trace) method prints function frames,
using the previous form to deduce the location from which
the function is called. The (eval-frame print-trace) method
mostly suppresses the printing of eval frames. We print
an eval frame if it is the parent of an internal function
frame, and if it is the topmost frame (to identify the
toplevel form at the root of the backtrace).

* unwind.c (form_s): New symbol variable.
(eval_frame_type): New static variable.
(uw_find_frames_by_mask): Handle UW_EVAL case, producing
eval-frame struct.
(uw_push_eval): New function.
(uw_late_init): Allocate eval-frame struct type, storing it in
eval_frame_type, and gc-protect that new variable.
Register uw-eval variable evaluating to a one bit mask
with the UW_EVAL-th bit set.

* unwind.h (enum uw_frtype): New enum constant UW_EVAL.
(struct uw_eval): New struct type.
(union uw_frame): New member, el.
(uw_push_eval): Declared.

1 files changed, 37 insertions, 14 deletions

diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl
index 07cbcfe8..9cd52b61 100644
--- a/share/txr/stdlib/debugger.tl
+++ b/share/txr/stdlib/debugger.tl
@@ -44,26 +44,49 @@
 (defun debugger-help ()
   (mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%))
 
+(defmeth fcall-frame loc (fr))
+
+(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix)
+  (let* ((fun fr.fun)
+         (args fr.args)
+         (name (if (functionp fun)
+                 (func-get-name fun)))
+         (loc nx-fr.(loc))
+         (kind
+           (cond
+             ((interp-fun-p fun) "I")
+             ((vm-fun-p fun) "V")
+             ((functionp fun) "C")
+             (t "O"))))
+    (put-string `@prefix @kind:@(if loc `(@loc):`)`)
+    (prinl ^[,(or name fun) ,*args])))
+
+(defmeth eval-frame loc (fr)
+  (source-loc-str fr.form))
+
+(defmeth eval-frame print-trace (fr pr-fr nx-fr prefix)
+  (when (or (null nx-fr)
+            (and (typep pr-fr 'fcall-frame)
+                 (not (interp-fun-p pr-fr.fun))
+                 (not (vm-fun-p pr-fr.fun))))
+    (let* ((form fr.form)
+           (sym (if (consp form) (car form)))
+           (loc (source-loc-str form)))
+      (when sym
+        (put-string `@prefix E:@(if loc `(@loc):`)`)
+        (prinl (if (eq sym 'dwim)
+                 ^[,(cadr form)]
+                 ^(,sym)))))))
+
 (defun print-backtrace (: (*stdout* *stdout*) (prefix ""))
   (with-resources ((imode (set-indent-mode *stdout* indent-foff)
                           (set-indent-mode *stdout* imode))
-                   (depth (set-max-depth *stdout* 4)
+                   (depth (set-max-depth *stdout* 2)
                           (set-max-depth *stdout* depth))
                    (length (set-max-length *stdout* 10)
                            (set-max-length *stdout* length)))
-    (each ((fr (find-frames-by-mask uw-fcall)))
-      (let* ((fun fr.fun)
-             (args fr.args)
-             (name (if (functionp fun)
-                     (func-get-name fun)))
-             (kind
-               (cond
-                 ((interp-fun-p fun) "I")
-                 ((vm-fun-p fun) "V")
-                 ((functionp fun) "C")
-                 (t "O"))))
-        (put-string `@prefix @kind: `)
-        (prinl ^[,(or name fun) ,*args])))))
+    (window-map 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix))
+                (find-frames-by-mask (logior uw-fcall uw-eval)))))
 
 (defun debugger ()
   (with-disabled-debugging