diff options
Diffstat (limited to 'lisp/emacs-lisp/debug.el')
| -rw-r--r-- | lisp/emacs-lisp/debug.el | 446 |
1 files changed, 255 insertions, 191 deletions
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 4ef28a7615a..472706d886b 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,7 +1,7 @@ ;;; debug.el --- debuggers and related commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: lisp, tools, maint @@ -49,6 +49,39 @@ the middle is discarded, and just the beginning and end are displayed." :group 'debugger :version "21.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 +previously showing the debugger buffer. + +`nil' means that if its window is not deleted when exiting the + debugger, invoking `switch-to-prev-buffer' will usually show + the debugger buffer again. + +`append' means that if the window is not deleted, the debugger + buffer moves to the end of the window's previous buffers so + it's less likely that a future invocation of + `switch-to-prev-buffer' will switch to it. Also, it moves the + buffer to the end of the frame's buffer list. + +`bury' means that if the window is not deleted, its buffer is + removed from the window's list of previous buffers. Also, it + moves the buffer to the end of the frame's buffer list. This + value provides the most reliable remedy to not have + `switch-to-prev-buffer' switch to the debugger buffer again + without killing the buffer. + +`kill' means to kill the debugger buffer. + +The value used here is passed to `quit-restore-window'." + :type '(choice + (const :tag "Keep alive" nil) + (const :tag "Append" append) + (const :tag "Bury" bury) + (const :tag "Kill" kill)) + :group 'debugger + :version "24.3") + (defvar debug-function-list nil "List of functions currently set for debug on entry.") @@ -61,6 +94,12 @@ the middle is discarded, and just the beginning and end are displayed." (defvar debugger-old-buffer nil "This is the buffer that was current when the debugger was entered.") +(defvar debugger-previous-window nil + "This is the window last showing the debugger buffer.") + +(defvar debugger-previous-window-height nil + "The last recorded height of `debugger-previous-window'.") + (defvar debugger-previous-backtrace nil "The contents of the previous backtrace (including text properties). This is to optimize `debugger-make-xrefs'.") @@ -72,10 +111,6 @@ This is to optimize `debugger-make-xrefs'.") (defvar debugger-outer-track-mouse) (defvar debugger-outer-last-command) (defvar debugger-outer-this-command) -;; unread-command-char is obsolete, -;; but we still save and restore it -;; in case some user program still tries to set it. -(defvar debugger-outer-unread-command-char) (defvar debugger-outer-unread-command-events) (defvar debugger-outer-unread-post-input-method-events) (defvar debugger-outer-last-input-event) @@ -99,11 +134,21 @@ and `debugger-reenable' to temporarily disable debug-on-entry.") (defvar inhibit-trace) ;Not yet implemented. +(defvar debugger-args nil + "Arguments with which the debugger was called. +It is a list expected to take the form (CAUSE . REST) +where CAUSE can be: +- debug: called for entry to a flagged function. +- t: called because of debug-on-next-call. +- lambda: same thing but via `funcall'. +- exit: called because of exit of a flagged function. +- error: called because of `debug-on-error'.") + ;;;###autoload (setq debugger 'debug) ;;;###autoload (defun debug (&rest debugger-args) - "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. + "Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger. Arguments are mainly for use when this is called from the internals of the evaluator. @@ -117,10 +162,13 @@ first will be printed into the backtrace buffer." (unless noninteractive (message "Entering debugger...")) (let (debugger-value - (debug-on-error nil) - (debug-on-quit nil) + (debugger-previous-state + (if (get-buffer "*Backtrace*") + (with-current-buffer (get-buffer "*Backtrace*") + (list major-mode (buffer-string))))) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) + (debugger-window nil) (debugger-step-after-exit nil) (debugger-will-be-back nil) ;; Don't keep reading from an executing kbd macro! @@ -135,8 +183,6 @@ first will be printed into the backtrace buffer." (debugger-outer-track-mouse track-mouse) (debugger-outer-last-command last-command) (debugger-outer-this-command this-command) - (debugger-outer-unread-command-char - (with-no-warnings unread-command-char)) (debugger-outer-unread-command-events unread-command-events) (debugger-outer-unread-post-input-method-events unread-post-input-method-events) @@ -168,72 +214,86 @@ first will be printed into the backtrace buffer." (or enable-recursive-minibuffers (> (minibuffer-depth) 0))) (standard-input t) (standard-output t) inhibit-redisplay - (cursor-in-echo-area nil)) + (cursor-in-echo-area nil) + (window-configuration (current-window-configuration))) (unwind-protect (save-excursion - (save-window-excursion - (with-no-warnings - (setq unread-command-char -1)) - (when (eq (car debugger-args) 'debug) - ;; Skip the frames for backtrace-debug, byte-code, - ;; and implement-debug-on-entry. - (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))) - (pop-to-buffer debugger-buffer) - (debugger-mode) - (debugger-setup-buffer debugger-args) - (when noninteractive - ;; If the backtrace is long, save the beginning - ;; and the end, but discard the middle. - (when (> (count-lines (point-min) (point-max)) - debugger-batch-max-lines) - (goto-char (point-min)) - (forward-line (/ 2 debugger-batch-max-lines)) - (let ((middlestart (point))) - (goto-char (point-max)) - (forward-line (- (/ 2 debugger-batch-max-lines) - debugger-batch-max-lines)) - (delete-region middlestart (point))) - (insert "...\n")) + (when (eq (car debugger-args) 'debug) + ;; Skip the frames for backtrace-debug, byte-code, + ;; and implement-debug-on-entry. + (backtrace-debug 3 t) + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 3)))) + (backtrace-debug 4 t))) + (pop-to-buffer + debugger-buffer + `((display-buffer-reuse-window + display-buffer-in-previous-window) + . (,(when debugger-previous-window + `(previous-window . ,debugger-previous-window))))) + (setq debugger-window (selected-window)) + (if (eq debugger-previous-window debugger-window) + (when debugger-jumping-flag + ;; Try to restore previous height of debugger + ;; window. + (condition-case nil + (window-resize + debugger-window + (- debugger-previous-window-height + (window-total-size debugger-window))) + (error nil))) + (setq debugger-previous-window debugger-window)) + (debugger-mode) + (debugger-setup-buffer debugger-args) + (when noninteractive + ;; If the backtrace is long, save the beginning + ;; and the end, but discard the middle. + (when (> (count-lines (point-min) (point-max)) + debugger-batch-max-lines) (goto-char (point-min)) - (message "%s" (buffer-string)) - (kill-emacs -1)) + (forward-line (/ 2 debugger-batch-max-lines)) + (let ((middlestart (point))) + (goto-char (point-max)) + (forward-line (- (/ 2 debugger-batch-max-lines) + debugger-batch-max-lines)) + (delete-region middlestart (point))) + (insert "...\n")) + (goto-char (point-min)) + (message "%s" (buffer-string)) + (kill-emacs -1)) + (message "") + (let ((standard-output nil) + (buffer-read-only t)) (message "") - (let ((standard-output nil) - (buffer-read-only t)) - (message "") - ;; Make sure we unbind buffer-read-only in the right buffer. - (save-excursion - (recursive-edit))))) - ;; Kill or at least neuter the backtrace buffer, so that users - ;; don't try to execute debugger commands in an invalid context. - (if (get-buffer-window debugger-buffer 0) - ;; Still visible despite the save-window-excursion? Maybe it - ;; it's in a pop-up frame. It would be annoying to delete and - ;; recreate it every time the debugger stops, so instead we'll - ;; erase it (and maybe hide it) but keep it alive. - (with-current-buffer debugger-buffer + ;; Make sure we unbind buffer-read-only in the right buffer. + (save-excursion + (recursive-edit)))) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + ;; Record height of debugger window. + (setq debugger-previous-window-height + (window-total-size debugger-window))) + (if debugger-will-be-back + ;; Restore previous window configuration (Bug#12623). + (set-window-configuration window-configuration) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + (progn + ;; Unshow debugger-buffer. + (quit-restore-window debugger-window debugger-bury-or-kill) + ;; Restore current buffer (Bug#12502). + (set-buffer debugger-old-buffer)))) + ;; 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. + (when (buffer-live-p debugger-buffer) + (with-current-buffer debugger-buffer + (let ((inhibit-read-only t)) (erase-buffer) - (fundamental-mode) - (with-selected-window (get-buffer-window debugger-buffer 0) - (when (and (window-dedicated-p (selected-window)) - (not debugger-will-be-back)) - ;; If the window is not dedicated, burying the buffer - ;; will mean that the frame created for it is left - ;; around showing some random buffer, and next time we - ;; pop to the debugger buffer we'll create yet - ;; another frame. - ;; If debugger-will-be-back is non-nil, the frame - ;; would need to be de-iconified anyway immediately - ;; after when we re-enter the debugger, so iconifying it - ;; here would cause flashing. - ;; Drew Adams is not happy with this: he wants to frame - ;; to be left at the top-level, still working on how - ;; best to do that. - (bury-buffer)))) - (kill-buffer debugger-buffer)) + (if (null debugger-previous-state) + (fundamental-mode) + (insert (nth 1 debugger-previous-state)) + (funcall (nth 0 debugger-previous-state)))))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) ;; Put into effect the modified values of these variables @@ -245,8 +305,6 @@ first will be printed into the backtrace buffer." (setq track-mouse debugger-outer-track-mouse) (setq last-command debugger-outer-last-command) (setq this-command debugger-outer-this-command) - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) (setq unread-command-events debugger-outer-unread-command-events) (setq unread-post-input-method-events debugger-outer-unread-post-input-method-events) @@ -284,32 +342,33 @@ That buffer should be current already." (insert "Debugger entered") ;; lambda is for debug-on-call when a function call is next. ;; debug is for debug-on-entry function called. - (cond ((memq (car debugger-args) '(lambda debug)) - (insert "--entering a function:\n")) - ;; Exiting a function. - ((eq (car debugger-args) 'exit) - (insert "--returning value: ") - (setq debugger-value (nth 1 debugger-args)) - (prin1 debugger-value (current-buffer)) - (insert ?\n) - (delete-char 1) - (insert ? ) - (beginning-of-line)) - ;; Debugger entered for an error. - ((eq (car debugger-args) 'error) - (insert "--Lisp error: ") - (prin1 (nth 1 debugger-args) (current-buffer)) - (insert ?\n)) - ;; debug-on-call, when the next thing is an eval. - ((eq (car debugger-args) t) - (insert "--beginning evaluation of function call form:\n")) - ;; User calls debug directly. - (t - (insert ": ") - (prin1 (if (eq (car debugger-args) 'nil) - (cdr debugger-args) debugger-args) - (current-buffer)) - (insert ?\n))) + (pcase (car debugger-args) + ((or `lambda `debug) + (insert "--entering a function:\n")) + ;; Exiting a function. + (`exit + (insert "--returning value: ") + (setq debugger-value (nth 1 debugger-args)) + (prin1 debugger-value (current-buffer)) + (insert ?\n) + (delete-char 1) + (insert ? ) + (beginning-of-line)) + ;; Debugger entered for an error. + (`error + (insert "--Lisp error: ") + (prin1 (nth 1 debugger-args) (current-buffer)) + (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 ": ") + (prin1 (if (eq (car debugger-args) 'nil) + (cdr debugger-args) debugger-args) + (current-buffer)) + (insert ?\n))) ;; After any frame that uses eval-buffer, ;; insert a line that states the buffer position it's reading at. (save-excursion @@ -330,71 +389,72 @@ That buffer should be current already." "Attach cross-references to function names in the `*Backtrace*' buffer." (interactive "b") (with-current-buffer (or buffer (current-buffer)) - (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)) + (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 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)))) + (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. @@ -426,6 +486,10 @@ Enter another debugger on next entry to eval, apply or funcall." This is only useful when the value returned from the debugger will be used, such as in a debug on exit from a frame." (interactive "XReturn value (evaluated): ") + (when (memq (car debugger-args) '(t lambda error debug)) + (error "Cannot return a value %s" + (if (eq (car debugger-args) 'error) + "from an error" "at function entrance"))) (setq debugger-value val) (princ "Returning " t) (prin1 debugger-value) @@ -514,9 +578,9 @@ Applies to the frame whose line point is on in the backtrace." (insert ? ))) (beginning-of-line)) -(put 'debugger-env-macro 'lisp-indent-function 0) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." + (declare (indent 0)) `(save-excursion (if (null (buffer-name debugger-old-buffer)) ;; old buffer deleted @@ -542,16 +606,7 @@ Applies to the frame whose line point is on in the backtrace." (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) (set-match-data debugger-outer-match-data) (prog1 - (let ((save-ucc (with-no-warnings unread-command-char))) - (unwind-protect - (progn - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) - (prog1 (progn ,@body) - (with-no-warnings - (setq debugger-outer-unread-command-char unread-command-char)))) - (with-no-warnings - (setq unread-command-char save-ucc)))) + (progn ,@body) (setq debugger-outer-match-data (match-data)) (setq debugger-outer-load-read-function load-read-function) (setq debugger-outer-overriding-terminal-local-map @@ -766,6 +821,7 @@ Redefining FUNCTION also cancels it." (not (debugger-special-form-p symbol)))) t nil nil (symbol-name fn))) (list (if (equal val "") fn (intern val))))) + ;; FIXME: Use advice.el. (when (debugger-special-form-p function) (error "Function %s is a special form" function)) (if (or (symbolp (symbol-function function)) @@ -776,9 +832,9 @@ Redefining FUNCTION also cancels it." ,(interactive-form (symbol-function function)) (apply ',(symbol-function function) debug-on-entry-args))) - (when (eq (car-safe (symbol-function function)) 'autoload) + (when (autoloadp (symbol-function function)) ;; The function is autoloaded. Load its real definition. - (load (cadr (symbol-function function)) nil noninteractive nil t)) + (autoload-do-load (symbol-function function) function)) (when (or (not (consp (symbol-function function))) (and (eq (car (symbol-function function)) 'macro) (not (consp (cdr (symbol-function function)))))) @@ -823,24 +879,32 @@ To specify a nil argument interactively, exit with an empty minibuffer." (message "Cancelling debug-on-entry for all functions") (mapcar 'cancel-debug-on-entry debug-function-list))) +(defun debug-arglist (definition) + ;; FIXME: copied from ad-arglist. + "Return the argument list of DEFINITION." + (require 'help-fns) + (help-function-arglist definition 'preserve-names)) + (defun debug-convert-byte-code (function) (let* ((defn (symbol-function function)) (macro (eq (car-safe defn) 'macro))) (when macro (setq defn (cdr defn))) - (unless (consp defn) - ;; Assume a compiled code object. - (let* ((contents (append defn nil)) + (when (byte-code-function-p defn) + (let* ((args (debug-arglist defn)) (body - (list (list 'byte-code (nth 1 contents) - (nth 2 contents) (nth 3 contents))))) - (if (nthcdr 5 contents) - (setq body (cons (list 'interactive (nth 5 contents)) body))) - (if (nth 4 contents) + `((,(if (memq '&rest args) #'apply #'funcall) + ,defn + ,@(remq '&rest (remq '&optional args)))))) + (if (> (length defn) 5) + ;; The mere presence of field 5 is sufficient to make + ;; it interactive. + (push `(interactive ,(aref defn 5)) body)) + (if (and (> (length defn) 4) (aref defn 4)) ;; Use `documentation' here, to get the actual string, ;; in case the compiled function has a reference ;; to the .elc file. (setq body (cons (documentation function) body))) - (setq defn (cons 'lambda (cons (car contents) body)))) + (setq defn `(closure (t) ,args ,@body))) (when macro (setq defn (cons 'macro defn))) (fset function defn)))) @@ -849,11 +913,12 @@ To specify a nil argument interactively, exit with an empty minibuffer." (tail defn)) (when (eq (car-safe tail) 'macro) (setq tail (cdr tail))) - (if (not (eq (car-safe tail) 'lambda)) + (if (not (memq (car-safe tail) '(closure lambda))) ;; Only signal an error when we try to set debug-on-entry. ;; When we try to clear debug-on-entry, we are now done. (when flag (error "%s is not a user-defined Lisp function" function)) + (if (eq (car tail) 'closure) (setq tail (cdr tail))) (setq tail (cdr tail)) ;; Skip the docstring. (when (and (stringp (cadr tail)) (cddr tail)) @@ -863,9 +928,9 @@ To specify a nil argument interactively, exit with an empty minibuffer." (setq tail (cdr tail))) (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry))) ;; Add/remove debug statement as needed. - (if flag - (setcdr tail (cons '(implement-debug-on-entry) (cdr tail))) - (setcdr tail (cddr tail))))) + (setcdr tail (if flag + (cons '(implement-debug-on-entry) (cdr tail)) + (cddr tail))))) defn)) (defun debugger-list-functions () @@ -890,5 +955,4 @@ To specify a nil argument interactively, exit with an empty minibuffer." (provide 'debug) -;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b ;;; debug.el ends here |