; Merge: Backtrace printing improvements (Bug#6991)

3 files changed, 107 insertions, 168 deletions

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 89a71d1b6c5..824d0b7b4f5 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -105,10 +105,11 @@ into a button whose action shows the function's disassembly.")
     (if args
         (prin1 args stream)
       (princ "()" stream)))
-  (let ((doc (documentation object 'raw)))
-    (when doc
-      (princ " " stream)
-      (prin1 doc stream)))
+  (pcase (help-split-fundoc (documentation object 'raw) object)
+    ;; Drop args which `help-function-arglist' already printed.
+    (`(,_usage . ,(and doc (guard (stringp doc))))
+     (princ " " stream)
+     (prin1 doc stream)))
   (let ((inter (interactive-form object)))
     (when inter
       (princ " " stream)
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 83456fc31a2..726005af9b1 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -49,6 +49,12 @@ the middle is discarded, and just the beginning and end are displayed."
   :group 'debugger
   :version "21.1")
 
+(defcustom debugger-print-function #'cl-prin1
+  "Function used to print values in the debugger backtraces."
+  :type 'function
+  :options '(cl-prin1 prin1)
+  :version "26.1")
+
 (defcustom debugger-bury-or-kill 'bury
   "What to do with the debugger buffer when exiting `debug'.
 The value affects the behavior of operations on any window
@@ -264,6 +270,43 @@ first will be printed into the backtrace buffer."
       (setq debug-on-next-call debugger-step-after-exit)
       debugger-value)))
 
+
+(defvar cl-print-compiled-button)
+
+(defun debugger-insert-backtrace (frames do-xrefs)
+  "Format and insert the backtrace FRAMES at point.
+Make functions into cross-reference buttons if DO-XREFS is non-nil."
+  (let ((standard-output (current-buffer))
+        (cl-print-compiled-button t)
+        (eval-buffers eval-buffer-list))
+    (require 'help-mode)     ; Define `help-function-def' button type.
+    (pcase-dolist (`(,evald ,fun ,args ,flags) frames)
+      (insert (if (plist-get flags :debug-on-exit)
+                  "* " "  "))
+      (let ((fun-file (and do-xrefs (symbol-file fun 'defun)))
+            (fun-pt (point)))
+        (cond
+         ((and evald (not debugger-stack-frame-as-list))
+          (funcall debugger-print-function fun)
+          (if args (funcall debugger-print-function args) (princ "()")))
+         (t
+          (funcall debugger-print-function (cons fun args))
+          (cl-incf fun-pt)))
+        (when fun-file
+          (make-text-button fun-pt (+ fun-pt (length (symbol-name fun)))
+                            :type 'help-function-def
+                            'help-args (list fun fun-file))))
+      ;; After any frame that uses eval-buffer, insert a line that
+      ;; states the buffer position it's reading at.
+      (when (and eval-buffers (memq fun '(eval-buffer eval-region)))
+        (insert (format "  ; Reading at buffer position %d"
+                        ;; This will get the wrong result if there are
+                        ;; two nested eval-region calls for the same
+                        ;; buffer.  That's not a very useful case.
+                        (with-current-buffer (pop eval-buffers)
+                          (point)))))
+      (insert "\n"))))
+
 (defun debugger-setup-buffer (args)
   "Initialize the `*Backtrace*' buffer for entry to the debugger.
 That buffer should be current already."
@@ -271,27 +314,20 @@ That buffer should be current already."
   (erase-buffer)
   (set-buffer-multibyte t)		;Why was it nil ?  -stef
   (setq buffer-undo-list t)
-  (let ((standard-output (current-buffer))
-	(print-escape-newlines t)
-	(print-level 8)
-        (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
-                   (forward-line (if (eq (car args) 'debug)
-                                     ;; Remove debug--implement-debug-on-entry
-                                     ;; and the advice's `apply' frame.
-				     3
-				   1))
-		   (point)))
   (insert "Debugger entered")
-  ;; lambda is for debug-on-call when a function call is next.
-  ;; debug is for debug-on-entry function called.
-  (let ((pos (point)))
+  (let ((frames (nthcdr
+                 ;; Remove debug--implement-debug-on-entry and the
+                 ;; advice's `apply' frame.
+                 (if (eq (car args) 'debug) 3 1)
+                 (backtrace-frames 'debug)))
+        (print-escape-newlines t)
+        (print-escape-control-characters t)
+        (print-level 8)
+        (print-length 50)
+        (pos (point)))
     (pcase (car args)
+      ;; lambda is for debug-on-call when a function call is next.
+      ;; debug is for debug-on-entry function called.
       ((or `lambda `debug)
        (insert "--entering a function:\n")
        (setq pos (1- (point))))
@@ -300,11 +336,9 @@ That buffer should be current already."
        (insert "--returning value: ")
        (setq pos (point))
        (setq debugger-value (nth 1 args))
-       (prin1 debugger-value (current-buffer))
-       (insert ?\n)
-       (delete-char 1)
-       (insert ? )
-       (beginning-of-line))
+       (funcall debugger-print-function debugger-value (current-buffer))
+       (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil)
+       (insert ?\n))
       ;; Watchpoint triggered.
       ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args)))
        (insert
@@ -327,7 +361,7 @@ That buffer should be current already."
       (`error
        (insert "--Lisp error: ")
        (setq pos (point))
-       (prin1 (nth 1 args) (current-buffer))
+       (funcall debugger-print-function (nth 1 args) (current-buffer))
        (insert ?\n))
       ;; debug-on-call, when the next thing is an eval.
       (`t
@@ -337,98 +371,15 @@ That buffer should be current already."
       (_
        (insert ": ")
        (setq pos (point))
-       (prin1 (if (eq (car args) 'nil)
-                  (cdr args) args)
-              (current-buffer))
+       (funcall debugger-print-function
+                (if (eq (car args) 'nil)
+                    (cdr args) args)
+                (current-buffer))
        (insert ?\n)))
+    (debugger-insert-backtrace frames t)
     ;; Place point on "stack frame 0" (bug#15101).
-    (goto-char pos))
-  ;; After any frame that uses eval-buffer,
-  ;; insert a line that states the buffer position it's reading at.
-  (save-excursion
-    (let ((tem eval-buffer-list))
-      (while (and tem
-		  (re-search-forward "^  eval-\\(buffer\\|region\\)(" nil t))
-	(end-of-line)
-	(insert (format "  ; Reading at buffer position %d"
-			;; This will get the wrong result
-			;; if there are two nested eval-region calls
-			;; for the same buffer.  That's not a very useful case.
-			(with-current-buffer (car tem)
-			  (point))))
-	(pop tem))))
-  (debugger-make-xrefs))
-
-(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)))))
+    (goto-char pos)))
+
 
 (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 2c49a634e35..7edc40188e1 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))