master 6937182a0e7: debug.el: Straighten the code that find the "base" of the backtrace

[Stefan Monnier]

branch: master
commit 6937182a0e7735e83377c757ae13292692b0cb85
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    debug.el: Straighten the code that find the "base" of the backtrace
    
    Let the caller tell us clearly where is the base of the backtrace,
    if it's not `debug`.  This is done by passing a new `:backtrace-base`
    keyword argument to `debug`.
    
    Then use this info systematically in all the places where we access
    the real C-level backtrace, to try and avoid inconsistencies and brittle
    code that tries to enumerate the expected frames we're in.
    
    * src/eval.c (get_backtrace_starting_at): Add support for offsets in the
    `base` argument.
    (Fbacktrace_debug): Add optional `base` argument.
    
    * lisp/emacs-lisp/debug.el (debug, debugger-frame, debugger-frame-clear):
    Use `debugger--backtrace-base` when calling `backtrace-debug`.
    (debugger-setup-buffer): Use `debugger--backtrace-base`
    when calling `backtrace-get-frames`.
    (debugger-frame-number): Drop `skip-base` arg, assume it's never nil.
    Add sanity check.
    (debugger--backtrace-base): Use the `:backtrace-base` info
    in `debugger-args`.
    (debugger-eval-expression): Adjust call to `debugger-frame-number`.
    (debug--implement-debug-on-entry): Pass appropriate `:backtrace-base`.
---
 lisp/emacs-lisp/debug.el | 62 +++++++++++++++++++++++++-----------------------
 lisp/subr.el             |  7 +++---
 src/eval.c               | 20 ++++++++++++----
 3 files changed, 52 insertions(+), 37 deletions(-)

diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 5411088189d..e0b6ca31b9e 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -237,12 +237,11 @@ the debugger will not be entered."
          (unwind-protect
              (save-excursion
                (when (eq (car debugger-args) 'debug)
-                 ;; Skip the frames for backtrace-debug, byte-code,
-                 ;; debug--implement-debug-on-entry and the advice's `apply'.
-                 (backtrace-debug 4 t)
-                 ;; Place an extra debug-on-exit for macro's.
-                 (when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
-                   (backtrace-debug 5 t)))
+                 (let ((base (debugger--backtrace-base)))
+                   (backtrace-debug 1 t base) ;FIXME!
+                   ;; Place an extra debug-on-exit for macro's.
+                   (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 
base))))
+                     (backtrace-debug 2 t base))))
                 (with-current-buffer debugger-buffer
                   (unless (derived-mode-p 'debugger-mode)
                    (debugger-mode))
@@ -343,11 +342,10 @@ Make functions into cross-reference buttons if DO-XREFS 
is non-nil."
 (defun debugger-setup-buffer (args)
   "Initialize the `*Backtrace*' buffer for entry to the debugger.
 That buffer should be current already and in `debugger-mode'."
-  (setq backtrace-frames (nthcdr
-                          ;; Remove debug--implement-debug-on-entry and the
-                          ;; advice's `apply' frame.
-                          (if (eq (car args) 'debug) 3 1)
-                          (backtrace-get-frames 'debug)))
+  (setq backtrace-frames
+        ;; The `base' frame is the one that gets index 0 and it is the entry to
+        ;; the debugger, so drop it with `cdr'.
+        (cdr (backtrace-get-frames (debugger--backtrace-base))))
   (when (eq (car-safe args) 'exit)
     (setq debugger-value (nth 1 args))
     (setf (cl-getf (backtrace-frame-flags (car backtrace-frames))
@@ -477,26 +475,29 @@ removes itself from that hook."
   (setq debugger-jumping-flag nil)
   (remove-hook 'post-command-hook 'debugger-reenable))
 
-(defun debugger-frame-number (&optional skip-base)
+(defun debugger-frame-number ()
   "Return number of frames in backtrace before the one point points at."
-  (let ((index (backtrace-get-index))
-        (count 0))
+  (let ((index (backtrace-get-index)))
     (unless index
       (error "This line is not a function call"))
-    (unless skip-base
-        (while (not (eq (cadr (backtrace-frame count)) 'debug))
-          (setq count (1+ count)))
-        ;; Skip debug--implement-debug-on-entry frame.
-        (when (eq 'debug--implement-debug-on-entry
-                  (cadr (backtrace-frame (1+ count))))
-          (setq count (+ 2 count))))
-    (+ count index)))
+    ;; We have 3 representations of the backtrace: the real in C in `specpdl',
+    ;; the one stored in `backtrace-frames' and the textual version in
+    ;; the buffer.  Check here that the one from `backtrace-frames' is in sync
+    ;; with the one from `specpdl'.
+    (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames))
+                      (nth 1 (backtrace-frame (1+ index)
+                                              (debugger--backtrace-base)))))
+    ;; The `base' frame is the one that gets index 0 and it is the entry to
+    ;; the debugger, so the first non-debugger frame is 1.
+    ;; This `+1' skips the same frame as the `cdr' in
+    ;; `debugger-setup-buffer'.
+    (1+ index)))
 
 (defun debugger-frame ()
   "Request entry to debugger when this frame exits.
 Applies to the frame whose line point is on in the backtrace."
   (interactive)
-  (backtrace-debug (debugger-frame-number) t)
+  (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base))
   (setf
    (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) 
backtrace-frames))
             :debug-on-exit)
@@ -507,7 +508,7 @@ Applies to the frame whose line point is on in the 
backtrace."
   "Do not enter debugger when this frame exits.
 Applies to the frame whose line point is on in the backtrace."
   (interactive)
-  (backtrace-debug (debugger-frame-number) nil)
+  (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base))
   (setf
    (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) 
backtrace-frames))
             :debug-on-exit)
@@ -526,10 +527,8 @@ Applies to the frame whose line point is on in the 
backtrace."
 (defun debugger--backtrace-base ()
   "Return the function name that marks the top of the backtrace.
 See `backtrace-frame'."
-  (cond ((eq 'debug--implement-debug-on-entry
-            (cadr (backtrace-frame 1 'debug)))
-        'debug--implement-debug-on-entry)
-       (t 'debug)))
+  (or (cadr (memq :backtrace-base debugger-args))
+      #'debug))
 
 (defun debugger-eval-expression (exp &optional nframe)
   "Eval an expression, in an environment like that outside the debugger.
@@ -537,7 +536,7 @@ The environment used is the one when entering the 
activation frame at point."
   (interactive
    (list (read--expression "Eval in stack frame: ")))
   (let ((nframe (or nframe
-                    (condition-case nil (1+ (debugger-frame-number 'skip-base))
+                    (condition-case nil (debugger-frame-number)
                       (error 0)))) ;; If on first line.
        (base (debugger--backtrace-base)))
     (debugger-env-macro
@@ -670,7 +669,10 @@ functions to break on entry."
   (if (or inhibit-debug-on-entry debugger-jumping-flag)
       nil
     (let ((inhibit-debug-on-entry t))
-      (funcall debugger 'debug))))
+      (funcall debugger 'debug :backtrace-base
+               ;; An offset of 1 because we need to skip the advice
+               ;; OClosure that called us.
+               '(1 . debug--implement-debug-on-entry)))))
 
 ;;;###autoload
 (defun debug-on-entry (function)
diff --git a/lisp/subr.el b/lisp/subr.el
index 7b52f4f68f9..93428c4a518 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -6384,13 +6384,14 @@ If non-nil, BASE should be a function, and frames 
before its
 nearest activation frame are discarded."
   (let ((frames nil))
     (mapbacktrace (lambda (&rest frame) (push frame frames))
-                  (or base 'backtrace-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.
+nearest activation frame.  BASE can also be of the form (OFFSET . FUNCTION)
+in which case OFFSET will be added to NFRAMES.
 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,
@@ -6401,7 +6402,7 @@ 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)))
+   nframes (or base #'backtrace-frame)))
 
 
 (defvar called-interactively-p-functions nil
diff --git a/src/eval.c b/src/eval.c
index 12e811ce264..419285eb694 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -3806,10 +3806,18 @@ get_backtrace_starting_at (Lisp_Object base)
 
   if (!NILP (base))
     { /* Skip up to `base'.  */
+      int offset = 0;
+      if (CONSP (base) && FIXNUMP (XCAR (base)))
+        {
+          offset = XFIXNUM (XCAR (base));
+          base = XCDR (base);
+        }
       base = Findirect_function (base, Qt);
       while (backtrace_p (pdl)
              && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
         pdl = backtrace_next (pdl);
+      while (backtrace_p (pdl) && offset-- > 0)
+        pdl = backtrace_next (pdl);
     }
 
   return pdl;
@@ -3849,13 +3857,14 @@ backtrace_frame_apply (Lisp_Object function, union 
specbinding *pdl)
     }
 }
 
-DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
+DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 3, 0,
        doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to 
FLAG.
+LEVEL and BASE specify the activation frame to use, as in `backtrace-frame'.
 The debugger is entered when that frame exits, if the flag is non-nil.  */)
-  (Lisp_Object level, Lisp_Object flag)
+  (Lisp_Object level, Lisp_Object flag, Lisp_Object base)
 {
   CHECK_FIXNUM (level);
-  union specbinding *pdl = get_backtrace_frame(level, Qnil);
+  union specbinding *pdl = get_backtrace_frame (level, base);
 
   if (backtrace_p (pdl))
     set_backtrace_debug_on_exit (pdl, !NILP (flag));
@@ -4342,7 +4351,10 @@ If due to frame exit, args are `exit' and the value 
being returned;
  this function's value will be returned instead of that.
 If due to error, args are `error' and a list of the args to `signal'.
 If due to `apply' or `funcall' entry, one arg, `lambda'.
-If due to `eval' entry, one arg, t.  */);
+If due to `eval' entry, one arg, t.
+IF the desired entry point of the debugger is higher in the call stack,
+it can can be specified with the keyword argument `:backtrace-base'
+whose format should be the same as the BASE arg of `backtrace-frame'.  */);
   Vdebugger = Qdebug_early;
 
   DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function,