diff options
Diffstat (limited to 'lisp/emacs-lisp/debug.el')
| -rw-r--r-- | lisp/emacs-lisp/debug.el | 390 |
1 files changed, 138 insertions, 252 deletions
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0efaa637129..707e0cfa186 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -28,6 +28,7 @@ ;;; Code: (require 'cl-lib) +(require 'backtrace) (require 'button) (defgroup debugger nil @@ -133,6 +134,25 @@ where CAUSE can be: - exit: called because of exit of a flagged function. - error: called because of `debug-on-error'.") +(cl-defstruct (debugger--buffer-state + (:constructor debugger--save-buffer-state + (&aux (mode major-mode) + (header backtrace-insert-header-function) + (frames backtrace-frames) + (content (buffer-string)) + (pos (point))))) + mode header frames content pos) + +(defun debugger--restore-buffer-state (state) + (unless (derived-mode-p (debugger--buffer-state-mode state)) + (funcall (debugger--buffer-state-mode state))) + (setq backtrace-insert-header-function (debugger--buffer-state-header state) + backtrace-frames (debugger--buffer-state-frames state)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (debugger--buffer-state-content state))) + (goto-char (debugger--buffer-state-pos state))) + ;;;###autoload (setq debugger 'debug) ;;;###autoload @@ -174,7 +194,7 @@ first will be printed into the backtrace buffer." (debugger-previous-state (if (get-buffer "*Backtrace*") (with-current-buffer (get-buffer "*Backtrace*") - (list major-mode (buffer-string))))) + (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) @@ -236,7 +256,8 @@ first will be printed into the backtrace buffer." (window-total-height debugger-window))) (error nil))) (setq debugger-previous-window debugger-window)) - (debugger-mode) + (unless (derived-mode-p 'debugger-mode) + (debugger-mode)) (debugger-setup-buffer debugger-args) (when noninteractive ;; If the backtrace is long, save the beginning @@ -280,15 +301,14 @@ first will be printed into the backtrace buffer." (setq debugger-previous-window nil)) ;; Restore previous state of debugger-buffer in case we were ;; in a recursive invocation of the debugger, otherwise just - ;; erase the buffer and put it into fundamental mode. + ;; erase the buffer. (when (buffer-live-p debugger-buffer) (with-current-buffer debugger-buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (if (null debugger-previous-state) - (fundamental-mode) - (insert (nth 1 debugger-previous-state)) - (funcall (nth 0 debugger-previous-state)))))) + (if debugger-previous-state + (debugger--restore-buffer-state debugger-previous-state) + (setq backtrace-insert-header-function nil) + (setq backtrace-frames nil) + (backtrace-print)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) (setq debug-on-next-call debugger-step-after-exit) @@ -301,112 +321,80 @@ first will be printed into the backtrace buffer." (message "Error in debug printer: %S" err) (prin1 obj stream)))) -(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)) - (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)) - (debugger--print fun) - (if args (debugger--print args) (princ "()"))) - (t - (debugger--print (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." - (setq buffer-read-only nil) - (erase-buffer) - (set-buffer-multibyte t) ;Why was it nil ? -stef - (setq buffer-undo-list t) +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))) + (when (eq (car-safe args) 'exit) + (setq debugger-value (nth 1 args)) + (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) + :debug-on-exit) + nil)) + + (setq backtrace-view '(:do-xrefs t :show-flags t) + backtrace-insert-header-function (lambda () + (debugger--insert-header args)) + backtrace-print-function debugger-print-function) + (backtrace-print) + ;; Place point on "stack frame 0" (bug#15101). + (goto-char (point-min)) + (search-forward ":" (line-end-position) t) + (when (and (< (point) (line-end-position)) + (= (char-after) ?\s)) + (forward-char))) + +(defun debugger--insert-header (args) + "Insert the header for the debugger's Backtrace buffer. +Include the reason for debugger entry from ARGS." (insert "Debugger entered") - (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) - ;; If you increase print-level, add more depth in call_debugger. - (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)))) - ;; Exiting a function. - (`exit - (insert "--returning value: ") - (setq pos (point)) - (setq debugger-value (nth 1 args)) - (debugger--print 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 - "--" - (pcase details - (`(makunbound nil) (format "making %s void" symbol)) - (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" - symbol buffer)) - (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) - (`(let ,_) (format "let-binding %s to %S" symbol newval)) - (`(unlet ,_) (format "ending let-binding of %s" symbol)) - (`(set nil) (format "setting %s to %S" symbol newval)) - (`(set ,buffer) (format "setting %s in buffer %s to %S" - symbol buffer newval)) - (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) - ": ") - (setq pos (point)) - (insert ?\n)) - ;; Debugger entered for an error. - (`error - (insert "--Lisp error: ") - (setq pos (point)) - (debugger--print (nth 1 args) (current-buffer)) - (insert ?\n)) - ;; debug-on-call, when the next thing is an eval. - (`t - (insert "--beginning evaluation of function call form:\n") - (setq pos (1- (point)))) - ;; User calls debug directly. - (_ - (insert ": ") - (setq pos (point)) - (debugger--print - (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))) + (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")) + ;; Exiting a function. + (`exit + (insert "--returning value: ") + (insert (backtrace-print-to-string debugger-value)) + (insert ?\n)) + ;; Watchpoint triggered. + ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + (`(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %s" symbol + (backtrace-print-to-string newval))) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + (`(set nil) (format "setting %s to %s" symbol + (backtrace-print-to-string newval))) + (`(set ,buffer) (format "setting %s in buffer %s to %s" + symbol buffer + (backtrace-print-to-string newval))) + (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (insert ?\n)) + ;; Debugger entered for an error. + (`error + (insert "--Lisp error: ") + (insert (backtrace-print-to-string (nth 1 args))) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + (`t + (insert "--beginning evaluation of function call form:\n")) + ;; User calls debug directly. + (_ + (insert ": ") + (insert (backtrace-print-to-string (if (eq (car args) 'nil) + (cdr args) args))) + (insert ?\n)))) (defun debugger-step-through () @@ -426,12 +414,12 @@ Enter another debugger on next entry to eval, apply or funcall." (unless debugger-may-continue (error "Cannot continue")) (message "Continuing.") - (save-excursion - ;; Check to see if we've flagged some frame for debug-on-exit, in which - ;; case we'll probably come back to the debugger soon. - (goto-char (point-min)) - (if (re-search-forward "^\\* " nil t) - (setq debugger-will-be-back t))) + + ;; Check to see if we've flagged some frame for debug-on-exit, in which + ;; case we'll probably come back to the debugger soon. + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) (exit-recursive-edit)) (defun debugger-return-value (val) @@ -446,12 +434,11 @@ will be used, such as in a debug on exit from a frame." (setq debugger-value val) (princ "Returning " t) (debugger--print debugger-value) - (save-excursion ;; Check to see if we've flagged some frame for debug-on-exit, in which ;; case we'll probably come back to the debugger soon. - (goto-char (point-min)) - (if (re-search-forward "^\\* " nil t) - (setq debugger-will-be-back t))) + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) (exit-recursive-edit)) (defun debugger-jump () @@ -473,63 +460,40 @@ removes itself from that hook." (defun debugger-frame-number (&optional skip-base) "Return number of frames in backtrace before the one point points at." - (save-excursion - (beginning-of-line) - (if (looking-at " *;;;\\|[a-z]") - (error "This line is not a function call")) - (let ((opoint (point)) - (count 0)) - (unless skip-base + (let ((index (backtrace-get-index)) + (count 0)) + (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)))) - (goto-char (point-min)) - (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") - (goto-char (match-end 0)) - (forward-sexp 1)) - (forward-line 1) - (while (progn - (forward-char 2) - (cond ((debugger--locals-visible-p) - (goto-char (next-single-char-property-change - (point) 'locals-visible))) - ((= (following-char) ?\() - (forward-sexp 1)) - (t - (forward-sexp 2))) - (forward-line 1) - (<= (point) opoint)) - (if (looking-at " *;;;") - (forward-line 1)) - (setq count (1+ count))) - 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) - (beginning-of-line) - (if (= (following-char) ? ) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ?*))) - (beginning-of-line)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + t) + (backtrace-update-flags)) (defun debugger-frame-clear () "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) - (beginning-of-line) - (if (= (following-char) ?*) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ? ))) - (beginning-of-line)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + nil) + (backtrace-update-flags)) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." @@ -564,69 +528,11 @@ The environment used is the one when entering the activation frame at point." (let ((str (eval-expression-print-format val))) (if str (princ str t)))))))) -(defun debugger--locals-visible-p () - "Are the local variables of the current stack frame visible?" - (save-excursion - (move-to-column 2) - (get-text-property (point) 'locals-visible))) - -(defun debugger--insert-locals (locals) - "Insert the local variables LOCALS at point." - (cond ((null locals) - (insert "\n [no locals]")) - (t - (let ((print-escape-newlines t)) - (dolist (s+v locals) - (let ((symbol (car s+v)) - (value (cdr s+v))) - (insert "\n ") - (prin1 symbol (current-buffer)) - (insert " = ") - (debugger--print value (current-buffer)))))))) - -(defun debugger--show-locals () - "For the frame at point, insert locals and add text properties." - (let* ((nframe (1+ (debugger-frame-number 'skip-base))) - (base (debugger--backtrace-base)) - (locals (backtrace--locals nframe base)) - (inhibit-read-only t)) - (save-excursion - (let ((start (progn - (move-to-column 2) - (point)))) - (end-of-line) - (debugger--insert-locals locals) - (add-text-properties start (point) '(locals-visible t)))))) - -(defun debugger--hide-locals () - "Delete local variables and remove the text property." - (let* ((col (current-column)) - (end (progn - (move-to-column 2) - (next-single-char-property-change (point) 'locals-visible))) - (start (previous-single-char-property-change end 'locals-visible)) - (inhibit-read-only t)) - (remove-text-properties start end '(locals-visible)) - (goto-char start) - (end-of-line) - (delete-region (point) end) - (move-to-column col))) - -(defun debugger-toggle-locals () - "Show or hide local variables of the current stack frame." - (interactive) - (cond ((debugger--locals-visible-p) - (debugger--hide-locals)) - (t - (debugger--show-locals)))) - (defvar debugger-mode-map (let ((map (make-keymap)) (menu-map (make-sparse-keymap))) - (set-keymap-parent map button-buffer-map) - (suppress-keymap map) - (define-key map "-" 'negative-argument) + (set-keymap-parent map backtrace-mode-map) (define-key map "b" 'debugger-frame) (define-key map "c" 'debugger-continue) (define-key map "j" 'debugger-jump) @@ -634,24 +540,20 @@ The environment used is the one when entering the activation frame at point." (define-key map "u" 'debugger-frame-clear) (define-key map "d" 'debugger-step-through) (define-key map "l" 'debugger-list-functions) - (define-key map "h" 'describe-mode) - (define-key map "q" 'top-level) + (define-key map "q" 'debugger-quit) (define-key map "e" 'debugger-eval-expression) - (define-key map "v" 'debugger-toggle-locals) ; "v" is for "variables". - (define-key map " " 'next-line) (define-key map "R" 'debugger-record-expression) - (define-key map "\C-m" 'debug-help-follow) (define-key map [mouse-2] 'push-button) (define-key map [menu-bar debugger] (cons "Debugger" menu-map)) (define-key menu-map [deb-top] - '(menu-item "Quit" top-level + '(menu-item "Quit" debugger-quit :help "Quit debugging and return to top level")) (define-key menu-map [deb-s0] '("--")) (define-key menu-map [deb-descr] '(menu-item "Describe Debugger Mode" describe-mode :help "Display documentation for debugger-mode")) (define-key menu-map [deb-hfol] - '(menu-item "Help Follow" debug-help-follow + '(menu-item "Help Follow" backtrace-help-follow-symbol :help "Follow cross-reference")) (define-key menu-map [deb-nxt] '(menu-item "Next Line" next-line @@ -689,8 +591,8 @@ The environment used is the one when entering the activation frame at point." (put 'debugger-mode 'mode-class 'special) -(define-derived-mode debugger-mode fundamental-mode "Debugger" - "Mode for backtrace buffers, selected in debugger. +(define-derived-mode debugger-mode backtrace-mode "Debugger" + "Mode for debugging Emacs Lisp using a backtrace. \\<debugger-mode-map> A line starts with `*' if exiting that frame will call the debugger. Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. @@ -704,8 +606,6 @@ which functions will enter the debugger when called. Complete list of commands: \\{debugger-mode-map}" - (setq truncate-lines t) - (set-syntax-table emacs-lisp-mode-syntax-table) (add-hook 'kill-buffer-hook (lambda () (if (> (recursion-depth) 0) (top-level))) nil t) @@ -732,27 +632,6 @@ Complete list of commands: (buffer-substring (line-beginning-position 0) (line-end-position 0))))) -(defun debug-help-follow (&optional pos) - "Follow cross-reference at POS, defaulting to point. - -For the cross-reference format, see `help-make-xrefs'." - (interactive "d") - ;; Ideally we'd just do (call-interactively 'help-follow) except that this - ;; assumes we're already in a *Help* buffer and reuses it, so it ends up - ;; incorrectly "reusing" the *Backtrace* buffer to show the help info. - (unless pos - (setq pos (point))) - (unless (push-button pos) - ;; check if the symbol under point is a function or variable - (let ((sym - (intern - (save-excursion - (goto-char pos) (skip-syntax-backward "w_") - (buffer-substring (point) - (progn (skip-syntax-forward "w_") - (point))))))) - (when (or (boundp sym) (fboundp sym) (facep sym)) - (describe-symbol sym))))) ;; When you change this, you may also need to change the number of ;; frames that the debugger skips. @@ -853,6 +732,13 @@ To specify a nil argument interactively, exit with an empty minibuffer." ;;(princ "be set to debug on entry, even if it is in the list.") ))))) +(defun debugger-quit () + "Quit debugging and return to the top level." + (interactive) + (if (= (recursion-depth) 0) + (quit-window) + (top-level))) + (defun debug--implement-debug-watch (symbol newval op where) "Conditionally call the debugger. This function is called when SYMBOL's value is modified." |