pull 29.1 elisp

Author: gtrak

lisp/emacs-lisp/backtrace.el

@@ -1,6 +1,6 @@
 ;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*-
 
-;; Copyright (C) 2018-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2018-2023 Free Software Foundation, Inc.
 
 ;; Author: Gemini Lasswell
 ;; Keywords: lisp, tools, maint
@@ -135,7 +135,8 @@ frames before its nearest activation frame are discarded."
 ;; Font Locking support
 
 (defconst backtrace--font-lock-keywords
-  '()
+  '((backtrace--match-ellipsis-in-string
+     (1 'button prepend)))
   "Expressions to fontify in Backtrace mode.
 Fontify these in addition to the expressions Emacs Lisp mode
 fontifies.")
@@ -153,6 +154,16 @@ fontifies.")
           backtrace--font-lock-keywords)
   "Gaudy level highlighting for Backtrace mode.")
 
+(defun backtrace--match-ellipsis-in-string (bound)
+  ;; Fontify ellipses within strings as buttons.
+  ;; This is necessary because ellipses are text property buttons
+  ;; instead of overlay buttons, which is done because there could
+  ;; be a large number of them.
+  (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t)
+    (and (get-text-property (- (point) 2) 'cl-print-ellipsis)
+         (get-text-property (- (point) 3) 'cl-print-ellipsis)
+         (get-text-property (- (point) 4) 'cl-print-ellipsis))))
+
 ;;; Xref support
 
 (defun backtrace--xref-backend () 'elisp)
@@ -413,12 +424,12 @@ the buffer."
       (overlay-put o 'evaporate t))))
 
 (defun backtrace--change-button-skip (beg end value)
-  "Change the `skip' property on all buttons between BEG and END.
-Set it to VALUE unless the button is a `cl-print-ellipsis' button."
+  "Change the skip property on all buttons between BEG and END.
+Set it to VALUE unless the button is a `backtrace-ellipsis' button."
   (let ((inhibit-read-only t))
     (setq beg (next-button beg))
     (while (and beg (< beg end))
-      (unless (eq (button-type beg) 'cl-print-ellipsis)
+      (unless (eq (button-type beg) 'backtrace-ellipsis)
           (button-put beg 'skip value))
       (setq beg (next-button beg)))))
 
@@ -486,15 +497,34 @@ Reprint the frame with the new view plist."
                          `(backtrace-index ,index backtrace-view ,view))
     (goto-char min)))
 
-(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args)
-  "Wrapper to expand an ellipsis.
-For use on `cl-print-expand-ellipsis-function'."
-  (let* ((props (backtrace-get-text-properties begin))
+(defun backtrace-expand-ellipsis (button)
+  "Expand display of the elided form at BUTTON."
+  (interactive)
+  (goto-char (button-start button))
+  (unless (get-text-property (point) 'cl-print-ellipsis)
+    (if (and (> (point) (point-min))
+             (get-text-property (1- (point)) 'cl-print-ellipsis))
+        (backward-char)
+      (user-error "No ellipsis to expand here")))
+  (let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
+         (begin (previous-single-property-change end 'cl-print-ellipsis))
+         (value (get-text-property begin 'cl-print-ellipsis))
+         (props (backtrace-get-text-properties begin))
          (inhibit-read-only t))
     (backtrace--with-output-variables (backtrace-get-view)
-      (let ((end (apply orig-fun begin end val backtrace-line-length args)))
-        (add-text-properties begin end props)
-        end))))
+      (delete-region begin end)
+      (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value
+                                          backtrace-line-length))
+      (setq end (point))
+      (goto-char begin)
+      (while (< (point) end)
+        (let ((next (next-single-property-change (point) 'cl-print-ellipsis
+                                                 nil end)))
+          (when (get-text-property (point) 'cl-print-ellipsis)
+            (make-text-button (point) next :type 'backtrace-ellipsis))
+          (goto-char next)))
+      (goto-char begin)
+      (add-text-properties begin end props))))
 
 (defun backtrace-expand-ellipses (&optional no-limit)
   "Expand display of all \"...\"s in the backtrace frame at point.
@@ -667,6 +697,13 @@ line and recenter window line accordingly."
                  (recenter window-line)))
       (goto-char (point-min)))))
 
+;; Define button type used for ...'s.
+;; Set skip property so you don't have to TAB through 100 of them to
+;; get to the next function name.
+(define-button-type 'backtrace-ellipsis
+  'skip t 'action #'backtrace-expand-ellipsis
+  'help-echo "mouse-2, RET: expand this ellipsis")
+
 (defun backtrace-print-to-string (obj &optional limit)
   "Return a printed representation of OBJ formatted for backtraces.
 Attempt to get the length of the returned string under LIMIT
@@ -678,10 +715,21 @@ characters with appropriate settings of `print-level' and
 (defun backtrace--print-to-string (sexp &optional limit)
   ;; This is for use by callers who wrap the call with
   ;; backtrace--with-output-variables.
-  (propertize (cl-print-to-string-with-limit #'backtrace--print sexp
-                                             (or limit backtrace-line-length))
-              ;; Add a unique backtrace-form property.
-              'backtrace-form (gensym)))
+  (setq limit (or limit backtrace-line-length))
+  (with-temp-buffer
+    (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit))
+    ;; Add a unique backtrace-form property.
+    (put-text-property (point-min) (point) 'backtrace-form (gensym))
+    ;; Make buttons from all the "..."s.  Since there might be many of
+    ;; them, use text property buttons.
+    (goto-char (point-min))
+    (while (< (point) (point-max))
+      (let ((end (next-single-property-change (point) 'cl-print-ellipsis
+                                              nil (point-max))))
+        (when (get-text-property (point) 'cl-print-ellipsis)
+          (make-text-button (point) end :type 'backtrace-ellipsis))
+        (goto-char end)))
+    (buffer-string)))
 
 (defun backtrace-print-frame (frame view)
   "Insert a backtrace FRAME at point formatted according to VIEW.
@@ -720,10 +768,9 @@ Format it according to VIEW."
          (def   (find-function-advised-original fun))
          (fun-file (or (symbol-file fun 'defun)
                        (and (subrp def)
-                            (not (special-form-p def))
+                            (not (eq 'unevalled (cdr (subr-arity def))))
                             (find-lisp-object-file-name fun def))))
-         (fun-beg (point))
-         (fun-end nil))
+         (fun-pt (point)))
     (cond
      ((and evald (not debugger-stack-frame-as-list))
       (if (atom fun)
@@ -733,7 +780,6 @@ Format it according to VIEW."
           fun
           (when (and args (backtrace--line-length-or-nil))
             (/ backtrace-line-length 2)))))
-      (setq fun-end (point))
       (if args
           (insert (backtrace--print-to-string
                    args
@@ -749,16 +795,10 @@ Format it according to VIEW."
      (t
       (let ((fun-and-args (cons fun args)))
         (insert (backtrace--print-to-string fun-and-args)))
-      ;; Skip the open-paren.
-      (cl-incf fun-beg)))
+      (cl-incf fun-pt)))
     (when fun-file
-      (make-text-button fun-beg
-                        (or fun-end
-                            (+ fun-beg
-                               ;; FIXME: `backtrace--print-to-string' will
-                               ;; not necessarily print FUN in the same way
-                               ;; as it did when it was in FUN-AND-ARGS!
-                               (length (backtrace--print-to-string fun))))
+      (make-text-button fun-pt (+ fun-pt
+                                  (length (backtrace--print-to-string fun)))
                         :type 'help-function-def
                         'help-args (list fun fun-file)))
     ;; After any frame that uses eval-buffer, insert a comment that
@@ -879,8 +919,6 @@ followed by `backtrace-print-frame', once for each stack frame."
   (setq-local filter-buffer-substring-function #'backtrace--filter-visible)
   (setq-local indent-line-function 'lisp-indent-line)
   (setq-local indent-region-function 'lisp-indent-region)
-  (add-function :around (local 'cl-print-expand-ellipsis-function)
-                #'backtrace--expand-ellipsis)
   (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t))
 
 (put 'backtrace-mode 'mode-class 'special)

lisp/emacs-lisp/debug.el

@@ -1,6 +1,6 @@
 ;;; debug.el --- debuggers and related commands for Emacs  -*- lexical-binding: t -*-
 
-;; Copyright (C) 1985-1986, 1994, 2001-2024 Free Software Foundation,
+;; Copyright (C) 1985-1986, 1994, 2001-2023 Free Software Foundation,
 ;; Inc.
 
 ;; Maintainer: emacs-devel@gnu.org
@@ -153,24 +153,11 @@ where CAUSE can be:
     (insert (debugger--buffer-state-content state)))
   (goto-char (debugger--buffer-state-pos state)))
 
-(defvar debugger--last-error nil)
-
-(defun debugger--duplicate-p (args)
-  (pcase args
-    (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error)))))
-
 ;;;###autoload
 (setq debugger 'debug)
 ;;;###autoload
 (defun debug (&rest args)
   "Enter debugger.  \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger.
-
-In interactive sessions, this switches to a backtrace buffer and shows
-the Lisp backtrace of function calls there.  In batch mode (more accurately,
-when `noninteractive' is non-nil), it shows the Lisp backtrace on the
-standard error stream (unless `backtrace-on-error-noninteractive' is nil),
-and then kills Emacs, causing it to exit with a negative exit code.
-
 Arguments are mainly for use when this is called from the internals
 of the evaluator.
 
@@ -181,14 +168,9 @@ first will be printed into the backtrace buffer.
 If `inhibit-redisplay' is non-nil when this function is called,
 the debugger will not be entered."
   (interactive)
-  (if (or inhibit-redisplay
-          (debugger--duplicate-p args))
-      ;; Don't really try to enter debugger within an eval from redisplay
-      ;; or if we already popper into the debugger for this error,
-      ;; which can happen when we have several nested `handler-bind's that
-      ;; want to invoke the debugger.
+  (if inhibit-redisplay
+      ;; Don't really try to enter debugger within an eval from redisplay.
       debugger-value
-    (setq debugger--last-error nil)
     (let ((non-interactive-frame
            (or noninteractive           ;FIXME: Presumably redundant.
                ;; If we're in the initial-frame (where `message' just
@@ -211,7 +193,7 @@ the debugger will not be entered."
       (let (debugger-value
 	    (debugger-previous-state
              (if (get-buffer "*Backtrace*")
-                 (with-current-buffer "*Backtrace*"
+                 (with-current-buffer (get-buffer "*Backtrace*")
                    (debugger--save-buffer-state))))
             (debugger-args args)
 	    (debugger-buffer (get-buffer-create "*Backtrace*"))
@@ -248,11 +230,12 @@ the debugger will not be entered."
 	  (unwind-protect
 	      (save-excursion
 	        (when (eq (car debugger-args) 'debug)
-		  (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))))
+		  ;; 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)))
                 (with-current-buffer debugger-buffer
                   (unless (derived-mode-p 'debugger-mode)
 	            (debugger-mode))
@@ -329,12 +312,6 @@ the debugger will not be entered."
                   (backtrace-mode))))
 	    (with-timeout-unsuspend debugger-with-timeout-suspend)
 	    (set-match-data debugger-outer-match-data)))
-	(when (eq 'error (car-safe debugger-args))
-	  ;; Remember the error we just debugged, to avoid re-entering
-          ;; the debugger if some higher-up `handler-bind' invokes us
-          ;; again, oblivious that the error was already debugged from
-          ;; a more deeply nested `handler-bind'.
-	  (setq debugger--last-error (nth 1 debugger-args)))
         (setq debug-on-next-call debugger-step-after-exit)
         debugger-value))))
 
@@ -359,10 +336,11 @@ 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
-        ;; 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))))
+  (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)))
   (when (eq (car-safe args) 'exit)
     (setq debugger-value (nth 1 args))
     (setf (cl-getf (backtrace-frame-flags (car backtrace-frames))
@@ -492,29 +470,26 @@ removes itself from that hook."
   (setq debugger-jumping-flag nil)
   (remove-hook 'post-command-hook 'debugger-reenable))
 
-(defun debugger-frame-number ()
+(defun debugger-frame-number (&optional skip-base)
   "Return number of frames in backtrace before the one point points at."
-  (let ((index (backtrace-get-index)))
+  (let ((index (backtrace-get-index))
+        (count 0))
     (unless index
       (error "This line is not a function call"))
-    ;; 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)))
+    (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)))
 
 (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 (debugger--backtrace-base))
+  (backtrace-debug (debugger-frame-number) t)
   (setf
    (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
             :debug-on-exit)
@@ -525,7 +500,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 (debugger--backtrace-base))
+  (backtrace-debug (debugger-frame-number) nil)
   (setf
    (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
             :debug-on-exit)
@@ -544,16 +519,18 @@ 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'."
-  (or (cadr (memq :backtrace-base debugger-args))
-      #'debug))
+  (cond ((eq 'debug--implement-debug-on-entry
+	     (cadr (backtrace-frame 1 'debug)))
+	 'debug--implement-debug-on-entry)
+	(t 'debug)))
 
 (defun debugger-eval-expression (exp &optional nframe)
   "Eval an expression, in an environment like that outside the debugger.
 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 (debugger-frame-number)
+                    (condition-case nil (1+ (debugger-frame-number 'skip-base))
                       (error 0)))) ;; If on first line.
 	(base (debugger--backtrace-base)))
     (debugger-env-macro
@@ -668,7 +645,7 @@ Complete list of commands:
     (princ (debugger-eval-expression exp))
     (terpri))
 
-  (with-current-buffer debugger-record-buffer
+  (with-current-buffer (get-buffer debugger-record-buffer)
     (message "%s"
 	     (buffer-substring (line-beginning-position 0)
 			       (line-end-position 0)))))
@@ -686,10 +663,7 @@ functions to break on entry."
   (if (or inhibit-debug-on-entry debugger-jumping-flag)
       nil
     (let ((inhibit-debug-on-entry t))
-      (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)))))
+      (funcall debugger 'debug))))
 
 ;;;###autoload
 (defun debug-on-entry (function)