1;;; debug.el --- debuggers and related commands for Emacs 2 3;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: FSF 7;; Keywords: lisp, tools, maint 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; This is a major mode documented in the Emacs Lisp manual. 29 30;;; Code: 31 32(require 'button) 33 34(defgroup debugger nil 35 "Debuggers and related commands for Emacs." 36 :prefix "debugger-" 37 :group 'debug) 38 39(defcustom debugger-mode-hook nil 40 "*Hooks run when `debugger-mode' is turned on." 41 :type 'hook 42 :group 'debugger 43 :version "20.3") 44 45(defcustom debugger-batch-max-lines 40 46 "*Maximum lines to show in debugger buffer in a noninteractive Emacs. 47When the debugger is entered and Emacs is running in batch mode, 48if the backtrace text has more than this many lines, 49the middle is discarded, and just the beginning and end are displayed." 50 :type 'integer 51 :group 'debugger 52 :version "21.1") 53 54(defvar debug-function-list nil 55 "List of functions currently set for debug on entry.") 56 57(defvar debugger-step-after-exit nil 58 "Non-nil means \"single-step\" after the debugger exits.") 59 60(defvar debugger-value nil 61 "This is the value for the debugger to return, when it returns.") 62 63(defvar debugger-old-buffer nil 64 "This is the buffer that was current when the debugger was entered.") 65 66(defvar debugger-previous-backtrace nil 67 "The contents of the previous backtrace (including text properties). 68This is to optimize `debugger-make-xrefs'.") 69 70(defvar debugger-outer-match-data) 71(defvar debugger-outer-load-read-function) 72(defvar debugger-outer-overriding-local-map) 73(defvar debugger-outer-overriding-terminal-local-map) 74(defvar debugger-outer-track-mouse) 75(defvar debugger-outer-last-command) 76(defvar debugger-outer-this-command) 77;; unread-command-char is obsolete, 78;; but we still save and restore it 79;; in case some user program still tries to set it. 80(defvar debugger-outer-unread-command-char) 81(defvar debugger-outer-unread-command-events) 82(defvar debugger-outer-unread-post-input-method-events) 83(defvar debugger-outer-last-input-event) 84(defvar debugger-outer-last-command-event) 85(defvar debugger-outer-last-nonmenu-event) 86(defvar debugger-outer-last-event-frame) 87(defvar debugger-outer-standard-input) 88(defvar debugger-outer-standard-output) 89(defvar debugger-outer-inhibit-redisplay) 90(defvar debugger-outer-cursor-in-echo-area) 91(defvar debugger-will-be-back nil 92 "Non-nil if we expect to get back in the debugger soon.") 93 94(defvar inhibit-debug-on-entry nil 95 "Non-nil means that debug-on-entry is disabled.") 96 97(defvar debugger-jumping-flag nil 98 "Non-nil means that debug-on-entry is disabled. 99This variable is used by `debugger-jump', `debugger-step-through', 100and `debugger-reenable' to temporarily disable debug-on-entry.") 101 102(defvar inhibit-trace) ;Not yet implemented. 103 104;;;###autoload 105(setq debugger 'debug) 106;;;###autoload 107(defun debug (&rest debugger-args) 108 "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. 109Arguments are mainly for use when this is called from the internals 110of the evaluator. 111 112You may call with no args, or you may pass nil as the first arg and 113any other args you like. In that case, the list of args after the 114first will be printed into the backtrace buffer." 115 (interactive) 116 (if inhibit-redisplay 117 ;; Don't really try to enter debugger within an eval from redisplay. 118 debugger-value 119 (unless noninteractive 120 (message "Entering debugger...")) 121 (let (debugger-value 122 (debug-on-error nil) 123 (debug-on-quit nil) 124 (debugger-buffer (let ((default-major-mode 'fundamental-mode)) 125 (get-buffer-create "*Backtrace*"))) 126 (debugger-old-buffer (current-buffer)) 127 (debugger-step-after-exit nil) 128 (debugger-will-be-back nil) 129 ;; Don't keep reading from an executing kbd macro! 130 (executing-kbd-macro nil) 131 ;; Save the outer values of these vars for the `e' command 132 ;; before we replace the values. 133 (debugger-outer-match-data (match-data)) 134 (debugger-outer-load-read-function load-read-function) 135 (debugger-outer-overriding-local-map overriding-local-map) 136 (debugger-outer-overriding-terminal-local-map 137 overriding-terminal-local-map) 138 (debugger-outer-track-mouse track-mouse) 139 (debugger-outer-last-command last-command) 140 (debugger-outer-this-command this-command) 141 (debugger-outer-unread-command-char 142 (with-no-warnings unread-command-char)) 143 (debugger-outer-unread-command-events unread-command-events) 144 (debugger-outer-unread-post-input-method-events 145 unread-post-input-method-events) 146 (debugger-outer-last-input-event last-input-event) 147 (debugger-outer-last-command-event last-command-event) 148 (debugger-outer-last-nonmenu-event last-nonmenu-event) 149 (debugger-outer-last-event-frame last-event-frame) 150 (debugger-outer-standard-input standard-input) 151 (debugger-outer-standard-output standard-output) 152 (debugger-outer-inhibit-redisplay inhibit-redisplay) 153 (debugger-outer-cursor-in-echo-area cursor-in-echo-area) 154 (debugger-with-timeout-suspend (with-timeout-suspend))) 155 ;; Set this instead of binding it, so that `q' 156 ;; will not restore it. 157 (setq overriding-terminal-local-map nil) 158 ;; Don't let these magic variables affect the debugger itself. 159 (let ((last-command nil) this-command track-mouse 160 (inhibit-trace t) 161 (inhibit-debug-on-entry t) 162 unread-command-events 163 unread-post-input-method-events 164 last-input-event last-command-event last-nonmenu-event 165 last-event-frame 166 overriding-local-map 167 load-read-function 168 ;; If we are inside a minibuffer, allow nesting 169 ;; so that we don't get an error from the `e' command. 170 (enable-recursive-minibuffers 171 (or enable-recursive-minibuffers (> (minibuffer-depth) 0))) 172 (standard-input t) (standard-output t) 173 inhibit-redisplay 174 (cursor-in-echo-area nil)) 175 (unwind-protect 176 (save-excursion 177 (save-window-excursion 178 (with-no-warnings 179 (setq unread-command-char -1)) 180 (when (eq (car debugger-args) 'debug) 181 ;; Skip the frames for backtrace-debug, byte-code, 182 ;; and implement-debug-on-entry. 183 (backtrace-debug 4 t) 184 ;; Place an extra debug-on-exit for macro's. 185 (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) 186 (backtrace-debug 5 t))) 187 (pop-to-buffer debugger-buffer) 188 (debugger-mode) 189 (debugger-setup-buffer debugger-args) 190 (when noninteractive 191 ;; If the backtrace is long, save the beginning 192 ;; and the end, but discard the middle. 193 (when (> (count-lines (point-min) (point-max)) 194 debugger-batch-max-lines) 195 (goto-char (point-min)) 196 (forward-line (/ 2 debugger-batch-max-lines)) 197 (let ((middlestart (point))) 198 (goto-char (point-max)) 199 (forward-line (- (/ 2 debugger-batch-max-lines) 200 debugger-batch-max-lines)) 201 (delete-region middlestart (point))) 202 (insert "...\n")) 203 (goto-char (point-min)) 204 (message "%s" (buffer-string)) 205 (kill-emacs)) 206 (message "") 207 (let ((standard-output nil) 208 (buffer-read-only t)) 209 (message "") 210 ;; Make sure we unbind buffer-read-only in the right buffer. 211 (save-excursion 212 (recursive-edit))))) 213 ;; Kill or at least neuter the backtrace buffer, so that users 214 ;; don't try to execute debugger commands in an invalid context. 215 (if (get-buffer-window debugger-buffer 0) 216 ;; Still visible despite the save-window-excursion? Maybe it 217 ;; it's in a pop-up frame. It would be annoying to delete and 218 ;; recreate it every time the debugger stops, so instead we'll 219 ;; erase it (and maybe hide it) but keep it alive. 220 (with-current-buffer debugger-buffer 221 (erase-buffer) 222 (fundamental-mode) 223 (with-selected-window (get-buffer-window debugger-buffer 0) 224 (when (and (window-dedicated-p (selected-window)) 225 (not debugger-will-be-back)) 226 ;; If the window is not dedicated, burying the buffer 227 ;; will mean that the frame created for it is left 228 ;; around showing some random buffer, and next time we 229 ;; pop to the debugger buffer we'll create yet 230 ;; another frame. 231 ;; If debugger-will-be-back is non-nil, the frame 232 ;; would need to be de-iconified anyway immediately 233 ;; after when we re-enter the debugger, so iconifying it 234 ;; here would cause flashing. 235 ;; Use quit-window rather than bury-buffer to quieten 236 ;; Drew Adams. --Stef 237 (quit-window)))) 238 (kill-buffer debugger-buffer)) 239 (with-timeout-unsuspend debugger-with-timeout-suspend) 240 (set-match-data debugger-outer-match-data))) 241 ;; Put into effect the modified values of these variables 242 ;; in case the user set them with the `e' command. 243 (setq load-read-function debugger-outer-load-read-function) 244 (setq overriding-local-map debugger-outer-overriding-local-map) 245 (setq overriding-terminal-local-map 246 debugger-outer-overriding-terminal-local-map) 247 (setq track-mouse debugger-outer-track-mouse) 248 (setq last-command debugger-outer-last-command) 249 (setq this-command debugger-outer-this-command) 250 (with-no-warnings 251 (setq unread-command-char debugger-outer-unread-command-char)) 252 (setq unread-command-events debugger-outer-unread-command-events) 253 (setq unread-post-input-method-events 254 debugger-outer-unread-post-input-method-events) 255 (setq last-input-event debugger-outer-last-input-event) 256 (setq last-command-event debugger-outer-last-command-event) 257 (setq last-nonmenu-event debugger-outer-last-nonmenu-event) 258 (setq last-event-frame debugger-outer-last-event-frame) 259 (setq standard-input debugger-outer-standard-input) 260 (setq standard-output debugger-outer-standard-output) 261 (setq inhibit-redisplay debugger-outer-inhibit-redisplay) 262 (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) 263 (setq debug-on-next-call debugger-step-after-exit) 264 debugger-value))) 265 266(defun debugger-setup-buffer (debugger-args) 267 "Initialize the `*Backtrace*' buffer for entry to the debugger. 268That buffer should be current already." 269 (setq buffer-read-only nil) 270 (erase-buffer) 271 (set-buffer-multibyte nil) 272 (let ((standard-output (current-buffer)) 273 (print-escape-newlines t) 274 (print-level 8) 275 (print-length 50)) 276 (backtrace)) 277 (goto-char (point-min)) 278 (delete-region (point) 279 (progn 280 (search-forward "\n debug(") 281 (forward-line (if (eq (car debugger-args) 'debug) 282 2 ; Remove implement-debug-on-entry frame. 283 1)) 284 (point))) 285 (insert "Debugger entered") 286 ;; lambda is for debug-on-call when a function call is next. 287 ;; debug is for debug-on-entry function called. 288 (cond ((memq (car debugger-args) '(lambda debug)) 289 (insert "--entering a function:\n")) 290 ;; Exiting a function. 291 ((eq (car debugger-args) 'exit) 292 (insert "--returning value: ") 293 (setq debugger-value (nth 1 debugger-args)) 294 (prin1 debugger-value (current-buffer)) 295 (insert ?\n) 296 (delete-char 1) 297 (insert ? ) 298 (beginning-of-line)) 299 ;; Debugger entered for an error. 300 ((eq (car debugger-args) 'error) 301 (insert "--Lisp error: ") 302 (prin1 (nth 1 debugger-args) (current-buffer)) 303 (insert ?\n)) 304 ;; debug-on-call, when the next thing is an eval. 305 ((eq (car debugger-args) t) 306 (insert "--beginning evaluation of function call form:\n")) 307 ;; User calls debug directly. 308 (t 309 (insert ": ") 310 (prin1 (if (eq (car debugger-args) 'nil) 311 (cdr debugger-args) debugger-args) 312 (current-buffer)) 313 (insert ?\n))) 314 ;; After any frame that uses eval-buffer, 315 ;; insert a line that states the buffer position it's reading at. 316 (save-excursion 317 (let ((tem eval-buffer-list)) 318 (while (and tem 319 (re-search-forward "^ eval-\\(buffer\\|region\\)(" nil t)) 320 (end-of-line) 321 (insert (format " ; Reading at buffer position %d" 322 ;; This will get the wrong result 323 ;; if there are two nested eval-region calls 324 ;; for the same buffer. That's not a very useful case. 325 (with-current-buffer (car tem) 326 (point)))) 327 (pop tem)))) 328 (debugger-make-xrefs)) 329 330(defun debugger-make-xrefs (&optional buffer) 331 "Attach cross-references to function names in the `*Backtrace*' buffer." 332 (interactive "b") 333 (save-excursion 334 (set-buffer (or buffer (current-buffer))) 335 (setq buffer (current-buffer)) 336 (let ((inhibit-read-only t) 337 (old-end (point-min)) (new-end (point-min))) 338 ;; If we saved an old backtrace, find the common part 339 ;; between the new and the old. 340 ;; Compare line by line, starting from the end, 341 ;; because that's the part that is likely to be unchanged. 342 (if debugger-previous-backtrace 343 (let (old-start new-start (all-match t)) 344 (goto-char (point-max)) 345 (with-temp-buffer 346 (insert debugger-previous-backtrace) 347 (while (and all-match (not (bobp))) 348 (setq old-end (point)) 349 (forward-line -1) 350 (setq old-start (point)) 351 (with-current-buffer buffer 352 (setq new-end (point)) 353 (forward-line -1) 354 (setq new-start (point))) 355 (if (not (zerop 356 (let ((case-fold-search nil)) 357 (compare-buffer-substrings 358 (current-buffer) old-start old-end 359 buffer new-start new-end)))) 360 (setq all-match nil)))) 361 ;; Now new-end is the position of the start of the 362 ;; unchanged part in the current buffer, and old-end is 363 ;; the position of that same text in the saved old 364 ;; backtrace. But we must subtract (point-min) since strings are 365 ;; indexed in origin 0. 366 367 ;; Replace the unchanged part of the backtrace 368 ;; with the text from debugger-previous-backtrace, 369 ;; since that already has the proper xrefs. 370 ;; With this optimization, we only need to scan 371 ;; the changed part of the backtrace. 372 (delete-region new-end (point-max)) 373 (goto-char (point-max)) 374 (insert (substring debugger-previous-backtrace 375 (- old-end (point-min)))) 376 ;; Make the unchanged part of the backtrace inaccessible 377 ;; so it won't be scanned. 378 (narrow-to-region (point-min) new-end))) 379 380 ;; Scan the new part of the backtrace, inserting xrefs. 381 (goto-char (point-min)) 382 (while (progn 383 (goto-char (+ (point) 2)) 384 (skip-syntax-forward "^w_") 385 (not (eobp))) 386 (let* ((beg (point)) 387 (end (progn (skip-syntax-forward "w_") (point))) 388 (sym (intern-soft (buffer-substring-no-properties 389 beg end))) 390 (file (and sym (symbol-file sym 'defun)))) 391 (when file 392 (goto-char beg) 393 ;; help-xref-button needs to operate on something matched 394 ;; by a regexp, so set that up for it. 395 (re-search-forward "\\(\\sw\\|\\s_\\)+") 396 (help-xref-button 0 'help-function-def sym file))) 397 (forward-line 1)) 398 (widen)) 399 (setq debugger-previous-backtrace (buffer-string)))) 400 401(defun debugger-step-through () 402 "Proceed, stepping through subexpressions of this expression. 403Enter another debugger on next entry to eval, apply or funcall." 404 (interactive) 405 (setq debugger-step-after-exit t) 406 (setq debugger-jumping-flag t) 407 (setq debugger-will-be-back t) 408 (add-hook 'post-command-hook 'debugger-reenable) 409 (message "Proceeding, will debug on next eval or call.") 410 (exit-recursive-edit)) 411 412(defun debugger-continue () 413 "Continue, evaluating this expression without stopping." 414 (interactive) 415 (unless debugger-may-continue 416 (error "Cannot continue")) 417 (message "Continuing.") 418 (save-excursion 419 ;; Check to see if we've flagged some frame for debug-on-exit, in which 420 ;; case we'll probably come back to the debugger soon. 421 (goto-char (point-min)) 422 (if (re-search-forward "^\\* " nil t) 423 (setq debugger-will-be-back t))) 424 (exit-recursive-edit)) 425 426(defun debugger-return-value (val) 427 "Continue, specifying value to return. 428This is only useful when the value returned from the debugger 429will be used, such as in a debug on exit from a frame." 430 (interactive "XReturn value (evaluated): ") 431 (setq debugger-value val) 432 (princ "Returning " t) 433 (prin1 debugger-value) 434 (save-excursion 435 ;; Check to see if we've flagged some frame for debug-on-exit, in which 436 ;; case we'll probably come back to the debugger soon. 437 (goto-char (point-min)) 438 (if (re-search-forward "^\\* " nil t) 439 (setq debugger-will-be-back t))) 440 (exit-recursive-edit)) 441 442(defun debugger-jump () 443 "Continue to exit from this frame, with all debug-on-entry suspended." 444 (interactive) 445 (debugger-frame) 446 (setq debugger-jumping-flag t) 447 (add-hook 'post-command-hook 'debugger-reenable) 448 (message "Continuing through this frame") 449 (setq debugger-will-be-back t) 450 (exit-recursive-edit)) 451 452(defun debugger-reenable () 453 "Turn all debug-on-entry functions back on. 454This function is put on `post-command-hook' by `debugger-jump' and 455removes itself from that hook." 456 (setq debugger-jumping-flag nil) 457 (remove-hook 'post-command-hook 'debugger-reenable)) 458 459(defun debugger-frame-number () 460 "Return number of frames in backtrace before the one point points at." 461 (save-excursion 462 (beginning-of-line) 463 (let ((opoint (point)) 464 (count 0)) 465 (while (not (eq (cadr (backtrace-frame count)) 'debug)) 466 (setq count (1+ count))) 467 ;; Skip implement-debug-on-entry frame. 468 (when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count)))) 469 (setq count (1+ count))) 470 (goto-char (point-min)) 471 (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") 472 (goto-char (match-end 0)) 473 (forward-sexp 1)) 474 (forward-line 1) 475 (while (progn 476 (forward-char 2) 477 (if (= (following-char) ?\() 478 (forward-sexp 1) 479 (forward-sexp 2)) 480 (forward-line 1) 481 (<= (point) opoint)) 482 (if (looking-at " *;;;") 483 (forward-line 1)) 484 (setq count (1+ count))) 485 count))) 486 487(defun debugger-frame () 488 "Request entry to debugger when this frame exits. 489Applies to the frame whose line point is on in the backtrace." 490 (interactive) 491 (save-excursion 492 (beginning-of-line) 493 (if (looking-at " *;;;\\|[a-z]") 494 (error "This line is not a function call"))) 495 (beginning-of-line) 496 (backtrace-debug (debugger-frame-number) t) 497 (if (= (following-char) ? ) 498 (let ((inhibit-read-only t)) 499 (delete-char 1) 500 (insert ?*))) 501 (beginning-of-line)) 502 503(defun debugger-frame-clear () 504 "Do not enter debugger when this frame exits. 505Applies to the frame whose line point is on in the backtrace." 506 (interactive) 507 (save-excursion 508 (beginning-of-line) 509 (if (looking-at " *;;;\\|[a-z]") 510 (error "This line is not a function call"))) 511 (beginning-of-line) 512 (backtrace-debug (debugger-frame-number) nil) 513 (if (= (following-char) ?*) 514 (let ((inhibit-read-only t)) 515 (delete-char 1) 516 (insert ? ))) 517 (beginning-of-line)) 518 519(put 'debugger-env-macro 'lisp-indent-function 0) 520(defmacro debugger-env-macro (&rest body) 521 "Run BODY in original environment." 522 `(save-excursion 523 (if (null (buffer-name debugger-old-buffer)) 524 ;; old buffer deleted 525 (setq debugger-old-buffer (current-buffer))) 526 (set-buffer debugger-old-buffer) 527 (let ((load-read-function debugger-outer-load-read-function) 528 (overriding-terminal-local-map 529 debugger-outer-overriding-terminal-local-map) 530 (overriding-local-map debugger-outer-overriding-local-map) 531 (track-mouse debugger-outer-track-mouse) 532 (last-command debugger-outer-last-command) 533 (this-command debugger-outer-this-command) 534 (unread-command-events debugger-outer-unread-command-events) 535 (unread-post-input-method-events 536 debugger-outer-unread-post-input-method-events) 537 (last-input-event debugger-outer-last-input-event) 538 (last-command-event debugger-outer-last-command-event) 539 (last-nonmenu-event debugger-outer-last-nonmenu-event) 540 (last-event-frame debugger-outer-last-event-frame) 541 (standard-input debugger-outer-standard-input) 542 (standard-output debugger-outer-standard-output) 543 (inhibit-redisplay debugger-outer-inhibit-redisplay) 544 (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) 545 (set-match-data debugger-outer-match-data) 546 (prog1 547 (let ((save-ucc (with-no-warnings unread-command-char))) 548 (unwind-protect 549 (progn 550 (with-no-warnings 551 (setq unread-command-char debugger-outer-unread-command-char)) 552 (prog1 (progn ,@body) 553 (with-no-warnings 554 (setq debugger-outer-unread-command-char unread-command-char)))) 555 (with-no-warnings 556 (setq unread-command-char save-ucc)))) 557 (setq debugger-outer-match-data (match-data)) 558 (setq debugger-outer-load-read-function load-read-function) 559 (setq debugger-outer-overriding-terminal-local-map 560 overriding-terminal-local-map) 561 (setq debugger-outer-overriding-local-map overriding-local-map) 562 (setq debugger-outer-track-mouse track-mouse) 563 (setq debugger-outer-last-command last-command) 564 (setq debugger-outer-this-command this-command) 565 (setq debugger-outer-unread-command-events unread-command-events) 566 (setq debugger-outer-unread-post-input-method-events 567 unread-post-input-method-events) 568 (setq debugger-outer-last-input-event last-input-event) 569 (setq debugger-outer-last-command-event last-command-event) 570 (setq debugger-outer-last-nonmenu-event last-nonmenu-event) 571 (setq debugger-outer-last-event-frame last-event-frame) 572 (setq debugger-outer-standard-input standard-input) 573 (setq debugger-outer-standard-output standard-output) 574 (setq debugger-outer-inhibit-redisplay inhibit-redisplay) 575 (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area) 576 )))) 577 578(defun debugger-eval-expression (exp) 579 "Eval an expression, in an environment like that outside the debugger." 580 (interactive 581 (list (read-from-minibuffer "Eval: " 582 nil read-expression-map t 583 'read-expression-history))) 584 (debugger-env-macro (eval-expression exp))) 585 586(defvar debugger-mode-map 587 (let ((map (make-keymap))) 588 (set-keymap-parent map button-buffer-map) 589 (suppress-keymap map) 590 (define-key map "-" 'negative-argument) 591 (define-key map "b" 'debugger-frame) 592 (define-key map "c" 'debugger-continue) 593 (define-key map "j" 'debugger-jump) 594 (define-key map "r" 'debugger-return-value) 595 (define-key map "u" 'debugger-frame-clear) 596 (define-key map "d" 'debugger-step-through) 597 (define-key map "l" 'debugger-list-functions) 598 (define-key map "h" 'describe-mode) 599 (define-key map "q" 'top-level) 600 (define-key map "e" 'debugger-eval-expression) 601 (define-key map " " 'next-line) 602 (define-key map "R" 'debugger-record-expression) 603 (define-key map "\C-m" 'debug-help-follow) 604 (define-key map [mouse-2] 'push-button) 605 map)) 606 607(put 'debugger-mode 'mode-class 'special) 608 609(defun debugger-mode () 610 "Mode for backtrace buffers, selected in debugger. 611\\<debugger-mode-map> 612A line starts with `*' if exiting that frame will call the debugger. 613Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. 614 615When in debugger due to frame being exited, 616use the \\[debugger-return-value] command to override the value 617being returned from that frame. 618 619Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control 620which functions will enter the debugger when called. 621 622Complete list of commands: 623\\{debugger-mode-map}" 624 (kill-all-local-variables) 625 (setq major-mode 'debugger-mode) 626 (setq mode-name "Debugger") 627 (setq truncate-lines t) 628 (set-syntax-table emacs-lisp-mode-syntax-table) 629 (use-local-map debugger-mode-map) 630 (run-mode-hooks 'debugger-mode-hook)) 631 632(defcustom debugger-record-buffer "*Debugger-record*" 633 "*Buffer name for expression values, for \\[debugger-record-expression]." 634 :type 'string 635 :group 'debugger 636 :version "20.3") 637 638(defun debugger-record-expression (exp) 639 "Display a variable's value and record it in `*Backtrace-record*' buffer." 640 (interactive 641 (list (read-from-minibuffer 642 "Record Eval: " 643 nil 644 read-expression-map t 645 'read-expression-history))) 646 (let* ((buffer (get-buffer-create debugger-record-buffer)) 647 (standard-output buffer)) 648 (princ (format "Debugger Eval (%s): " exp)) 649 (princ (debugger-eval-expression exp)) 650 (terpri)) 651 652 (with-current-buffer (get-buffer debugger-record-buffer) 653 (message "%s" 654 (buffer-substring (line-beginning-position 0) 655 (line-end-position 0))))) 656 657(defun debug-help-follow (&optional pos) 658 "Follow cross-reference at POS, defaulting to point. 659 660For the cross-reference format, see `help-make-xrefs'." 661 (interactive "d") 662 (require 'help-mode) 663 ;; Ideally we'd just do (call-interactively 'help-follow) except that this 664 ;; assumes we're already in a *Help* buffer and reuses it, so it ends up 665 ;; incorrectly "reusing" the *Backtrace* buffer to show the help info. 666 (unless pos 667 (setq pos (point))) 668 (unless (push-button pos) 669 ;; check if the symbol under point is a function or variable 670 (let ((sym 671 (intern 672 (save-excursion 673 (goto-char pos) (skip-syntax-backward "w_") 674 (buffer-substring (point) 675 (progn (skip-syntax-forward "w_") 676 (point))))))) 677 (when (or (boundp sym) (fboundp sym) (facep sym)) 678 (help-xref-interned sym))))) 679 680;; When you change this, you may also need to change the number of 681;; frames that the debugger skips. 682(defun implement-debug-on-entry () 683 "Conditionally call the debugger. 684A call to this function is inserted by `debug-on-entry' to cause 685functions to break on entry." 686 (if (or inhibit-debug-on-entry debugger-jumping-flag) 687 nil 688 (funcall debugger 'debug))) 689 690(defun debugger-special-form-p (symbol) 691 "Return whether SYMBOL is a special form." 692 (and (fboundp symbol) 693 (subrp (symbol-function symbol)) 694 (eq (cdr (subr-arity (symbol-function symbol))) 'unevalled))) 695 696;;;###autoload 697(defun debug-on-entry (function) 698 "Request FUNCTION to invoke debugger each time it is called. 699 700When called interactively, prompt for FUNCTION in the minibuffer. 701 702This works by modifying the definition of FUNCTION. If you tell the 703debugger to continue, FUNCTION's execution proceeds. If FUNCTION is a 704normal function or a macro written in Lisp, you can also step through 705its execution. FUNCTION can also be a primitive that is not a special 706form, in which case stepping is not possible. Break-on-entry for 707primitive functions only works when that function is called from Lisp. 708 709Use \\[cancel-debug-on-entry] to cancel the effect of this command. 710Redefining FUNCTION also cancels it." 711 (interactive 712 (let ((fn (function-called-at-point)) val) 713 (when (debugger-special-form-p fn) 714 (setq fn nil)) 715 (setq val (completing-read 716 (if fn 717 (format "Debug on entry to function (default %s): " fn) 718 "Debug on entry to function: ") 719 obarray 720 #'(lambda (symbol) 721 (and (fboundp symbol) 722 (not (debugger-special-form-p symbol)))) 723 t nil nil (symbol-name fn))) 724 (list (if (equal val "") fn (intern val))))) 725 (when (debugger-special-form-p function) 726 (error "Function %s is a special form" function)) 727 (if (or (symbolp (symbol-function function)) 728 (subrp (symbol-function function))) 729 ;; The function is built-in or aliased to another function. 730 ;; Create a wrapper in which we can add the debug call. 731 (fset function `(lambda (&rest debug-on-entry-args) 732 ,(interactive-form (symbol-function function)) 733 (apply ',(symbol-function function) 734 debug-on-entry-args))) 735 (when (eq (car-safe (symbol-function function)) 'autoload) 736 ;; The function is autoloaded. Load its real definition. 737 (load (cadr (symbol-function function)) nil noninteractive nil t)) 738 (when (or (not (consp (symbol-function function))) 739 (and (eq (car (symbol-function function)) 'macro) 740 (not (consp (cdr (symbol-function function)))))) 741 ;; The function is byte-compiled. Create a wrapper in which 742 ;; we can add the debug call. 743 (debug-convert-byte-code function))) 744 (unless (consp (symbol-function function)) 745 (error "Definition of %s is not a list" function)) 746 (fset function (debug-on-entry-1 function t)) 747 (unless (memq function debug-function-list) 748 (push function debug-function-list)) 749 function) 750 751;;;###autoload 752(defun cancel-debug-on-entry (&optional function) 753 "Undo effect of \\[debug-on-entry] on FUNCTION. 754If FUNCTION is nil, cancel debug-on-entry for all functions. 755When called interactively, prompt for FUNCTION in the minibuffer. 756To specify a nil argument interactively, exit with an empty minibuffer." 757 (interactive 758 (list (let ((name 759 (completing-read 760 "Cancel debug on entry to function (default all functions): " 761 (mapcar 'symbol-name debug-function-list) nil t))) 762 (when name 763 (unless (string= name "") 764 (intern name)))))) 765 (if (and function 766 (not (string= function ""))) ; Pre 22.1 compatibility test. 767 (progn 768 (let ((defn (debug-on-entry-1 function nil))) 769 (condition-case nil 770 (when (and (equal (nth 1 defn) '(&rest debug-on-entry-args)) 771 (eq (car (nth 3 defn)) 'apply)) 772 ;; `defn' is a wrapper introduced in debug-on-entry. 773 ;; Get rid of it since we don't need it any more. 774 (setq defn (nth 1 (nth 1 (nth 3 defn))))) 775 (error nil)) 776 (fset function defn)) 777 (setq debug-function-list (delq function debug-function-list)) 778 function) 779 (message "Cancelling debug-on-entry for all functions") 780 (mapcar 'cancel-debug-on-entry debug-function-list))) 781 782(defun debug-convert-byte-code (function) 783 (let* ((defn (symbol-function function)) 784 (macro (eq (car-safe defn) 'macro))) 785 (when macro (setq defn (cdr defn))) 786 (unless (consp defn) 787 ;; Assume a compiled code object. 788 (let* ((contents (append defn nil)) 789 (body 790 (list (list 'byte-code (nth 1 contents) 791 (nth 2 contents) (nth 3 contents))))) 792 (if (nthcdr 5 contents) 793 (setq body (cons (list 'interactive (nth 5 contents)) body))) 794 (if (nth 4 contents) 795 ;; Use `documentation' here, to get the actual string, 796 ;; in case the compiled function has a reference 797 ;; to the .elc file. 798 (setq body (cons (documentation function) body))) 799 (setq defn (cons 'lambda (cons (car contents) body)))) 800 (when macro (setq defn (cons 'macro defn))) 801 (fset function defn)))) 802 803(defun debug-on-entry-1 (function flag) 804 (let* ((defn (symbol-function function)) 805 (tail defn)) 806 (when (eq (car-safe tail) 'macro) 807 (setq tail (cdr tail))) 808 (if (not (eq (car-safe tail) 'lambda)) 809 ;; Only signal an error when we try to set debug-on-entry. 810 ;; When we try to clear debug-on-entry, we are now done. 811 (when flag 812 (error "%s is not a user-defined Lisp function" function)) 813 (setq tail (cdr tail)) 814 ;; Skip the docstring. 815 (when (and (stringp (cadr tail)) (cddr tail)) 816 (setq tail (cdr tail))) 817 ;; Skip the interactive form. 818 (when (eq 'interactive (car-safe (cadr tail))) 819 (setq tail (cdr tail))) 820 (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry))) 821 ;; Add/remove debug statement as needed. 822 (if flag 823 (setcdr tail (cons '(implement-debug-on-entry) (cdr tail))) 824 (setcdr tail (cddr tail))))) 825 defn)) 826 827(defun debugger-list-functions () 828 "Display a list of all the functions now set to debug on entry." 829 (interactive) 830 (require 'help-mode) 831 (help-setup-xref '(debugger-list-functions) (interactive-p)) 832 (with-output-to-temp-buffer (help-buffer) 833 (with-current-buffer standard-output 834 (if (null debug-function-list) 835 (princ "No debug-on-entry functions now\n") 836 (princ "Functions set to debug on entry:\n\n") 837 (dolist (fun debug-function-list) 838 (make-text-button (point) (progn (prin1 fun) (point)) 839 'type 'help-function 840 'help-args (list fun)) 841 (terpri)) 842 (terpri) 843 (princ "Note: if you have redefined a function, then it may no longer\n") 844 (princ "be set to debug on entry, even if it is in the list."))))) 845 846(provide 'debug) 847 848;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b 849;;; debug.el ends here 850