;;; debug.el --- debuggers and related commands for Emacs
-;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1994, 2001, 2003, 2005
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: lisp, tools, maint
;;; Commentary:
-;; This is a major mode documented in the Emacs manual.
+;; This is a major mode documented in the Emacs Lisp manual.
;;; Code:
+(require 'button)
+
(defgroup debugger nil
"Debuggers and related commands for Emacs."
:prefix "debugger-"
:group 'debugger
:version "21.1")
-(defcustom debug-function-list nil
- "List of functions currently set for debug on entry."
- :type '(repeat function)
- :group 'debugger)
+(defvar debug-function-list nil
+ "List of functions currently set for debug on entry.")
-(defcustom debugger-step-after-exit nil
- "Non-nil means \"single-step\" after the debugger exits."
- :type 'boolean
- :group 'debugger)
+(defvar debugger-step-after-exit nil
+ "Non-nil means \"single-step\" after the debugger exits.")
(defvar debugger-value nil
"This is the value for the debugger to return, when it returns.")
(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-inhibit-redisplay)
(defvar debugger-outer-cursor-in-echo-area)
+(defvar inhibit-debug-on-entry nil
+ "Non-nil means that debug-on-entry is disabled.")
+
+(defvar debugger-jumping-flag nil
+ "Non-nil means that debug-on-entry is disabled.
+This variable is used by `debugger-jump', `debugger-step-through',
+and `debugger-reenable' to temporarily disable debug-on-entry.")
+
;;;###autoload
(setq debugger 'debug)
;;;###autoload
any other args you like. In that case, the list of args after the
first will be printed into the backtrace buffer."
(interactive)
- (unless noninteractive
- (message "Entering debugger..."))
- (let (debugger-value
- (debug-on-error nil)
- (debug-on-quit nil)
- (debugger-buffer (let ((default-major-mode 'fundamental-mode))
- (get-buffer-create "*Backtrace*")))
- (debugger-old-buffer (current-buffer))
- (debugger-step-after-exit nil)
- ;; Don't keep reading from an executing kbd macro!
- (executing-kbd-macro nil)
- ;; Save the outer values of these vars for the `e' command
- ;; before we replace the values.
- (debugger-outer-match-data (match-data))
- (debugger-outer-load-read-function load-read-function)
- (debugger-outer-overriding-local-map overriding-local-map)
- (debugger-outer-overriding-terminal-local-map
- overriding-terminal-local-map)
- (debugger-outer-track-mouse track-mouse)
- (debugger-outer-last-command last-command)
- (debugger-outer-this-command this-command)
- (debugger-outer-unread-command-char unread-command-char)
- (debugger-outer-unread-command-events unread-command-events)
- (debugger-outer-unread-post-input-method-events
- unread-post-input-method-events)
- (debugger-outer-last-input-event last-input-event)
- (debugger-outer-last-command-event last-command-event)
- (debugger-outer-last-nonmenu-event last-nonmenu-event)
- (debugger-outer-last-event-frame last-event-frame)
- (debugger-outer-standard-input standard-input)
- (debugger-outer-standard-output standard-output)
- (debugger-outer-inhibit-redisplay inhibit-redisplay)
- (debugger-outer-cursor-in-echo-area cursor-in-echo-area))
- ;; Set this instead of binding it, so that `q'
- ;; will not restore it.
- (setq overriding-terminal-local-map nil)
- ;; Don't let these magic variables affect the debugger itself.
- (let ((last-command nil) this-command track-mouse
- (unread-command-char -1) unread-command-events
- unread-post-input-method-events
- last-input-event last-command-event last-nonmenu-event
- last-event-frame
- overriding-local-map
- load-read-function
- ;; If we are inside a minibuffer, allow nesting
- ;; so that we don't get an error from the `e' command.
- (enable-recursive-minibuffers
- (or enable-recursive-minibuffers (> (minibuffer-depth) 0)))
- (standard-input t) (standard-output t)
- inhibit-redisplay
- (cursor-in-echo-area nil))
- (unwind-protect
- (save-excursion
- (save-window-excursion
- (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)
+ (if inhibit-redisplay
+ ;; Don't really try to enter debugger within an eval from redisplay.
+ debugger-value
+ (unless noninteractive
+ (message "Entering debugger..."))
+ (let (debugger-value
+ (debug-on-error nil)
+ (debug-on-quit nil)
+ (debugger-buffer (let ((default-major-mode 'fundamental-mode))
+ (get-buffer-create "*Backtrace*")))
+ (debugger-old-buffer (current-buffer))
+ (debugger-step-after-exit nil)
+ ;; Don't keep reading from an executing kbd macro!
+ (executing-kbd-macro nil)
+ ;; Save the outer values of these vars for the `e' command
+ ;; before we replace the values.
+ (debugger-outer-match-data (match-data))
+ (debugger-outer-load-read-function load-read-function)
+ (debugger-outer-overriding-local-map overriding-local-map)
+ (debugger-outer-overriding-terminal-local-map
+ overriding-terminal-local-map)
+ (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)
+ (debugger-outer-last-input-event last-input-event)
+ (debugger-outer-last-command-event last-command-event)
+ (debugger-outer-last-nonmenu-event last-nonmenu-event)
+ (debugger-outer-last-event-frame last-event-frame)
+ (debugger-outer-standard-input standard-input)
+ (debugger-outer-standard-output standard-output)
+ (debugger-outer-inhibit-redisplay inhibit-redisplay)
+ (debugger-outer-cursor-in-echo-area cursor-in-echo-area))
+ ;; Set this instead of binding it, so that `q'
+ ;; will not restore it.
+ (setq overriding-terminal-local-map nil)
+ ;; Don't let these magic variables affect the debugger itself.
+ (let ((last-command nil) this-command track-mouse
+ (inhibit-trace t)
+ (inhibit-debug-on-entry t)
+ unread-command-events
+ unread-post-input-method-events
+ last-input-event last-command-event last-nonmenu-event
+ last-event-frame
+ overriding-local-map
+ load-read-function
+ ;; If we are inside a minibuffer, allow nesting
+ ;; so that we don't get an error from the `e' command.
+ (enable-recursive-minibuffers
+ (or enable-recursive-minibuffers (> (minibuffer-depth) 0)))
+ (standard-input t) (standard-output t)
+ inhibit-redisplay
+ (cursor-in-echo-area nil))
+ (unwind-protect
+ (save-excursion
+ (save-window-excursion
+ (with-no-warnings
+ (setq unread-command-char -1))
+ (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"))
(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"))
- (goto-char (point-min))
- (message (buffer-string))
- (kill-emacs))
- (if (eq (car debugger-args) 'debug)
- ;; Skip the frames for backtrace-debug, byte-code, and debug.
- (backtrace-debug 3 t))
- (debugger-reenable)
- (message "")
- (let ((inhibit-trace t)
- (standard-output nil)
- (buffer-read-only t))
+ (message "%s" (buffer-string))
+ (kill-emacs))
+ (if (eq (car debugger-args) 'debug)
+ ;; Skip the frames for backtrace-debug, byte-code,
+ ;; and implement-debug-on-entry.
+ (backtrace-debug 4 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 'visible)
- ;; 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 but leave it visible.
- (save-excursion
- (set-buffer debugger-buffer)
- (erase-buffer)
- (fundamental-mode))
- (kill-buffer debugger-buffer))
- (set-match-data debugger-outer-match-data)))
- ;; Put into effect the modified values of these variables
- ;; in case the user set them with the `e' command.
- (setq load-read-function debugger-outer-load-read-function)
- (setq overriding-local-map debugger-outer-overriding-local-map)
- (setq overriding-terminal-local-map
- debugger-outer-overriding-terminal-local-map)
- (setq track-mouse debugger-outer-track-mouse)
- (setq last-command debugger-outer-last-command)
- (setq this-command debugger-outer-this-command)
- (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)
- (setq last-input-event debugger-outer-last-input-event)
- (setq last-command-event debugger-outer-last-command-event)
- (setq last-nonmenu-event debugger-outer-last-nonmenu-event)
- (setq last-event-frame debugger-outer-last-event-frame)
- (setq standard-input debugger-outer-standard-input)
- (setq standard-output debugger-outer-standard-output)
- (setq inhibit-redisplay debugger-outer-inhibit-redisplay)
- (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
- (setq debug-on-next-call debugger-step-after-exit)
- debugger-value))
+ (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 hide it but keep it alive.
+ (with-current-buffer debugger-buffer
+ (erase-buffer)
+ (fundamental-mode)
+ (with-selected-window (get-buffer-window debugger-buffer 0)
+ (bury-buffer)))
+ (kill-buffer debugger-buffer))
+ (set-match-data debugger-outer-match-data)))
+ ;; Put into effect the modified values of these variables
+ ;; in case the user set them with the `e' command.
+ (setq load-read-function debugger-outer-load-read-function)
+ (setq overriding-local-map debugger-outer-overriding-local-map)
+ (setq overriding-terminal-local-map
+ debugger-outer-overriding-terminal-local-map)
+ (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)
+ (setq last-input-event debugger-outer-last-input-event)
+ (setq last-command-event debugger-outer-last-command-event)
+ (setq last-nonmenu-event debugger-outer-last-nonmenu-event)
+ (setq last-event-frame debugger-outer-last-event-frame)
+ (setq standard-input debugger-outer-standard-input)
+ (setq standard-output debugger-outer-standard-output)
+ (setq inhibit-redisplay debugger-outer-inhibit-redisplay)
+ (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
+ (setq debug-on-next-call debugger-step-after-exit)
+ debugger-value)))
\f
(defun debugger-setup-buffer (debugger-args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
(delete-region (point)
(progn
(search-forward "\n debug(")
- (forward-line 1)
+ (forward-line (if (eq (car debugger-args) 'debug)
+ 2 ; Remove implement-debug-on-entry frame.
+ 1))
(point)))
(insert "Debugger entered")
;; lambda is for debug-on-call when a function call is next.
(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
+ (while (re-search-forward "^ eval-buffer(" nil t)
+ (end-of-line)
+ (insert (format "\n ;;; Reading at buffer position %d"
+ (with-current-buffer (nth 2 (backtrace-frame (debugger-frame-number)))
+ (point))))))
(debugger-make-xrefs))
(defun debugger-make-xrefs (&optional buffer)
(set-buffer (or buffer (current-buffer)))
(setq buffer (current-buffer))
(let ((buffer-read-only nil)
- (old-end 1) (new-end 1))
+ (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,
;; 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 1 since strings are
+ ;; backtrace. But we must subtract (point-min) since strings are
;; indexed in origin 0.
;; Replace the unchanged part of the backtrace
;; the changed part of the backtrace.
(delete-region new-end (point-max))
(goto-char (point-max))
- (insert (substring debugger-previous-backtrace (1- old-end)))
+ (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
(end (progn (skip-syntax-forward "w_") (point)))
(sym (intern-soft (buffer-substring-no-properties
beg end)))
- (file (and sym (symbol-file sym))))
+ (file (and sym (symbol-file sym 'defun))))
(when file
(goto-char beg)
;; help-xref-button needs to operate on something matched
Enter another debugger on next entry to eval, apply or funcall."
(interactive)
(setq debugger-step-after-exit t)
+ (setq debugger-jumping-flag t)
+ (add-hook 'post-command-hook 'debugger-reenable)
(message "Proceeding, will debug on next eval or call.")
(exit-recursive-edit))
(prin1 debugger-value)
(exit-recursive-edit))
-;; Chosen empirically to account for all the frames
-;; that will exist when debugger-frame is called
-;; within the first one that appears in the backtrace buffer.
-;; Assumes debugger-frame is called from a key;
-;; will be wrong if it is called with Meta-x.
-(defconst debugger-frame-offset 8 "")
-
(defun debugger-jump ()
"Continue to exit from this frame, with all debug-on-entry suspended."
(interactive)
- ;; Compensate for the two extra stack frames for debugger-jump.
- (let ((debugger-frame-offset (+ debugger-frame-offset 2)))
- (debugger-frame))
- ;; Turn off all debug-on-entry functions
- ;; but leave them in the list.
- (let ((list debug-function-list))
- (while list
- (fset (car list)
- (debug-on-entry-1 (car list) (symbol-function (car list)) nil))
- (setq list (cdr list))))
+ (debugger-frame)
+ (setq debugger-jumping-flag t)
+ (add-hook 'post-command-hook 'debugger-reenable)
(message "Continuing through this frame")
(exit-recursive-edit))
(defun debugger-reenable ()
- "Turn all debug-on-entry functions back on."
- (let ((list debug-function-list))
- (while list
- (or (consp (symbol-function (car list)))
- (debug-convert-byte-code (car list)))
- (fset (car list)
- (debug-on-entry-1 (car list) (symbol-function (car list)) t))
- (setq list (cdr list)))))
+ "Turn all debug-on-entry functions back on.
+This function is put on `post-command-hook' by `debugger-jump' and
+removes itself from that hook."
+ (setq debugger-jumping-flag nil)
+ (remove-hook 'post-command-hook 'debugger-reenable))
(defun debugger-frame-number ()
"Return number of frames in backtrace before the one point points at."
(beginning-of-line)
(let ((opoint (point))
(count 0))
+ (while (not (eq (cadr (backtrace-frame count)) 'debug))
+ (setq count (1+ count)))
+ ;; Skip implement-debug-on-entry frame.
+ (when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count))))
+ (setq count (1+ count)))
(goto-char (point-min))
- (if (or (equal (buffer-substring (point) (+ (point) 6))
- "Signal")
- (equal (buffer-substring (point) (+ (point) 6))
- "Return"))
- (progn
- (search-forward ":")
- (forward-sexp 1)))
+ (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)
(forward-sexp 2))
(forward-line 1)
(<= (point) opoint))
+ (if (looking-at " *;;;")
+ (forward-line 1))
(setq count (1+ count)))
count)))
"Request entry to debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at " *;;;\\|[a-z]")
+ (error "This line is not a function call")))
(beginning-of-line)
- (let ((level (debugger-frame-number)))
- (backtrace-debug (+ level debugger-frame-offset) t))
+ (backtrace-debug (debugger-frame-number) t)
(if (= (following-char) ? )
(let ((buffer-read-only nil))
(delete-char 1)
"Do not enter debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at " *;;;\\|[a-z]")
+ (error "This line is not a function call")))
(beginning-of-line)
- (let ((level (debugger-frame-number)))
- (backtrace-debug (+ level debugger-frame-offset) nil))
+ (backtrace-debug (debugger-frame-number) nil)
(if (= (following-char) ?*)
(let ((buffer-read-only nil))
(delete-char 1)
(insert ? )))
(beginning-of-line))
-
-
(put 'debugger-env-macro 'lisp-indent-function 0)
(defmacro debugger-env-macro (&rest body)
"Run BODY in original environment."
(track-mouse debugger-outer-track-mouse)
(last-command debugger-outer-last-command)
(this-command debugger-outer-this-command)
- (unread-command-char debugger-outer-unread-command-char)
(unread-command-events debugger-outer-unread-command-events)
(unread-post-input-method-events
debugger-outer-unread-post-input-method-events)
(inhibit-redisplay debugger-outer-inhibit-redisplay)
(cursor-in-echo-area debugger-outer-cursor-in-echo-area))
(set-match-data debugger-outer-match-data)
- (prog1 (progn ,@body)
+ (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))))
(setq debugger-outer-match-data (match-data))
(setq debugger-outer-load-read-function load-read-function)
(setq debugger-outer-overriding-terminal-local-map
(setq debugger-outer-track-mouse track-mouse)
(setq debugger-outer-last-command last-command)
(setq debugger-outer-this-command this-command)
- (setq debugger-outer-unread-command-char unread-command-char)
(setq debugger-outer-unread-command-events unread-command-events)
(setq debugger-outer-unread-post-input-method-events
unread-post-input-method-events)
'read-expression-history)))
(debugger-env-macro (eval-expression exp)))
\f
-(defvar debugger-mode-map nil)
-(unless debugger-mode-map
- (let ((loop ? ))
- (setq debugger-mode-map (make-keymap))
- (suppress-keymap debugger-mode-map)
- (define-key debugger-mode-map "-" 'negative-argument)
- (define-key debugger-mode-map "b" 'debugger-frame)
- (define-key debugger-mode-map "c" 'debugger-continue)
- (define-key debugger-mode-map "j" 'debugger-jump)
- (define-key debugger-mode-map "r" 'debugger-return-value)
- (define-key debugger-mode-map "u" 'debugger-frame-clear)
- (define-key debugger-mode-map "d" 'debugger-step-through)
- (define-key debugger-mode-map "l" 'debugger-list-functions)
- (define-key debugger-mode-map "h" 'describe-mode)
- (define-key debugger-mode-map "q" 'top-level)
- (define-key debugger-mode-map "e" 'debugger-eval-expression)
- (define-key debugger-mode-map " " 'next-line)
- (define-key debugger-mode-map "R" 'debugger-record-expression)
- (define-key debugger-mode-map "\C-m" 'help-follow)
- (define-key debugger-mode-map [mouse-2] 'push-button)
- ))
-
+(defvar debugger-mode-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map button-buffer-map)
+ (suppress-keymap map)
+ (define-key map "-" 'negative-argument)
+ (define-key map "b" 'debugger-frame)
+ (define-key map "c" 'debugger-continue)
+ (define-key map "j" 'debugger-jump)
+ (define-key map "r" 'debugger-return-value)
+ (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 "e" 'debugger-eval-expression)
+ (define-key map " " 'next-line)
+ (define-key map "R" 'debugger-record-expression)
+ (define-key map "\C-m" 'help-follow)
+ (define-key map [mouse-2] 'push-button)
+ map))
(defcustom debugger-record-buffer "*Debugger-record*"
"*Buffer name for expression values, for \\[debugger-record-expression]."
(setq truncate-lines t)
(set-syntax-table emacs-lisp-mode-syntax-table)
(use-local-map debugger-mode-map)
- (run-hooks 'debugger-mode-hook))
+ (run-mode-hooks 'debugger-mode-hook))
\f
+;; When you change this, you may also need to change the number of
+;; frames that the debugger skips.
+(defun implement-debug-on-entry ()
+ "Conditionally call the debugger.
+A call to this function is inserted by `debug-on-entry' to cause
+functions to break on entry."
+ (if (or inhibit-debug-on-entry debugger-jumping-flag)
+ nil
+ (funcall debugger 'debug)))
+
;;;###autoload
(defun debug-on-entry (function)
"Request FUNCTION to invoke debugger each time it is called.
Use \\[cancel-debug-on-entry] to cancel the effect of this command.
Redefining FUNCTION also cancels it."
(interactive "aDebug on entry (to function): ")
- (debugger-reenable)
;; Handle a function that has been aliased to some other function.
- (if (symbolp (symbol-function function))
+ (if (and (subrp (symbol-function function))
+ (eq (cdr (subr-arity (symbol-function function))) 'unevalled))
+ (error "Function %s is a special form" function))
+ (if (or (symbolp (symbol-function function))
+ (subrp (symbol-function function)))
+ ;; Create a wrapper in which we can then add the necessary debug call.
(fset function `(lambda (&rest debug-on-entry-args)
+ ,(interactive-form (symbol-function function))
(apply ',(symbol-function function)
debug-on-entry-args))))
- (if (subrp (symbol-function function))
- (error "Function %s is a primitive" function))
(or (consp (symbol-function function))
(debug-convert-byte-code function))
(or (consp (symbol-function function))
(error "Definition of %s is not a list" function))
- (fset function (debug-on-entry-1 function (symbol-function function) t))
+ (fset function (debug-on-entry-1 function t))
(or (memq function debug-function-list)
- (setq debug-function-list (cons function debug-function-list)))
+ (push function debug-function-list))
function)
;;;###autoload
(interactive
(list (let ((name
(completing-read "Cancel debug on entry (to function): "
- ;; Make an "alist" of the functions
- ;; that now have debug on entry.
- (mapcar 'list
- (mapcar 'symbol-name
- debug-function-list))
+ (mapcar 'symbol-name debug-function-list)
nil t nil)))
(if name (intern name)))))
- (debugger-reenable)
(if (and function (not (string= function "")))
(progn
- (fset function
- (debug-on-entry-1 function (symbol-function function) nil))
+ (let ((f (debug-on-entry-1 function nil)))
+ (condition-case nil
+ (if (and (equal (nth 1 f) '(&rest debug-on-entry-args))
+ (eq (car (nth 3 f)) 'apply))
+ ;; `f' is a wrapper introduced in debug-on-entry.
+ ;; Get rid of it since we don't need it any more.
+ (setq f (nth 1 (nth 1 (nth 3 f)))))
+ (error nil))
+ (fset function f))
(setq debug-function-list (delq function debug-function-list))
function)
(message "Cancelling debug-on-entry for all functions")
(setq body (cons (documentation function) body)))
(fset function (cons 'lambda (cons (car contents) body)))))))
-(defun debug-on-entry-1 (function defn flag)
- (if (subrp defn)
- (error "%s is a built-in function" function)
- (if (eq (car defn) 'macro)
- (debug-on-entry-1 function (cdr defn) flag)
- (or (eq (car defn) 'lambda)
- (error "%s not user-defined Lisp function" function))
- (let (tail prec)
- (if (stringp (car (nthcdr 2 defn)))
- (setq tail (nthcdr 3 defn)
- prec (list (car defn) (car (cdr defn))
- (car (cdr (cdr defn)))))
- (setq tail (nthcdr 2 defn)
- prec (list (car defn) (car (cdr defn)))))
- (if (eq flag (equal (car tail) '(debug 'debug)))
- defn
- (if flag
- (nconc prec (cons '(debug 'debug) tail))
- (nconc prec (cdr tail))))))))
+(defun debug-on-entry-1 (function flag)
+ (let* ((defn (symbol-function function))
+ (tail defn))
+ (if (subrp tail)
+ (error "%s is a built-in function" function)
+ (if (eq (car tail) 'macro) (setq tail (cdr tail)))
+ (if (eq (car tail) 'lambda) (setq tail (cdr tail))
+ (error "%s not user-defined Lisp function" function))
+ ;; Skip the docstring.
+ (when (and (stringp (cadr tail)) (cddr tail))
+ (setq tail (cdr tail)))
+ ;; Skip the interactive form.
+ (when (eq 'interactive (car-safe (cadr tail)))
+ (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))))
+ defn)))
(defun debugger-list-functions ()
"Display a list of all the functions now set to debug on entry."
(interactive)
- (with-output-to-temp-buffer "*Help*"
- (if (null debug-function-list)
- (princ "No debug-on-entry functions now\n")
- (princ "Functions set to debug on entry:\n\n")
- (let ((list debug-function-list))
- (while list
- (prin1 (car list))
- (terpri)
- (setq list (cdr list))))
- (princ "Note: if you have redefined a function, then it may no longer\n")
- (princ "be set to debug on entry, even if it is in the list."))
- (save-excursion
- (set-buffer standard-output)
- (help-mode))))
+ (require 'help-mode)
+ (help-setup-xref '(debugger-list-functions) (interactive-p))
+ (with-output-to-temp-buffer (help-buffer)
+ (with-current-buffer standard-output
+ (if (null debug-function-list)
+ (princ "No debug-on-entry functions now\n")
+ (princ "Functions set to debug on entry:\n\n")
+ (dolist (fun debug-function-list)
+ (make-text-button (point) (progn (prin1 fun) (point))
+ 'type 'help-function
+ 'help-args (list fun))
+ (terpri))
+ (terpri)
+ (princ "Note: if you have redefined a function, then it may no longer\n")
+ (princ "be set to debug on entry, even if it is in the list.")))))
(provide 'debug)
+;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b
;;; debug.el ends here