77 |
(defvar debugger-outer-track-mouse) |
(defvar debugger-outer-track-mouse) |
78 |
(defvar debugger-outer-last-command) |
(defvar debugger-outer-last-command) |
79 |
(defvar debugger-outer-this-command) |
(defvar debugger-outer-this-command) |
80 |
|
;; unread-command-char is obsolete, |
81 |
|
;; but we still save and restore it |
82 |
|
;; in case some user program still tries to set it. |
83 |
(defvar debugger-outer-unread-command-char) |
(defvar debugger-outer-unread-command-char) |
84 |
(defvar debugger-outer-unread-command-events) |
(defvar debugger-outer-unread-command-events) |
85 |
(defvar debugger-outer-unread-post-input-method-events) |
(defvar debugger-outer-unread-post-input-method-events) |
104 |
any other args you like. In that case, the list of args after the |
any other args you like. In that case, the list of args after the |
105 |
first will be printed into the backtrace buffer." |
first will be printed into the backtrace buffer." |
106 |
(interactive) |
(interactive) |
107 |
(unless noninteractive |
(if inhibit-redisplay |
108 |
(message "Entering debugger...")) |
;; Don't really try to enter debugger within an eval from redisplay. |
109 |
(let (debugger-value |
debugger-value |
110 |
(debug-on-error nil) |
(unless noninteractive |
111 |
(debug-on-quit nil) |
(message "Entering debugger...")) |
112 |
(debugger-buffer (let ((default-major-mode 'fundamental-mode)) |
(let (debugger-value |
113 |
(get-buffer-create "*Backtrace*"))) |
(debug-on-error nil) |
114 |
(debugger-old-buffer (current-buffer)) |
(debug-on-quit nil) |
115 |
(debugger-step-after-exit nil) |
(debugger-buffer (let ((default-major-mode 'fundamental-mode)) |
116 |
;; Don't keep reading from an executing kbd macro! |
(get-buffer-create "*Backtrace*"))) |
117 |
(executing-kbd-macro nil) |
(debugger-old-buffer (current-buffer)) |
118 |
;; Save the outer values of these vars for the `e' command |
(debugger-step-after-exit nil) |
119 |
;; before we replace the values. |
;; Don't keep reading from an executing kbd macro! |
120 |
(debugger-outer-match-data (match-data)) |
(executing-kbd-macro nil) |
121 |
(debugger-outer-load-read-function load-read-function) |
;; Save the outer values of these vars for the `e' command |
122 |
(debugger-outer-overriding-local-map overriding-local-map) |
;; before we replace the values. |
123 |
(debugger-outer-overriding-terminal-local-map |
(debugger-outer-match-data (match-data)) |
124 |
overriding-terminal-local-map) |
(debugger-outer-load-read-function load-read-function) |
125 |
(debugger-outer-track-mouse track-mouse) |
(debugger-outer-overriding-local-map overriding-local-map) |
126 |
(debugger-outer-last-command last-command) |
(debugger-outer-overriding-terminal-local-map |
127 |
(debugger-outer-this-command this-command) |
overriding-terminal-local-map) |
128 |
(debugger-outer-unread-command-char unread-command-char) |
(debugger-outer-track-mouse track-mouse) |
129 |
(debugger-outer-unread-command-events unread-command-events) |
(debugger-outer-last-command last-command) |
130 |
(debugger-outer-unread-post-input-method-events |
(debugger-outer-this-command this-command) |
131 |
unread-post-input-method-events) |
(debugger-outer-unread-command-char unread-command-char) |
132 |
(debugger-outer-last-input-event last-input-event) |
(debugger-outer-unread-command-events unread-command-events) |
133 |
(debugger-outer-last-command-event last-command-event) |
(debugger-outer-unread-post-input-method-events |
134 |
(debugger-outer-last-nonmenu-event last-nonmenu-event) |
unread-post-input-method-events) |
135 |
(debugger-outer-last-event-frame last-event-frame) |
(debugger-outer-last-input-event last-input-event) |
136 |
(debugger-outer-standard-input standard-input) |
(debugger-outer-last-command-event last-command-event) |
137 |
(debugger-outer-standard-output standard-output) |
(debugger-outer-last-nonmenu-event last-nonmenu-event) |
138 |
(debugger-outer-inhibit-redisplay inhibit-redisplay) |
(debugger-outer-last-event-frame last-event-frame) |
139 |
(debugger-outer-cursor-in-echo-area cursor-in-echo-area)) |
(debugger-outer-standard-input standard-input) |
140 |
;; Set this instead of binding it, so that `q' |
(debugger-outer-standard-output standard-output) |
141 |
;; will not restore it. |
(debugger-outer-inhibit-redisplay inhibit-redisplay) |
142 |
(setq overriding-terminal-local-map nil) |
(debugger-outer-cursor-in-echo-area cursor-in-echo-area)) |
143 |
;; Don't let these magic variables affect the debugger itself. |
;; Set this instead of binding it, so that `q' |
144 |
(let ((last-command nil) this-command track-mouse |
;; will not restore it. |
145 |
(unread-command-char -1) unread-command-events |
(setq overriding-terminal-local-map nil) |
146 |
unread-post-input-method-events |
;; Don't let these magic variables affect the debugger itself. |
147 |
last-input-event last-command-event last-nonmenu-event |
(let ((last-command nil) this-command track-mouse |
148 |
last-event-frame |
(unread-command-char -1) unread-command-events |
149 |
overriding-local-map |
unread-post-input-method-events |
150 |
load-read-function |
last-input-event last-command-event last-nonmenu-event |
151 |
;; If we are inside a minibuffer, allow nesting |
last-event-frame |
152 |
;; so that we don't get an error from the `e' command. |
overriding-local-map |
153 |
(enable-recursive-minibuffers |
load-read-function |
154 |
(or enable-recursive-minibuffers (> (minibuffer-depth) 0))) |
;; If we are inside a minibuffer, allow nesting |
155 |
(standard-input t) (standard-output t) |
;; so that we don't get an error from the `e' command. |
156 |
inhibit-redisplay |
(enable-recursive-minibuffers |
157 |
(cursor-in-echo-area nil)) |
(or enable-recursive-minibuffers (> (minibuffer-depth) 0))) |
158 |
(unwind-protect |
(standard-input t) (standard-output t) |
159 |
(save-excursion |
inhibit-redisplay |
160 |
(save-window-excursion |
(cursor-in-echo-area nil)) |
161 |
(pop-to-buffer debugger-buffer) |
(unwind-protect |
162 |
(debugger-mode) |
(save-excursion |
163 |
(debugger-setup-buffer debugger-args) |
(save-window-excursion |
164 |
(when noninteractive |
(pop-to-buffer debugger-buffer) |
165 |
;; If the backtrace is long, save the beginning |
(debugger-mode) |
166 |
;; and the end, but discard the middle. |
(debugger-setup-buffer debugger-args) |
167 |
(when (> (count-lines (point-min) (point-max)) |
(when noninteractive |
168 |
debugger-batch-max-lines) |
;; If the backtrace is long, save the beginning |
169 |
|
;; and the end, but discard the middle. |
170 |
|
(when (> (count-lines (point-min) (point-max)) |
171 |
|
debugger-batch-max-lines) |
172 |
|
(goto-char (point-min)) |
173 |
|
(forward-line (/ 2 debugger-batch-max-lines)) |
174 |
|
(let ((middlestart (point))) |
175 |
|
(goto-char (point-max)) |
176 |
|
(forward-line (- (/ 2 debugger-batch-max-lines) |
177 |
|
debugger-batch-max-lines)) |
178 |
|
(delete-region middlestart (point))) |
179 |
|
(insert "...\n")) |
180 |
(goto-char (point-min)) |
(goto-char (point-min)) |
181 |
(forward-line (/ 2 debugger-batch-max-lines)) |
(message (buffer-string)) |
182 |
(let ((middlestart (point))) |
(kill-emacs)) |
183 |
(goto-char (point-max)) |
(if (eq (car debugger-args) 'debug) |
184 |
(forward-line (- (/ 2 debugger-batch-max-lines) |
;; Skip the frames for backtrace-debug, byte-code, and debug. |
185 |
debugger-batch-max-lines)) |
(backtrace-debug 3 t)) |
186 |
(delete-region middlestart (point))) |
(debugger-reenable) |
|
(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)) |
|
187 |
(message "") |
(message "") |
188 |
;; Make sure we unbind buffer-read-only in the right buffer. |
(let ((inhibit-trace t) |
189 |
(save-excursion |
(standard-output nil) |
190 |
(recursive-edit))))) |
(buffer-read-only t)) |
191 |
;; Kill or at least neuter the backtrace buffer, so that users |
(message "") |
192 |
;; don't try to execute debugger commands in an invalid context. |
;; Make sure we unbind buffer-read-only in the right buffer. |
193 |
(if (get-buffer-window debugger-buffer 'visible) |
(save-excursion |
194 |
;; Still visible despite the save-window-excursion? Maybe it |
(recursive-edit))))) |
195 |
;; it's in a pop-up frame. It would be annoying to delete and |
;; Kill or at least neuter the backtrace buffer, so that users |
196 |
;; recreate it every time the debugger stops, so instead we'll |
;; don't try to execute debugger commands in an invalid context. |
197 |
;; erase it but leave it visible. |
(if (get-buffer-window debugger-buffer 'visible) |
198 |
(save-excursion |
;; Still visible despite the save-window-excursion? Maybe it |
199 |
(set-buffer debugger-buffer) |
;; it's in a pop-up frame. It would be annoying to delete and |
200 |
(erase-buffer) |
;; recreate it every time the debugger stops, so instead we'll |
201 |
(fundamental-mode)) |
;; erase it but leave it visible. |
202 |
(kill-buffer debugger-buffer)) |
(save-excursion |
203 |
(set-match-data debugger-outer-match-data))) |
(set-buffer debugger-buffer) |
204 |
;; Put into effect the modified values of these variables |
(erase-buffer) |
205 |
;; in case the user set them with the `e' command. |
(fundamental-mode)) |
206 |
(setq load-read-function debugger-outer-load-read-function) |
(kill-buffer debugger-buffer)) |
207 |
(setq overriding-local-map debugger-outer-overriding-local-map) |
(set-match-data debugger-outer-match-data))) |
208 |
(setq overriding-terminal-local-map |
;; Put into effect the modified values of these variables |
209 |
debugger-outer-overriding-terminal-local-map) |
;; in case the user set them with the `e' command. |
210 |
(setq track-mouse debugger-outer-track-mouse) |
(setq load-read-function debugger-outer-load-read-function) |
211 |
(setq last-command debugger-outer-last-command) |
(setq overriding-local-map debugger-outer-overriding-local-map) |
212 |
(setq this-command debugger-outer-this-command) |
(setq overriding-terminal-local-map |
213 |
(setq unread-command-char debugger-outer-unread-command-char) |
debugger-outer-overriding-terminal-local-map) |
214 |
(setq unread-command-events debugger-outer-unread-command-events) |
(setq track-mouse debugger-outer-track-mouse) |
215 |
(setq unread-post-input-method-events |
(setq last-command debugger-outer-last-command) |
216 |
debugger-outer-unread-post-input-method-events) |
(setq this-command debugger-outer-this-command) |
217 |
(setq last-input-event debugger-outer-last-input-event) |
(setq unread-command-char debugger-outer-unread-command-char) |
218 |
(setq last-command-event debugger-outer-last-command-event) |
(setq unread-command-events debugger-outer-unread-command-events) |
219 |
(setq last-nonmenu-event debugger-outer-last-nonmenu-event) |
(setq unread-post-input-method-events |
220 |
(setq last-event-frame debugger-outer-last-event-frame) |
debugger-outer-unread-post-input-method-events) |
221 |
(setq standard-input debugger-outer-standard-input) |
(setq last-input-event debugger-outer-last-input-event) |
222 |
(setq standard-output debugger-outer-standard-output) |
(setq last-command-event debugger-outer-last-command-event) |
223 |
(setq inhibit-redisplay debugger-outer-inhibit-redisplay) |
(setq last-nonmenu-event debugger-outer-last-nonmenu-event) |
224 |
(setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) |
(setq last-event-frame debugger-outer-last-event-frame) |
225 |
(setq debug-on-next-call debugger-step-after-exit) |
(setq standard-input debugger-outer-standard-input) |
226 |
debugger-value)) |
(setq standard-output debugger-outer-standard-output) |
227 |
|
(setq inhibit-redisplay debugger-outer-inhibit-redisplay) |
228 |
|
(setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) |
229 |
|
(setq debug-on-next-call debugger-step-after-exit) |
230 |
|
debugger-value))) |
231 |
|
|
232 |
(defun debugger-setup-buffer (debugger-args) |
(defun debugger-setup-buffer (debugger-args) |
233 |
"Initialize the `*Backtrace*' buffer for entry to the debugger. |
"Initialize the `*Backtrace*' buffer for entry to the debugger. |
338 |
;; Make the unchanged part of the backtrace inaccessible |
;; Make the unchanged part of the backtrace inaccessible |
339 |
;; so it won't be scanned. |
;; so it won't be scanned. |
340 |
(narrow-to-region (point-min) new-end))) |
(narrow-to-region (point-min) new-end))) |
341 |
|
|
342 |
;; Scan the new part of the backtrace, inserting xrefs. |
;; Scan the new part of the backtrace, inserting xrefs. |
343 |
(goto-char (point-min)) |
(goto-char (point-min)) |
344 |
(while (progn |
(while (progn |
617 |
(interactive "aDebug on entry (to function): ") |
(interactive "aDebug on entry (to function): ") |
618 |
(debugger-reenable) |
(debugger-reenable) |
619 |
;; Handle a function that has been aliased to some other function. |
;; Handle a function that has been aliased to some other function. |
620 |
(if (symbolp (symbol-function function)) |
(if (and (subrp (symbol-function function)) |
621 |
|
(eq (cdr (subr-arity (symbol-function function))) 'unevalled)) |
622 |
|
(error "Function %s is a special form" function)) |
623 |
|
(if (or (symbolp (symbol-function function)) |
624 |
|
(subrp (symbol-function function))) |
625 |
|
;; Create a wrapper in which we can then add the necessary debug call. |
626 |
(fset function `(lambda (&rest debug-on-entry-args) |
(fset function `(lambda (&rest debug-on-entry-args) |
627 |
|
,(interactive-form (symbol-function function)) |
628 |
(apply ',(symbol-function function) |
(apply ',(symbol-function function) |
629 |
debug-on-entry-args)))) |
debug-on-entry-args)))) |
|
(if (subrp (symbol-function function)) |
|
|
(error "Function %s is a primitive" function)) |
|
630 |
(or (consp (symbol-function function)) |
(or (consp (symbol-function function)) |
631 |
(debug-convert-byte-code function)) |
(debug-convert-byte-code function)) |
632 |
(or (consp (symbol-function function)) |
(or (consp (symbol-function function)) |
643 |
(interactive |
(interactive |
644 |
(list (let ((name |
(list (let ((name |
645 |
(completing-read "Cancel debug on entry (to function): " |
(completing-read "Cancel debug on entry (to function): " |
646 |
;; Make an "alist" of the functions |
(mapcar 'symbol-name debug-function-list) |
|
;; that now have debug on entry. |
|
|
(mapcar 'list |
|
|
(mapcar 'symbol-name |
|
|
debug-function-list)) |
|
647 |
nil t nil))) |
nil t nil))) |
648 |
(if name (intern name))))) |
(if name (intern name))))) |
649 |
(debugger-reenable) |
(debugger-reenable) |
650 |
(if (and function (not (string= function ""))) |
(if (and function (not (string= function ""))) |
651 |
(progn |
(progn |
652 |
(fset function |
(let ((f (debug-on-entry-1 function (symbol-function function) nil))) |
653 |
(debug-on-entry-1 function (symbol-function function) nil)) |
(condition-case nil |
654 |
|
(if (and (equal (nth 1 f) '(&rest debug-on-entry-args)) |
655 |
|
(eq (car (nth 3 f)) 'apply)) |
656 |
|
;; `f' is a wrapper introduced in debug-on-entry. |
657 |
|
;; Get rid of it since we don't need it any more. |
658 |
|
(setq f (nth 1 (nth 1 (nth 3 f))))) |
659 |
|
(error nil)) |
660 |
|
(fset function f)) |
661 |
(setq debug-function-list (delq function debug-function-list)) |
(setq debug-function-list (delq function debug-function-list)) |
662 |
function) |
function) |
663 |
(message "Cancelling debug-on-entry for all functions") |
(message "Cancelling debug-on-entry for all functions") |
687 |
(debug-on-entry-1 function (cdr defn) flag) |
(debug-on-entry-1 function (cdr defn) flag) |
688 |
(or (eq (car defn) 'lambda) |
(or (eq (car defn) 'lambda) |
689 |
(error "%s not user-defined Lisp function" function)) |
(error "%s not user-defined Lisp function" function)) |
690 |
(let (tail prec) |
(let ((tail (cddr defn))) |
691 |
(if (stringp (car (nthcdr 2 defn))) |
;; Skip the docstring. |
692 |
(setq tail (nthcdr 3 defn) |
(if (stringp (car tail)) (setq tail (cdr tail))) |
693 |
prec (list (car defn) (car (cdr defn)) |
;; Skip the interactive form. |
694 |
(car (cdr (cdr defn))))) |
(if (eq 'interactive (car-safe (car tail))) (setq tail (cdr tail))) |
695 |
(setq tail (nthcdr 2 defn) |
(unless (eq flag (equal (car tail) '(debug 'debug))) |
696 |
prec (list (car defn) (car (cdr defn))))) |
;; Add/remove debug statement as needed. |
697 |
(if (eq flag (equal (car tail) '(debug 'debug))) |
(if (not flag) |
698 |
defn |
(progn (setcar tail (cadr tail)) |
699 |
(if flag |
(setcdr tail (cddr tail))) |
700 |
(nconc prec (cons '(debug 'debug) tail)) |
(setcdr tail (cons (car tail) (cdr tail))) |
701 |
(nconc prec (cdr tail)))))))) |
(setcar tail '(debug 'debug)))) |
702 |
|
defn)))) |
703 |
|
|
704 |
(defun debugger-list-functions () |
(defun debugger-list-functions () |
705 |
"Display a list of all the functions now set to debug on entry." |
"Display a list of all the functions now set to debug on entry." |