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