[Emacs-diffs] master ead5458 2/7: Improve ert backtrace recording

[Noam Postavsky]

branch: master
commit ead545824e511ab18d18b5223eab80e1f4fe3d64
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    Improve ert backtrace recording
    
    Change ert to use the new `backtrace-frames' function instead of
    collecting frames one by one with `backtrace-frame'.  Additionally,
    collect frames starting from `signal' instead the somewhat arbitrary
    "6 from the bottom".  Skipping 6 frames would skip the expression that
    actually caused the signal that triggered the debugger.  Possibly 6
    was chosen because in the case of a failed test, the triggering frame
    is an `ert-fail' call, which is not so interesting.  But in case of a
    test throwing an error, this drops the `error' call which is too much.
    
    * lisp/emacs-lisp/debug.el (debugger-make-xrefs): Remove.
    * lisp/emacs-lisp/ert.el (ert--make-xrefs-region): Bring in relevant
    code from `debugger-make-xrefs'.
    (ert--print-backtrace): Add DO-XREFS parameter, delegate to
    `debugger-insert-backtrace'.
    (ert--run-test-debugger): Record the backtrace frames starting from
    the instigating `signal' call.
    (ert-run-tests-batch): Pass nil for `ert--print-backtrace's new
    DO-XREFS parameter.
    (ert-results-pop-to-backtrace-for-test-at-point): Pass t as DO-XREFS
    to `ert--print-backtrace' and remove call to `debugger-make-xrefs'.
    * test/lisp/emacs-lisp/ert-tests.el (ert-test-record-backtrace): Check
    the backtrace list instead of comparing its string representation.
    Expect `signal' to be the first frame.
---
 lisp/emacs-lisp/debug.el          | 71 --------------------------------
 lisp/emacs-lisp/ert.el            | 85 +++++++++++++++++----------------------
 test/lisp/emacs-lisp/ert-tests.el |  8 +---
 3 files changed, 38 insertions(+), 126 deletions(-)

diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 62e413b..7db0f91 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -370,77 +370,6 @@ That buffer should be current already."
     ;; Place point on "stack frame 0" (bug#15101).
     (goto-char pos)))
 
-
-(defun debugger-make-xrefs (&optional buffer)
-  "Attach cross-references to function names in the `*Backtrace*' buffer."
-  (interactive "b")
-  (with-current-buffer (or buffer (current-buffer))
-    (save-excursion
-      (setq buffer (current-buffer))
-      (let ((inhibit-read-only t)
-           (old-end (point-min)) (new-end (point-min)))
-       ;; If we saved an old backtrace, find the common part
-       ;; between the new and the old.
-       ;; Compare line by line, starting from the end,
-       ;; because that's the part that is likely to be unchanged.
-       (if debugger-previous-backtrace
-           (let (old-start new-start (all-match t))
-             (goto-char (point-max))
-             (with-temp-buffer
-               (insert debugger-previous-backtrace)
-               (while (and all-match (not (bobp)))
-                 (setq old-end (point))
-                 (forward-line -1)
-                 (setq old-start (point))
-                 (with-current-buffer buffer
-                   (setq new-end (point))
-                   (forward-line -1)
-                   (setq new-start (point)))
-                 (if (not (zerop
-                           (let ((case-fold-search nil))
-                             (compare-buffer-substrings
-                              (current-buffer) old-start old-end
-                              buffer new-start new-end))))
-                     (setq all-match nil))))
-             ;; Now new-end is the position of the start of the
-             ;; unchanged part in the current buffer, and old-end is
-             ;; the position of that same text in the saved old
-             ;; backtrace.  But we must subtract (point-min) since strings are
-             ;; indexed in origin 0.
-
-             ;; Replace the unchanged part of the backtrace
-             ;; with the text from debugger-previous-backtrace,
-             ;; since that already has the proper xrefs.
-             ;; With this optimization, we only need to scan
-             ;; the changed part of the backtrace.
-             (delete-region new-end (point-max))
-             (goto-char (point-max))
-             (insert (substring debugger-previous-backtrace
-                                (- old-end (point-min))))
-             ;; Make the unchanged part of the backtrace inaccessible
-             ;; so it won't be scanned.
-             (narrow-to-region (point-min) new-end)))
-
-       ;; Scan the new part of the backtrace, inserting xrefs.
-       (goto-char (point-min))
-       (while (progn
-                (goto-char (+ (point) 2))
-                (skip-syntax-forward "^w_")
-                (not (eobp)))
-         (let* ((beg (point))
-                (end (progn (skip-syntax-forward "w_") (point)))
-                (sym (intern-soft (buffer-substring-no-properties
-                                   beg end)))
-                (file (and sym (symbol-file sym 'defun))))
-           (when file
-             (goto-char beg)
-             ;; help-xref-button needs to operate on something matched
-             ;; by a regexp, so set that up for it.
-             (re-search-forward "\\(\\sw\\|\\s_\\)+")
-             (help-xref-button 0 'help-function-def sym file)))
-         (forward-line 1))
-       (widen))
-      (setq debugger-previous-backtrace (buffer-string)))))
 
 (defun debugger-step-through ()
   "Proceed, stepping through subexpressions of this expression.
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 2c49a63..7edc401 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -670,48 +670,12 @@ and is displayed in front of the value of MESSAGE-FORM."
 (cl-defstruct (ert-test-aborted-with-non-local-exit
                (:include ert-test-result)))
 
-
-(defun ert--record-backtrace ()
-  "Record the current backtrace (as a list) and return it."
-  ;; Since the backtrace is stored in the result object, result
-  ;; objects must only be printed with appropriate limits
-  ;; (`print-level' and `print-length') in place.  For interactive
-  ;; use, the cost of ensuring this possibly outweighs the advantage
-  ;; of storing the backtrace for
-  ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
-  ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
-  ;; For batch use, however, printing the backtrace may be useful.
-  (cl-loop
-   ;; 6 is the number of frames our own debugger adds (when
-   ;; compiled; more when interpreted).  FIXME: Need to describe a
-   ;; procedure for determining this constant.
-   for i from 6
-   for frame = (backtrace-frame i)
-   while frame
-   collect frame))
-
-(defun ert--print-backtrace (backtrace)
+(defun ert--print-backtrace (backtrace do-xrefs)
   "Format the backtrace BACKTRACE to the current buffer."
-  ;; This is essentially a reimplementation of Fbacktrace
-  ;; (src/eval.c), but for a saved backtrace, not the current one.
   (let ((print-escape-newlines t)
         (print-level 8)
         (print-length 50))
-    (dolist (frame backtrace)
-      (pcase-exhaustive frame
-        (`(nil ,special-operator . ,arg-forms)
-         ;; Special operator.
-         (insert
-          (format "  %S\n" (cons special-operator arg-forms))))
-        (`(t ,fn . ,args)
-         ;; Function call.
-         (insert (format "  %S(" fn))
-         (cl-loop for firstp = t then nil
-                  for arg in args do
-                  (unless firstp
-                    (insert " "))
-                  (insert (format "%S" arg)))
-         (insert ")\n"))))))
+    (debugger-insert-backtrace backtrace do-xrefs)))
 
 ;; A container for the state of the execution of a single test and
 ;; environment data needed during its execution.
@@ -750,7 +714,19 @@ run.  ARGS are the arguments to `debugger'."
                       ((quit) 'quit)
                      ((ert-test-skipped) 'skipped)
                       (otherwise 'failed)))
-              (backtrace (ert--record-backtrace))
+              ;; We store the backtrace in the result object for
+              ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+              ;; This means we have to limit `print-level' and
+              ;; `print-length' when printing result objects.  That
+              ;; might not be worth while when we can also use
+              ;; `ert-results-rerun-test-debugging-errors-at-point',
+              ;; (i.e., when running interactively) but having the
+              ;; backtrace ready for printing is important for batch
+              ;; use.
+              ;;
+              ;; Grab the frames starting from `signal', frames below
+              ;; that are all from the debugger.
+              (backtrace (backtrace-frames 'signal))
               (infos (reverse ert--infos)))
          (setf (ert--test-execution-info-result info)
                (cl-ecase type
@@ -1409,8 +1385,9 @@ Returns the stats object."
               (ert-test-result-with-condition
                (message "Test %S backtrace:" (ert-test-name test))
                (with-temp-buffer
-                 (ert--print-backtrace 
(ert-test-result-with-condition-backtrace
-                                        result))
+                 (ert--print-backtrace
+                  (ert-test-result-with-condition-backtrace result)
+                  nil)
                  (goto-char (point-min))
                  (while (not (eobp))
                    (let ((start (point))
@@ -1828,12 +1805,23 @@ EWOC and STATS are arguments for 
`ert--results-update-stats-display'."
 
 BEGIN and END specify a region in the current buffer."
   (save-excursion
-    (save-restriction
-      (narrow-to-region begin end)
-      ;; Inhibit optimization in `debugger-make-xrefs' that would
-      ;; sometimes insert unrelated backtrace info into our buffer.
-      (let ((debugger-previous-backtrace nil))
-        (debugger-make-xrefs)))))
+    (goto-char begin)
+    (while (progn
+             (goto-char (+ (point) 2))
+             (skip-syntax-forward "^w_")
+             (< (point) end))
+      (let* ((beg (point))
+             (end (progn (skip-syntax-forward "w_") (point)))
+             (sym (intern-soft (buffer-substring-no-properties
+                                beg end)))
+             (file (and sym (symbol-file sym 'defun))))
+        (when file
+          (goto-char beg)
+          ;; help-xref-button needs to operate on something matched
+          ;; by a regexp, so set that up for it.
+          (re-search-forward "\\(\\sw\\|\\s_\\)+")
+          (help-xref-button 0 'help-function-def sym file)))
+      (forward-line 1))))
 
 (defun ert--string-first-line (s)
   "Return the first line of S, or S if it contains no newlines.
@@ -2420,8 +2408,7 @@ To be used in the ERT results buffer."
            ;; Use unibyte because `debugger-setup-buffer' also does so.
            (set-buffer-multibyte nil)
            (setq truncate-lines t)
-           (ert--print-backtrace backtrace)
-           (debugger-make-xrefs)
+           (ert--print-backtrace backtrace t)
            (goto-char (point-min))
            (insert (substitute-command-keys "Backtrace for test `"))
            (ert-insert-test-name-button (ert-test-name test))
diff --git a/test/lisp/emacs-lisp/ert-tests.el 
b/test/lisp/emacs-lisp/ert-tests.el
index fc5790c..317838b 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -367,12 +367,8 @@ This macro is used to test if macroexpansion in `should' 
works."
          (test (make-ert-test :body test-body))
          (result (ert-run-test test)))
     (should (ert-test-failed-p result))
-    (with-temp-buffer
-      (ert--print-backtrace (ert-test-failed-backtrace result))
-      (goto-char (point-min))
-      (end-of-line)
-      (let ((first-line (buffer-substring-no-properties (point-min) (point))))
-        (should (equal first-line (format "  %S()" test-body)))))))
+    (should (eq (nth 1 (car (ert-test-failed-backtrace result)))
+                'signal))))
 
 (ert-deftest ert-test-messages ()
   :tags '(:causes-redisplay)