Mercurial > hg > xemacs-beta

comparison lisp/prim/debug.el @ 70:131b0175ea99 r20-0b30

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