Re: Lisp-friendly backtraces [was: Lispy backtraces]

["Clément Pit--Claudel" <clement.pit@gmail.com>]

[-- Attachment #1.1.1: Type: text/plain, Size: 202 bytes --]

On 2016-12-06 13:55, Eli Zaretskii wrote:
> […]
> Otherwise, LGTM.

Thanks a lot for the review! I've attached an updated patch, which I'll to master in a few days if no one objects :)

Clément.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.1.2: 0001-Move-backtrace-to-ELisp-using-a-new-mapbacktrace-pri.patch --]
[-- Type: text/x-diff; name="0001-Move-backtrace-to-ELisp-using-a-new-mapbacktrace-pri.patch", Size: 16689 bytes --]

From 0a525bc06b992c2995dd8f5853f9485588a2bf88 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Cl=C3=A9ment=20Pit--Claudel?= <clement.pitclaudel@live.com>
Date: Mon, 5 Dec 2016 00:52:14 -0500
Subject: [PATCH] Move backtrace to ELisp using a new mapbacktrace primitive

* src/eval.c (get_backtrace_starting_at, backtrace_frame_apply)
(Fmapbacktrace, Fbacktrace_frame_internal): New functions.
(get_backtrace_frame, Fbacktrace_debug): Use `get_backtrace_starting_at'.

* lisp/subr.el (backtrace--print-frame): New function.
(backtrace): Reimplement using `backtrace--print-frame' and `mapbacktrace'.
(backtrace-frame): Reimplement using `backtrace-frame--internal'.

* lisp/emacs-lisp/debug.el (debugger-setup-buffer): Pass a base to
`mapbacktrace' instead of searching for "(debug" in the output of
`backtrace'.

* test/lisp/subr-tests.el (subr-test-backtrace-simple-tests)
(subr-test-backtrace-integration-test): New tests.

* doc/lispref/debugging.texi (Internals of Debugger): Document
`mapbacktrace' and missing argument BASE of `backtrace-frame'.
---
 doc/lispref/debugging.texi |  23 ++++++-
 etc/NEWS                   |   4 ++
 lisp/emacs-lisp/debug.el   |  11 ++--
 lisp/subr.el               |  45 +++++++++++++
 src/eval.c                 | 157 ++++++++++++++++++++-------------------------
 test/lisp/subr-tests.el    |  47 ++++++++++++++
 6 files changed, 192 insertions(+), 95 deletions(-)

diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index c80b0f9..8fb663d 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -727,7 +727,7 @@ Internals of Debugger
 This variable is obsolete and will be removed in future versions.
 @end defvar
 
-@defun backtrace-frame frame-number
+@defun backtrace-frame frame-number &optional base
 The function @code{backtrace-frame} is intended for use in Lisp
 debuggers.  It returns information about what computation is happening
 in the stack frame @var{frame-number} levels down.
@@ -744,10 +744,31 @@ Internals of Debugger
 case of a macro call.  If the function has a @code{&rest} argument, that
 is represented as the tail of the list @var{arg-values}.
 
+If @var{base} is specified, @var{frame-number} counts relative to
+the topmost frame whose @var{function} is @var{base}.
+
 If @var{frame-number} is out of range, @code{backtrace-frame} returns
 @code{nil}.
 @end defun
 
+@defun mapbacktrace function &optional base
+The function @code{mapbacktrace} calls @var{function} once for each
+frame in the backtrace, starting at the first frame whose function is
+@var{base} (or from the top if @var{base} is omitted or @code{nil}).
+
+@var{function} is called with four arguments: @var{evald}, @var{func},
+@var{args}, and @var{flags}.
+
+If a frame has not evaluated its arguments yet or is a special form,
+@var{evald} is @code{nil} and @var{args} is a list of forms.
+
+If a frame has evaluated its arguments and called its function
+already, @var{evald} is @code{t} and @var{args} is a list of values.
+@var{flags} is a plist of properties of the current frame: currently,
+the only supported property is @code{:debug-on-exit}, which is
+@code{t} if the stack frame's @code{debug-on-exit} flag is set.
+@end defun
+
 @include edebug.texi
 
 @node Syntax Errors
diff --git a/etc/NEWS b/etc/NEWS
index a62668a..72bef06 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -74,6 +74,10 @@ for '--daemon'.
 * Changes in Emacs 26.1
 
 +++
+** The new function 'mapbacktrace' applies a function to all frames of
+the current stack trace.
+
++++
 ** The new function 'file-name-case-insensitive-p' tests whether a
 given file is on a case-insensitive filesystem.
 
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 5430b72..5a4b097 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -274,15 +274,14 @@ debugger-setup-buffer
   (let ((standard-output (current-buffer))
 	(print-escape-newlines t)
 	(print-level 8)
-	(print-length 50))
-    (backtrace))
+        (print-length 50))
+    ;; FIXME the debugger could pass a custom callback to mapbacktrace
+    ;; instead of manipulating printed results.
+    (mapbacktrace #'backtrace--print-frame 'debug))
   (goto-char (point-min))
   (delete-region (point)
 		 (progn
-		   (search-forward (if debugger-stack-frame-as-list
-                                       "\n  (debug "
-                                     "\n  debug("))
-		   (forward-line (if (eq (car args) 'debug)
+                   (forward-line (if (eq (car args) 'debug)
                                      ;; Remove debug--implement-debug-on-entry
                                      ;; and the advice's `apply' frame.
 				     3
diff --git a/lisp/subr.el b/lisp/subr.el
index 5da5bf8..6ab1d5f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4333,6 +4333,51 @@ define-mail-user-agent
   (put symbol 'sendfunc sendfunc)
   (put symbol 'abortfunc (or abortfunc 'kill-buffer))
   (put symbol 'hookvar (or hookvar 'mail-send-hook)))
+
+\f
+(defun backtrace--print-frame (evald func args flags)
+  "Print a trace of a single stack frame to `standard-output'.
+EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
+  (princ (if (plist-get flags :debug-on-exit) "* " "  "))
+  (cond
+   ((and evald (not debugger-stack-frame-as-list))
+    (prin1 func)
+    (if args (prin1 args) (princ "()")))
+   (t
+    (prin1 (cons func args))))
+  (princ "\n"))
+
+(defun backtrace ()
+  "Print a trace of Lisp function calls currently active.
+Output stream used is value of `standard-output'."
+  (let ((print-level (or print-level 8)))
+    (mapbacktrace #'backtrace--print-frame 'backtrace)))
+
+(defun backtrace-frames (&optional base)
+  "Collect all frames of current backtrace into a list.
+If non-nil, BASE should be a function, and frames before its
+nearest activation frames are discarded."
+  (let ((frames nil))
+    (mapbacktrace (lambda (&rest frame) (push frame frames))
+                  (or base 'backtrace-frames))
+    (nreverse frames)))
+
+(defun backtrace-frame (nframes &optional base)
+  "Return the function and arguments NFRAMES up from current execution point.
+If non-nil, BASE should be a function, and NFRAMES counts from its
+nearest activation frame.
+If the frame has not evaluated the arguments yet (or is a special form),
+the value is (nil FUNCTION ARG-FORMS...).
+If the frame has evaluated its arguments and called its function already,
+the value is (t FUNCTION ARG-VALUES...).
+A &rest arg is represented as the tail of the list ARG-VALUES.
+FUNCTION is whatever was supplied as car of evaluated list,
+or a lambda expression for macro calls.
+If NFRAMES is more than the number of frames, the value is nil."
+  (backtrace-frame--internal
+   (lambda (evald func args _) `(,evald ,func ,@args))
+   nframes (or base 'backtrace-frame)))
+
 \f
 (defvar called-interactively-p-functions nil
   "Special hook called to skip special frames in `called-interactively-p'.
diff --git a/src/eval.c b/src/eval.c
index 724f001..929b942 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -3401,87 +3401,29 @@ context where binding is lexical by default.  */)
 }
 
 \f
-DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
-       doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
-The debugger is entered when that frame exits, if the flag is non-nil.  */)
-  (Lisp_Object level, Lisp_Object flag)
-{
-  union specbinding *pdl = backtrace_top ();
-  register EMACS_INT i;
-
-  CHECK_NUMBER (level);
-
-  for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
-    pdl = backtrace_next (pdl);
-
-  if (backtrace_p (pdl))
-    set_backtrace_debug_on_exit (pdl, !NILP (flag));
-
-  return flag;
-}
-
-DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
-       doc: /* Print a trace of Lisp function calls currently active.
-Output stream used is value of `standard-output'.  */)
-  (void)
+static union specbinding *
+get_backtrace_starting_at (Lisp_Object base)
 {
   union specbinding *pdl = backtrace_top ();
-  Lisp_Object tem;
-  Lisp_Object old_print_level = Vprint_level;
 
-  if (NILP (Vprint_level))
-    XSETFASTINT (Vprint_level, 8);
-
-  while (backtrace_p (pdl))
-    {
-      write_string (backtrace_debug_on_exit (pdl) ? "* " : "  ");
-      if (backtrace_nargs (pdl) == UNEVALLED)
-	{
-	  Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
-		  Qnil);
-	  write_string ("\n");
-	}
-      else
-	{
-	  tem = backtrace_function (pdl);
-	  if (debugger_stack_frame_as_list)
-	    write_string ("(");
-	  Fprin1 (tem, Qnil);	/* This can QUIT.  */
-	  if (!debugger_stack_frame_as_list)
-	    write_string ("(");
-	  {
-	    ptrdiff_t i;
-	    for (i = 0; i < backtrace_nargs (pdl); i++)
-	      {
-		if (i || debugger_stack_frame_as_list)
-		  write_string(" ");
-		Fprin1 (backtrace_args (pdl)[i], Qnil);
-	      }
-	  }
-	  write_string (")\n");
-	}
-      pdl = backtrace_next (pdl);
+  if (!NILP (base))
+    { /* Skip up to `base'.  */
+      base = Findirect_function (base, Qt);
+      while (backtrace_p (pdl)
+             && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
+        pdl = backtrace_next (pdl);
     }
 
-  Vprint_level = old_print_level;
-  return Qnil;
+  return pdl;
 }
 
 static union specbinding *
 get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
 {
-  union specbinding *pdl = backtrace_top ();
   register EMACS_INT i;
 
   CHECK_NATNUM (nframes);
-
-  if (!NILP (base))
-    { /* Skip up to `base'.  */
-      base = Findirect_function (base, Qt);
-      while (backtrace_p (pdl)
-	     && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
-	pdl = backtrace_next (pdl);
-    }
+  union specbinding *pdl = get_backtrace_starting_at (base);
 
   /* Find the frame requested.  */
   for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
@@ -3490,33 +3432,71 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
   return pdl;
 }
 
-DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL,
-       doc: /* Return the function and arguments NFRAMES up from current execution point.
-If that frame has not evaluated the arguments yet (or is a special form),
-the value is (nil FUNCTION ARG-FORMS...).
-If that frame has evaluated its arguments and called its function already,
-the value is (t FUNCTION ARG-VALUES...).
-A &rest arg is represented as the tail of the list ARG-VALUES.
-FUNCTION is whatever was supplied as car of evaluated list,
-or a lambda expression for macro calls.
-If NFRAMES is more than the number of frames, the value is nil.
-If BASE is non-nil, it should be a function and NFRAMES counts from its
-nearest activation frame.  */)
-  (Lisp_Object nframes, Lisp_Object base)
+static Lisp_Object
+backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
 {
-  union specbinding *pdl = get_backtrace_frame (nframes, base);
-
   if (!backtrace_p (pdl))
     return Qnil;
+
+  Lisp_Object flags = Qnil;
+  if (backtrace_debug_on_exit (pdl))
+    flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
+
   if (backtrace_nargs (pdl) == UNEVALLED)
-    return Fcons (Qnil,
-		  Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
+    return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
   else
     {
       Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+      return call4 (function, Qt, backtrace_function (pdl), tem, flags);
+    }
+}
 
-      return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
+DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
+       doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
+The debugger is entered when that frame exits, if the flag is non-nil.  */)
+  (Lisp_Object level, Lisp_Object flag)
+{
+  CHECK_NUMBER (level);
+  union specbinding *pdl = get_backtrace_frame(level, Qnil);
+
+  if (backtrace_p (pdl))
+    set_backtrace_debug_on_exit (pdl, !NILP (flag));
+
+  return flag;
+}
+
+DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
+       doc: /* Call FUNCTION for each frame in backtrace.
+If BASE is non-nil, it should be a function and iteration will start
+from its nearest activation frame.
+FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS.  If
+a frame has not evaluated its arguments yet or is a special form,
+EVALD is nil and ARGS is a list of forms.  If a frame has evaluated
+its arguments and called its function already, EVALD is t and ARGS is
+a list of values.
+FLAGS is a plist of properties of the current frame: currently, the
+only supported property is :debug-on-exit.  `mapbacktrace' always
+returns nil.  */)
+     (Lisp_Object function, Lisp_Object base)
+{
+  union specbinding *pdl = get_backtrace_starting_at (base);
+
+  while (backtrace_p (pdl))
+    {
+      backtrace_frame_apply (function, pdl);
+      pdl = backtrace_next (pdl);
     }
+
+  return Qnil;
+}
+
+DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal,
+       Sbacktrace_frame_internal, 3, 3, NULL,
+       doc: /* Call FUNCTION on stack frame NFRAMES away from BASE.
+Return the result of FUNCTION, or nil if no matching frame could be found. */)
+     (Lisp_Object function, Lisp_Object nframes, Lisp_Object base)
+{
+  return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
 }
 
 /* For backtrace-eval, we want to temporarily unwind the last few elements of
@@ -3973,8 +3953,9 @@ alist of active lexical bindings.  */);
   defsubr (&Srun_hook_wrapped);
   defsubr (&Sfetch_bytecode);
   defsubr (&Sbacktrace_debug);
-  defsubr (&Sbacktrace);
-  defsubr (&Sbacktrace_frame);
+  DEFSYM (QCdebug_on_exit, ":debug-on-exit");
+  defsubr (&Smapbacktrace);
+  defsubr (&Sbacktrace_frame_internal);
   defsubr (&Sbacktrace_eval);
   defsubr (&Sbacktrace__locals);
   defsubr (&Sspecial_variable_p);
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index ce21290..82a70ca 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -224,5 +224,52 @@
               (error-message-string (should-error (version-to-list "beta22_8alpha3")))
               "Invalid version syntax: `beta22_8alpha3' (must start with a number)"))))
 
+(defun subr-test--backtrace-frames-with-backtrace-frame (base)
+  "Reference implementation of `backtrace-frames'."
+  (let ((idx 0)
+        (frame nil)
+        (frames nil))
+    (while (setq frame (backtrace-frame idx base))
+      (push frame frames)
+      (setq idx (1+ idx)))
+    (nreverse frames)))
+
+(defun subr-test--frames-2 (base)
+  (let ((_dummy nil))
+    (progn ;; Add a few frames to top of stack
+      (unwind-protect
+          (cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_))
+                          `(,evald ,func ,@args))
+                        (backtrace-frames base))
+                (subr-test--backtrace-frames-with-backtrace-frame base))))))
+
+(defun subr-test--frames-1 (base)
+  (subr-test--frames-2 base))
+
+(ert-deftest subr-test-backtrace-simple-tests ()
+  "Test backtrace-related functions (simple tests).
+This exercises `backtrace-frame', and indirectly `mapbacktrace'."
+  ;; `mapbacktrace' returns nil
+  (should (equal (mapbacktrace #'ignore) nil))
+  ;; Unbound BASE is silently ignored
+  (let ((unbound (make-symbol "ub")))
+    (should (equal (backtrace-frame 0 unbound) nil))
+    (should (equal (mapbacktrace #'error unbound) nil)))
+  ;; First frame is backtrace-related function
+  (should (equal (backtrace-frame 0) '(t backtrace-frame 0)))
+  (should (equal (catch 'ret
+                   (mapbacktrace (lambda (&rest args) (throw 'ret args))))
+                 '(t mapbacktrace ((lambda (&rest args) (throw 'ret args))) nil)))
+  ;; Past-end NFRAMES is silently ignored
+  (should (equal (backtrace-frame most-positive-fixnum) nil)))
+
+(ert-deftest subr-test-backtrace-integration-test ()
+  "Test backtrace-related functions (integration test).
+This exercises `backtrace-frame', `backtrace-frames', and
+indirectly `mapbacktrace'."
+  ;; Compare two implementations of backtrace-frames
+  (let ((frame-lists (subr-test--frames-1 'subr-test--frames-2)))
+    (should (equal (car frame-lists) (cdr frame-lists)))))
+
 (provide 'subr-tests)
 ;;; subr-tests.el ends here
-- 
2.7.4


[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 819 bytes --]