Mercurial > hg > xemacs-beta

comparison lisp/prim/debug.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details. 18 ;; General Public License for more details.
19 19
20 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 23 ;; 02111-1307, USA.
24 ;;; Synched up with: FSF 19.30. 24
25 ;;; Synched up with: FSF 19.34.
26
27 ;;; Commentary:
28
29 ;; NB: There are lots of formatting changes in the XEmacs version. -sb
30
31 ;; This is a major mode documented in the Emacs manual.
25 32
26 ;;; Code: 33 ;;; Code:
27 34
28 (defvar debug-function-list nil 35 (defvar debug-function-list nil
29 "List of functions currently set for debug on entry.") 36 "List of functions currently set for debug on entry.")
44 (defvar debugger-outer-overriding-local-map) 51 (defvar debugger-outer-overriding-local-map)
45 ;; FSFmacs (defvar debugger-outer-track-mouse) 52 ;; FSFmacs (defvar debugger-outer-track-mouse)
46 (defvar debugger-outer-last-command) 53 (defvar debugger-outer-last-command)
47 (defvar debugger-outer-this-command) 54 (defvar debugger-outer-this-command)
48 (defvar debugger-outer-unread-command-event) 55 (defvar debugger-outer-unread-command-event)
56 ;; FSF: (defvar debugger-outer-unread-command-char)
57 (defvar debugger-outer-unread-command-events)
49 (defvar debugger-outer-last-input-event) 58 (defvar debugger-outer-last-input-event)
50 (defvar debugger-outer-last-input-char) 59 (defvar debugger-outer-last-input-char)
51 (defvar debugger-outer-last-input-time) 60 (defvar debugger-outer-last-input-time)
52 (defvar debugger-outer-last-command-event) 61 (defvar debugger-outer-last-command-event)
62 ;; (defvar debugger-outer-last-nonmenu-event)
63 ;; (defvar debugger-outer-last-event-frame)
53 (defvar debugger-outer-last-command-char) 64 (defvar debugger-outer-last-command-char)
54 (defvar debugger-outer-standard-input) 65 (defvar debugger-outer-standard-input)
55 (defvar debugger-outer-standard-output) 66 (defvar debugger-outer-standard-output)
56 (defvar debugger-outer-cursor-in-echo-area) 67 (defvar debugger-outer-cursor-in-echo-area)
57 68
63 (defvar debugger-value) 74 (defvar debugger-value)
64 75
65 ;;;###autoload 76 ;;;###autoload
66 (defun debug (&rest debugger-args) 77 (defun debug (&rest debugger-args)
67 "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. 78 "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'.
68 Arguments are mainly for use when this is called 79 Arguments are mainly for use when this is called from the internals
69 from the internals of the evaluator. 80 of the evaluator.
70 You may call with no args, or you may 81
71 pass nil as the first arg and any other args you like. 82 You may call with no args, or you may pass nil as the first arg and
72 In that case, the list of args after the first will 83 any other args you like. In that case, the list of args after the
73 be printed into the backtrace buffer." 84 first will be printed into the backtrace buffer."
74 (interactive) 85 (interactive)
75 ;; XEmacs: it doesn't work to enter the debugger non-interactively 86 ;; XEmacs: it doesn't work to enter the debugger non-interactively
76 ;; so just print out a backtrace and exit. 87 ;; so just print out a backtrace and exit.
77 (if (noninteractive) (apply 'early-error-handler debugger-args)) 88 (if (noninteractive) (apply 'early-error-handler debugger-args))
78 (message "Entering debugger...") 89 (message "Entering debugger...")
79 (let (debugger-value 90 (let (debugger-value
80 (debug-on-error nil) 91 (debug-on-error nil)
81 (debug-on-quit nil) 92 (debug-on-quit nil)
82 (debug-on-signal nil) 93 (debug-on-signal nil) ; XEmacs
83 (debugger-buffer (let ((default-major-mode 'fundamental-mode)) 94 (debugger-buffer (let ((default-major-mode 'fundamental-mode))
84 (get-buffer-create "*Backtrace*"))) 95 (get-buffer-create "*Backtrace*")))
85 ;; #### I18N3 set the debugger-buffer to output-translating 96 ;; #### I18N3 set the debugger-buffer to output-translating
86 (debugger-old-buffer (current-buffer)) 97 (debugger-old-buffer (current-buffer))
87 (debugger-step-after-exit nil) 98 (debugger-step-after-exit nil)
88 ;; Don't keep reading from an executing kbd macro! 99 ;; Don't keep reading from an executing kbd macro!
89 (executing-macro nil) 100 (executing-macro nil)
90 ;; Save the outer values of these vars for the `e' command 101 ;; Save the outer values of these vars for the `e' command
91 ;; before we replace the values. 102 ;; before we replace the values.
92 (debugger-outer-match-data (match-data)) 103 (debugger-outer-match-data (match-data))
93 (debugger-outer-load-read-function load-read-function) 104 (debugger-outer-load-read-function load-read-function)
94 (debugger-outer-overriding-local-map overriding-local-map) 105 (debugger-outer-overriding-local-map overriding-local-map)
95 ;; FSFmacs (debugger-outer-track-mouse track-mouse) 106 ;; FSFmacs (debugger-outer-track-mouse track-mouse)
96 (debugger-outer-last-command last-command) 107 (debugger-outer-last-command last-command)
97 (debugger-outer-this-command this-command) 108 (debugger-outer-this-command this-command)
98 (debugger-outer-unread-command-event unread-command-event) 109 (debugger-outer-unread-command-event unread-command-event)
99 (debugger-outer-last-input-event last-input-event) 110 (debugger-outer-unread-command-events unread-command-events)
100 (debugger-outer-last-input-char last-input-char) 111 (debugger-outer-last-input-event last-input-event)
101 (debugger-outer-last-input-time last-input-time) 112 (debugger-outer-last-input-char last-input-char)
102 (debugger-outer-last-command-event last-command-event) 113 (debugger-outer-last-input-time last-input-time)
103 (debugger-outer-last-command-char last-command-char) 114 (debugger-outer-last-command-event last-command-event)
104 (debugger-outer-standard-input standard-input) 115 (debugger-outer-last-command-char last-command-char)
105 (debugger-outer-standard-output standard-output) 116 (debugger-outer-standard-input standard-input)
106 (debugger-outer-cursor-in-echo-area cursor-in-echo-area) 117 (debugger-outer-standard-output standard-output)
107 ) 118 (debugger-outer-cursor-in-echo-area cursor-in-echo-area))
108 ;; Don't let these magic variables affect the debugger itself. 119 ;; Don't let these magic variables affect the debugger itself.
109 (unwind-protect ;XEmacs change 120 (unwind-protect ;XEmacs change
110 (let ((last-command nil) 121 (let ((last-command nil)
111 (this-command nil) 122 (this-command nil)
112 (unread-command-event nil) 123 (unread-command-event nil)
130 (backtrace)) 141 (backtrace))
131 (goto-char (point-min)) 142 (goto-char (point-min))
132 (debugger-mode) 143 (debugger-mode)
133 (delete-region (point) 144 (delete-region (point)
134 (progn 145 (progn
146 ;; XEmacs change
135 (re-search-forward "\n[* ] debug(") 147 (re-search-forward "\n[* ] debug(")
136 (forward-line 1) 148 (forward-line 1)
137 (point))) 149 (point)))
150 (debugger-reenable)
138 ;; lambda is for debug-on-call when a function call is next. 151 ;; lambda is for debug-on-call when a function call is next.
139 ;; debug is for debug-on-entry function called. 152 ;; debug is for debug-on-entry function called.
140 (debugger-reenable)
141 (cond ((memq (car debugger-args) '(lambda debug)) 153 (cond ((memq (car debugger-args) '(lambda debug))
142 (insert "Entering:\n") 154 (insert "Entering:\n")
143 (if (eq (car debugger-args) 'debug) 155 (if (eq (car debugger-args) 'debug)
144 (progn 156 (progn
145 ;; Skip the frames for backtrace-debug, byte-code, 157 ;; Skip the frames for backtrace-debug, byte-code,
157 (delete-char 1) 169 (delete-char 1)
158 (insert ? ) 170 (insert ? )
159 (beginning-of-line)) 171 (beginning-of-line))
160 ;; Debugger entered for an error. 172 ;; Debugger entered for an error.
161 ((eq (car debugger-args) 'error) 173 ((eq (car debugger-args) 'error)
162 (insert "Signalling: ") 174 (insert "Signaling: ")
163 (prin1 (nth 1 debugger-args) (current-buffer)) 175 (prin1 (nth 1 debugger-args) (current-buffer))
164 (insert ?\n)) 176 (insert ?\n))
165 ;; debug-on-call, when the next thing is an eval. 177 ;; debug-on-call, when the next thing is an eval.
166 ((eq (car debugger-args) t) 178 ((eq (car debugger-args) t)
167 (insert 179 (insert "Beginning evaluation of function call form:\n"))
168 "Beginning evaluation of function call form:\n"))
169 ;; User calls debug directly. 180 ;; User calls debug directly.
170 (t 181 (t
171 (prin1 (if (eq (car debugger-args) 'nil) 182 (prin1 (if (eq (car debugger-args) 'nil)
172 (cdr debugger-args) debugger-args) 183 (cdr debugger-args) debugger-args)
173 (current-buffer)) 184 (current-buffer))
174 (insert ?\n))) 185 (insert ?\n)))
175 (message "") 186 (message "")
176 (let ((inhibit-trace t) 187 (let ((inhibit-trace t)
177 (standard-output nil) 188 (standard-output nil)
178 (buffer-read-only t)) 189 (buffer-read-only t))
179 (message nil) 190 (message "")
180 (recursive-edit))) 191 (recursive-edit)))
192 ;; XEmacs change
181 debugger-value)) 193 debugger-value))
182 ;; Kill or at least neuter the backtrace buffer, so that users 194 ;; Kill or at least neuter the backtrace buffer, so that users
183 ;; don't try to execute debugger commands in an invalid context. 195 ;; don't try to execute debugger commands in an invalid context.
184 (if (get-buffer-window debugger-buffer 'visible) 196 (if (get-buffer-window debugger-buffer 'visible)
185 ;; Still visible despite the save-window-excursion? Maybe it 197 ;; Still visible despite the save-window-excursion? Maybe it
186 ;; it's in a pop-up frame. It would be annoying to delete and 198 ;; it's in a pop-up frame. It would be annoying to delete and
187 ;; recreate it every time the debugger stops, so instead we'll 199 ;; recreate it every time the debugger stops, so instead we'll
188 ;; erase it but leave it visible. 200 ;; erase it but leave it visible.
198 (setq overriding-local-map debugger-outer-overriding-local-map) 210 (setq overriding-local-map debugger-outer-overriding-local-map)
199 ;; FSFmacs (setq track-mouse debugger-outer-track-mouse) 211 ;; FSFmacs (setq track-mouse debugger-outer-track-mouse)
200 (setq last-command debugger-outer-last-command) 212 (setq last-command debugger-outer-last-command)
201 (setq this-command debugger-outer-this-command) 213 (setq this-command debugger-outer-this-command)
202 (setq unread-command-event debugger-outer-unread-command-event) 214 (setq unread-command-event debugger-outer-unread-command-event)
215 (setq unread-command-event debugger-outer-unread-command-events)
203 (setq last-input-event debugger-outer-last-input-event) 216 (setq last-input-event debugger-outer-last-input-event)
204 (setq last-input-char debugger-outer-last-input-char) 217 (setq last-input-char debugger-outer-last-input-char)
205 (setq last-input-time debugger-outer-last-input-time) 218 (setq last-input-time debugger-outer-last-input-time)
206 (setq last-command-event debugger-outer-last-command-event) 219 (setq last-command-event debugger-outer-last-command-event)
207 (setq last-command-char debugger-outer-last-command-char) 220 (setq last-command-char debugger-outer-last-command-char)
209 (setq standard-output debugger-outer-standard-output) 222 (setq standard-output debugger-outer-standard-output)
210 (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) 223 (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
211 (setq debug-on-next-call debugger-step-after-exit) ;do this last! 224 (setq debug-on-next-call debugger-step-after-exit) ;do this last!
212 ))) 225 )))
213 226
214 227 ;; XEmacs
215 (defun debugger-exit () 228 (defun debugger-exit ()
216 (condition-case nil 229 (condition-case nil
217 (let ((debug-on-error nil) 230 (let ((debug-on-error nil)
218 (debug-on-signal nil)) 231 (debug-on-signal nil))
219 ;; Tell signal to keep searching for handlers 232 ;; Tell signal to keep searching for handlers
226 "Proceed, stepping through subexpressions of this expression. 239 "Proceed, stepping through subexpressions of this expression.
227 Enter another debugger on next entry to eval, apply or funcall." 240 Enter another debugger on next entry to eval, apply or funcall."
228 (interactive) 241 (interactive)
229 (setq debugger-step-after-exit t) 242 (setq debugger-step-after-exit t)
230 (message "Proceeding, will debug on next eval or call.") 243 (message "Proceeding, will debug on next eval or call.")
244 ;; XEmacs
231 (debugger-exit)) 245 (debugger-exit))
232 246
233 (defun debugger-continue () 247 (defun debugger-continue ()
234 "Continue, evaluating this expression without stopping." 248 "Continue, evaluating this expression without stopping."
235 (interactive) 249 (interactive)
236 (message "Continuing.") 250 (message "Continuing.")
251 ;; XEmacs
237 (debugger-exit)) 252 (debugger-exit))
238 253
239 (defun debugger-return-value (val) 254 (defun debugger-return-value (val)
240 "Continue, specifying value to return. 255 "Continue, specifying value to return.
241 This is only useful when the value returned from the debugger 256 This is only useful when the value returned from the debugger
244 (setq debugger-value val) 259 (setq debugger-value val)
245 (princ "Returning " t) 260 (princ "Returning " t)
246 (prin1 debugger-value) 261 (prin1 debugger-value)
247 (exit-recursive-edit)) 262 (exit-recursive-edit))
248 263
264 ;; XEmacs: [Moved block]
249 ;; Chosen empirically to account for all the frames 265 ;; Chosen empirically to account for all the frames
250 ;; that will exist when debugger-frame is called 266 ;; that will exist when debugger-frame is called
251 ;; within the first one that appears in the backtrace buffer. 267 ;; within the first one that appears in the backtrace buffer.
252 ;; Assumes debugger-frame is called from a key; 268 ;; Assumes debugger-frame is called from a key;
253 ;; will be wrong if it is called with Meta-x. 269 ;; will be wrong if it is called with Meta-x.
284 (save-excursion 300 (save-excursion
285 (beginning-of-line) 301 (beginning-of-line)
286 (let ((opoint (point)) 302 (let ((opoint (point))
287 (count 0)) 303 (count 0))
288 (goto-char (point-min)) 304 (goto-char (point-min))
289 ;; #### I18N3 will not localize properly! 305 ;; XEmacs:#### I18N3 will not localize properly!
290 (if (or (equal (buffer-substring (point) (+ (point) 6)) 306 (if (or (equal (buffer-substring (point) (+ (point) 6))
291 (gettext "Signal")) 307 (gettext "Signal"))
292 (equal (buffer-substring (point) (+ (point) 6)) 308 (equal (buffer-substring (point) (+ (point) 6))
293 (gettext "Return"))) 309 (gettext "Return")))
294 (progn 310 (progn
341 (if (null (buffer-name debugger-old-buffer)) 357 (if (null (buffer-name debugger-old-buffer))
342 ;; old buffer deleted 358 ;; old buffer deleted
343 (setq debugger-old-buffer (current-buffer))) 359 (setq debugger-old-buffer (current-buffer)))
344 (set-buffer debugger-old-buffer) 360 (set-buffer debugger-old-buffer)
345 (let ((last-command debugger-outer-last-command) 361 (let ((last-command debugger-outer-last-command)
346 (this-command debugger-outer-this-command) 362 (this-command debugger-outer-this-command)
347 (unread-command-event debugger-outer-unread-command-event) 363 (unread-command-event debugger-outer-unread-command-event)
348 (last-input-event debugger-outer-last-input-event) 364 (unread-command-event debugger-outer-unread-command-events)
349 (last-input-char debugger-outer-last-input-char) 365 (last-input-event debugger-outer-last-input-event)
350 (last-input-time debugger-outer-last-input-time) 366 (last-input-char debugger-outer-last-input-char)
351 (last-command-event debugger-outer-last-command-event) 367 (last-input-time debugger-outer-last-input-time)
352 (last-command-char debugger-outer-last-command-char) 368 (last-command-event debugger-outer-last-command-event)
353 (standard-input debugger-outer-standard-input) 369 (last-command-char debugger-outer-last-command-char)
354 (standard-output debugger-outer-standard-output) 370 (standard-input debugger-outer-standard-input)
371 (standard-output debugger-outer-standard-output)
355 (cursor-in-echo-area debugger-outer-cursor-in-echo-area) 372 (cursor-in-echo-area debugger-outer-cursor-in-echo-area)
356 (overriding-local-map debugger-outer-overriding-local-map) 373 (overriding-local-map debugger-outer-overriding-local-map)
357 (load-read-function debugger-outer-load-read-function)) 374 (load-read-function debugger-outer-load-read-function))
358 (store-match-data debugger-outer-match-data) 375 (store-match-data debugger-outer-match-data)
359 (prog1 (eval-expression debugger-exp) 376 (prog1 (eval-expression debugger-exp)
370 debugger-outer-last-command-char last-command-char 387 debugger-outer-last-command-char last-command-char
371 debugger-outer-standard-input standard-input 388 debugger-outer-standard-input standard-input
372 debugger-outer-standard-output standard-output 389 debugger-outer-standard-output standard-output
373 debugger-outer-cursor-in-echo-area cursor-in-echo-area))))) 390 debugger-outer-cursor-in-echo-area cursor-in-echo-area)))))
374 391
375 (defvar debugger-mode-map 392 (defvar debugger-mode-map nil)
376 (let ((map (make-keymap))) 393 (if debugger-mode-map
377 (set-keymap-name map 'debugger-mode-map) 394 nil
378 (suppress-keymap map) 395 (let ((loop ? ))
379 (define-key map "-" 'negative-argument) 396 (setq debugger-mode-map (make-keymap))
380 (define-key map "b" 'debugger-frame) 397 (suppress-keymap debugger-mode-map)
381 (define-key map "c" 'debugger-continue) 398 (define-key debugger-mode-map "-" 'negative-argument)
382 (define-key map "j" 'debugger-jump) 399 (define-key debugger-mode-map "b" 'debugger-frame)
383 (define-key map "r" 'debugger-return-value) 400 (define-key debugger-mode-map "c" 'debugger-continue)
384 (define-key map "u" 'debugger-frame-clear) 401 (define-key debugger-mode-map "j" 'debugger-jump)
385 (define-key map "d" 'debugger-step-through) 402 (define-key debugger-mode-map "r" 'debugger-return-value)
386 (define-key map "l" 'debugger-list-functions) 403 (define-key debugger-mode-map "u" 'debugger-frame-clear)
387 (define-key map "h" 'describe-mode) 404 (define-key debugger-mode-map "d" 'debugger-step-through)
388 (define-key map "q" 'top-level) 405 (define-key debugger-mode-map "l" 'debugger-list-functions)
389 (define-key map "e" 'debugger-eval-expression) 406 (define-key debugger-mode-map "h" 'describe-mode)
390 (define-key map " " 'next-line) 407 (define-key debugger-mode-map "q" 'top-level)
391 map)) 408 (define-key debugger-mode-map "e" 'debugger-eval-expression)
409 (define-key debugger-mode-map " " 'next-line)))
392 410
393 (put 'debugger-mode 'mode-class 'special) 411 (put 'debugger-mode 'mode-class 'special)
394 412
395 (defun debugger-mode () 413 (defun debugger-mode ()
396 "Mode for backtrace buffers, selected in debugger. 414 "Mode for backtrace buffers, selected in debugger.
407 425
408 Complete list of commands: 426 Complete list of commands:
409 \\{debugger-mode-map}" 427 \\{debugger-mode-map}"
410 (kill-all-local-variables) 428 (kill-all-local-variables)
411 (setq major-mode 'debugger-mode) 429 (setq major-mode 'debugger-mode)
412 (setq mode-name (gettext "Debugger")) 430 (setq mode-name (gettext "Debugger")) ; XEmacs
413 (setq truncate-lines t) 431 (setq truncate-lines t)
414 (set-syntax-table emacs-lisp-mode-syntax-table) 432 (set-syntax-table emacs-lisp-mode-syntax-table)
415 (use-local-map debugger-mode-map)) 433 (use-local-map debugger-mode-map))
416 434
417 ;;;###autoload 435 ;;;###autoload
439 (defun cancel-debug-on-entry (&optional function) 457 (defun cancel-debug-on-entry (&optional function)
440 "Undo effect of \\[debug-on-entry] on FUNCTION. 458 "Undo effect of \\[debug-on-entry] on FUNCTION.
441 If argument is nil or an empty string, cancel for all functions." 459 If argument is nil or an empty string, cancel for all functions."
442 (interactive 460 (interactive
443 (list (let ((name 461 (list (let ((name
444 (completing-read "Cancel debug on entry (to function): " 462 (completing-read "Cancel debug on entry (to function): "
445 ;; Make an "alist" of the functions 463 ;; Make an "alist" of the functions
446 ;; that now have debug on entry. 464 ;; that now have debug on entry.
447 (mapcar 'list (mapcar 'symbol-name 465 (mapcar 'list
448 debug-function-list)) 466 (mapcar 'symbol-name
467 debug-function-list))
449 nil t nil))) 468 nil t nil)))
450 (if name (intern name))))) 469 (if name (intern name)))))
451 (debugger-reenable) 470 (debugger-reenable)
452 (if (and function (not (string= function ""))) 471 (if (and function (not (string= function "")))
453 (progn 472 (progn
483 (or (eq (car defn) 'lambda) 502 (or (eq (car defn) 'lambda)
484 (error "%s not user-defined Lisp function" function)) 503 (error "%s not user-defined Lisp function" function))
485 (let (tail prec) 504 (let (tail prec)
486 (if (stringp (car (nthcdr 2 defn))) 505 (if (stringp (car (nthcdr 2 defn)))
487 (setq tail (nthcdr 3 defn) 506 (setq tail (nthcdr 3 defn)
488 prec (list (car defn) (car (cdr defn)) (car (cdr (cdr defn))))) 507 prec (list (car defn) (car (cdr defn))
508 (car (cdr (cdr defn)))))
489 (setq tail (nthcdr 2 defn) 509 (setq tail (nthcdr 2 defn)
490 prec (list (car defn) (car (cdr defn))))) 510 prec (list (car defn) (car (cdr defn)))))
491 (if (eq flag (equal (car tail) '(debug 'debug))) 511 (if (eq flag (equal (car tail) '(debug 'debug)))
492 defn 512 defn
493 (if flag 513 (if flag