1;;; debug.el --- debuggers and related commands for Emacs 2 3;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc. 4 5;; Maintainer: FSF 6;; Keywords: lisp, tools, maint 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to 22;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 24;;; Commentary: 25 26;; This is a major mode documented in the Emacs manual. 27 28;;; Code: 29 30(defvar debug-function-list nil 31 "List of functions currently set for debug on entry.") 32 33(defvar debugger-outer-match-data) 34(defvar debugger-outer-track-mouse) 35(defvar debugger-outer-last-command) 36(defvar debugger-outer-this-command) 37(defvar debugger-outer-unread-command-char) 38(defvar debugger-outer-unread-command-events) 39(defvar debugger-outer-last-input-event) 40(defvar debugger-outer-last-command-event) 41(defvar debugger-outer-last-nonmenu-event) 42(defvar debugger-outer-last-event-frame) 43(defvar debugger-outer-standard-input) 44(defvar debugger-outer-standard-output) 45(defvar debugger-outer-cursor-in-echo-area) 46 47;;;###autoload 48(setq debugger 'debug) 49;;;###autoload 50(defun debug (&rest debugger-args) 51 "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. 52Arguments are mainly for use when this is called from the internals 53of the evaluator. 54 55You may call with no args, or you may pass nil as the first arg and 56any other args you like. In that case, the list of args after the 57first will be printed into the backtrace buffer." 58 (message "Entering debugger...") 59 (let (debugger-value 60 (debug-on-error nil) 61 (debug-on-quit nil) 62 (debugger-buffer (let ((default-major-mode 'fundamental-mode)) 63 (get-buffer-create "*Backtrace*"))) 64 (debugger-old-buffer (current-buffer)) 65 (debugger-step-after-exit nil) 66 ;; Don't keep reading from an executing kbd macro! 67 (executing-macro nil) 68 ;; Save the outer values of these vars for the `e' command 69 ;; before we replace the values. 70 (debugger-outer-match-data (match-data)) 71 (debugger-outer-track-mouse track-mouse) 72 (debugger-outer-last-command last-command) 73 (debugger-outer-this-command this-command) 74 (debugger-outer-unread-command-char unread-command-char) 75 (debugger-outer-unread-command-events unread-command-events) 76 (debugger-outer-last-input-event last-input-event) 77 (debugger-outer-last-command-event last-command-event) 78 (debugger-outer-last-nonmenu-event last-nonmenu-event) 79 (debugger-outer-last-event-frame last-event-frame) 80 (debugger-outer-standard-input standard-input) 81 (debugger-outer-standard-output standard-output) 82 (debugger-outer-cursor-in-echo-area cursor-in-echo-area)) 83 ;; Don't let these magic variables affect the debugger itself. 84 (let ((last-command nil) this-command track-mouse 85 (unread-command-char -1) unread-command-events 86 last-input-event last-command-event last-nonmenu-event 87 last-event-frame 88 (standard-input t) (standard-output t) 89 (cursor-in-echo-area nil)) 90 (unwind-protect 91 (save-excursion 92 (save-window-excursion 93 (pop-to-buffer debugger-buffer) 94 (erase-buffer) 95 (let ((standard-output (current-buffer)) 96 (print-escape-newlines t) 97 (print-length 50)) 98 (backtrace)) 99 (goto-char (point-min)) 100 (debugger-mode) 101 (delete-region (point) 102 (progn 103 (search-forward "\n debug(") 104 (forward-line 1) 105 (point))) 106 (debugger-reenable) 107 (cond ((memq (car debugger-args) '(lambda debug)) 108 (insert "Entering:\n") 109 (if (eq (car debugger-args) 'debug) 110 (progn 111 (backtrace-debug 4 t) 112 (delete-char 1) 113 (insert ?*) 114 (beginning-of-line)))) 115 ((eq (car debugger-args) 'exit) 116 (insert "Return value: ") 117 (setq debugger-value (nth 1 debugger-args)) 118 (prin1 debugger-value (current-buffer)) 119 (insert ?\n) 120 (delete-char 1) 121 (insert ? ) 122 (beginning-of-line)) 123 ((eq (car debugger-args) 'error) 124 (insert "Signalling: ") 125 (prin1 (nth 1 debugger-args) (current-buffer)) 126 (insert ?\n)) 127 ((eq (car debugger-args) t) 128 (insert "Beginning evaluation of function call form:\n")) 129 (t 130 (prin1 (if (eq (car debugger-args) 'nil) 131 (cdr debugger-args) debugger-args) 132 (current-buffer)) 133 (insert ?\n))) 134 (message "") 135 (let ((inhibit-trace t) 136 (standard-output nil) 137 (buffer-read-only t)) 138 (message "") 139 (recursive-edit)))) 140 ;; Kill or at least neuter the backtrace buffer, so that users 141 ;; don't try to execute debugger commands in an invalid context. 142 (if (get-buffer-window debugger-buffer 'visible) 143 ;; Still visible despite the save-window-excursion? Maybe it 144 ;; it's in a pop-up frame. It would be annoying to delete and 145 ;; recreate it every time the debugger stops, so instead we'll 146 ;; erase it but leave it visible. 147 (save-excursion 148 (set-buffer debugger-buffer) 149 (erase-buffer) 150 (fundamental-mode)) 151 (kill-buffer debugger-buffer)) 152 (store-match-data debugger-outer-match-data))) 153 ;; Put into effect the modified values of these variables 154 ;; in case the user set them with the `e' command. 155 (setq track-mouse debugger-outer-track-mouse) 156 (setq last-command debugger-outer-last-command) 157 (setq this-command debugger-outer-this-command) 158 (setq unread-command-char debugger-outer-unread-command-char) 159 (setq unread-command-events debugger-outer-unread-command-events) 160 (setq last-input-event debugger-outer-last-input-event) 161 (setq last-command-event debugger-outer-last-command-event) 162 (setq last-nonmenu-event debugger-outer-last-nonmenu-event) 163 (setq last-event-frame debugger-outer-last-event-frame) 164 (setq standard-input debugger-outer-standard-input) 165 (setq standard-output debugger-outer-standard-output) 166 (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) 167 (setq debug-on-next-call debugger-step-after-exit) 168 debugger-value)) 169 170(defun debugger-step-through () 171 "Proceed, stepping through subexpressions of this expression. 172Enter another debugger on next entry to eval, apply or funcall." 173 (interactive) 174 (setq debugger-step-after-exit t) 175 (message "Proceeding, will debug on next eval or call.") 176 (exit-recursive-edit)) 177 178(defun debugger-continue () 179 "Continue, evaluating this expression without stopping." 180 (interactive) 181 (message "Continuing.") 182 (exit-recursive-edit)) 183 184(defun debugger-return-value (val) 185 "Continue, specifying value to return. 186This is only useful when the value returned from the debugger 187will be used, such as in a debug on exit from a frame." 188 (interactive "XReturn value (evaluated): ") 189 (setq debugger-value val) 190 (princ "Returning " t) 191 (prin1 debugger-value) 192 (exit-recursive-edit)) 193 194(defun debugger-jump () 195 "Continue to exit from this frame, with all debug-on-entry suspended." 196 (interactive) 197 ;; Compensate for the two extra stack frames for debugger-jump. 198 (let ((debugger-frame-offset (+ debugger-frame-offset 2))) 199 (debugger-frame)) 200 ;; Turn off all debug-on-entry functions 201 ;; but leave them in the list. 202 (let ((list debug-function-list)) 203 (while list 204 (fset (car list) 205 (debug-on-entry-1 (car list) (symbol-function (car list)) nil)) 206 (setq list (cdr list)))) 207 (message "Continuing through this frame") 208 (exit-recursive-edit)) 209 210(defun debugger-reenable () 211 "Turn all debug-on-entry functions back on." 212 (let ((list debug-function-list)) 213 (while list 214 (or (consp (symbol-function (car list))) 215 (debug-convert-byte-code (car list))) 216 (fset (car list) 217 (debug-on-entry-1 (car list) (symbol-function (car list)) t)) 218 (setq list (cdr list))))) 219 220(defun debugger-frame-number () 221 "Return number of frames in backtrace before the one point points at." 222 (save-excursion 223 (beginning-of-line) 224 (let ((opoint (point)) 225 (count 0)) 226 (goto-char (point-min)) 227 (if (or (equal (buffer-substring (point) (+ (point) 6)) 228 "Signal") 229 (equal (buffer-substring (point) (+ (point) 6)) 230 "Return")) 231 (progn 232 (search-forward ":") 233 (forward-sexp 1))) 234 (forward-line 1) 235 (while (progn 236 (forward-char 2) 237 (if (= (following-char) ?\() 238 (forward-sexp 1) 239 (forward-sexp 2)) 240 (forward-line 1) 241 (<= (point) opoint)) 242 (setq count (1+ count))) 243 count))) 244 245;; Chosen empirically to account for all the frames 246;; that will exist when debugger-frame is called 247;; within the first one that appears in the backtrace buffer. 248;; Assumes debugger-frame is called from a key; 249;; will be wrong if it is called with Meta-x. 250(defconst debugger-frame-offset 8 "") 251 252(defun debugger-frame () 253 "Request entry to debugger when this frame exits. 254Applies to the frame whose line point is on in the backtrace." 255 (interactive) 256 (beginning-of-line) 257 (let ((level (debugger-frame-number))) 258 (backtrace-debug (+ level debugger-frame-offset) t)) 259 (if (= (following-char) ? ) 260 (let ((buffer-read-only nil)) 261 (delete-char 1) 262 (insert ?*))) 263 (beginning-of-line)) 264 265(defun debugger-frame-clear () 266 "Do not enter to debugger when this frame exits. 267Applies to the frame whose line point is on in the backtrace." 268 (interactive) 269 (beginning-of-line) 270 (let ((level (debugger-frame-number))) 271 (backtrace-debug (+ level debugger-frame-offset) nil)) 272 (if (= (following-char) ?*) 273 (let ((buffer-read-only nil)) 274 (delete-char 1) 275 (insert ? ))) 276 (beginning-of-line)) 277 278(defun debugger-eval-expression (exp) 279 "Eval an expression, in an environment like that outside the debugger." 280 (interactive 281 (list (read-from-minibuffer "Eval: " 282 nil read-expression-map t 283 'read-expression-history))) 284 (save-excursion 285 (if (null (buffer-name debugger-old-buffer)) 286 ;; old buffer deleted 287 (setq debugger-old-buffer (current-buffer))) 288 (set-buffer debugger-old-buffer) 289 (let ((track-mouse debugger-outer-track-mouse) 290 (last-command debugger-outer-last-command) 291 (this-command debugger-outer-this-command) 292 (unread-command-char debugger-outer-unread-command-char) 293 (unread-command-events debugger-outer-unread-command-events) 294 (last-input-event debugger-outer-last-input-event) 295 (last-command-event debugger-outer-last-command-event) 296 (last-nonmenu-event debugger-outer-last-nonmenu-event) 297 (last-event-frame debugger-outer-last-event-frame) 298 (standard-input debugger-outer-standard-input) 299 (standard-output debugger-outer-standard-output) 300 (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) 301 (store-match-data debugger-outer-match-data) 302 (prog1 (eval-expression exp) 303 (setq debugger-outer-match-data (match-data)) 304 (setq debugger-outer-track-mouse track-mouse) 305 (setq debugger-outer-last-command last-command) 306 (setq debugger-outer-this-command this-command) 307 (setq debugger-outer-unread-command-char unread-command-char) 308 (setq debugger-outer-unread-command-events unread-command-events) 309 (setq debugger-outer-last-input-event last-input-event) 310 (setq debugger-outer-last-command-event last-command-event) 311 (setq debugger-outer-last-nonmenu-event last-nonmenu-event) 312 (setq debugger-outer-last-event-frame last-event-frame) 313 (setq debugger-outer-standard-input standard-input) 314 (setq debugger-outer-standard-output standard-output) 315 (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area))))) 316 317(defvar debugger-mode-map nil) 318(if debugger-mode-map 319 nil 320 (let ((loop ? )) 321 (setq debugger-mode-map (make-keymap)) 322 (suppress-keymap debugger-mode-map) 323 (define-key debugger-mode-map "-" 'negative-argument) 324 (define-key debugger-mode-map "b" 'debugger-frame) 325 (define-key debugger-mode-map "c" 'debugger-continue) 326 (define-key debugger-mode-map "j" 'debugger-jump) 327 (define-key debugger-mode-map "r" 'debugger-return-value) 328 (define-key debugger-mode-map "u" 'debugger-frame-clear) 329 (define-key debugger-mode-map "d" 'debugger-step-through) 330 (define-key debugger-mode-map "l" 'debugger-list-functions) 331 (define-key debugger-mode-map "h" 'describe-mode) 332 (define-key debugger-mode-map "q" 'top-level) 333 (define-key debugger-mode-map "e" 'debugger-eval-expression) 334 (define-key debugger-mode-map " " 'next-line))) 335 336(put 'debugger-mode 'mode-class 'special) 337 338(defun debugger-mode () 339 "Mode for backtrace buffers, selected in debugger. 340\\<debugger-mode-map> 341A line starts with `*' if exiting that frame will call the debugger. 342Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. 343 344When in debugger due to frame being exited, 345use the \\[debugger-return-value] command to override the value 346being returned from that frame. 347 348Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control 349which functions will enter the debugger when called. 350 351Complete list of commands: 352\\{debugger-mode-map}" 353 (kill-all-local-variables) 354 (setq major-mode 'debugger-mode) 355 (setq mode-name "Debugger") 356 (setq truncate-lines t) 357 (set-syntax-table emacs-lisp-mode-syntax-table) 358 (use-local-map debugger-mode-map)) 359 360;;;###autoload 361(defun debug-on-entry (function) 362 "Request FUNCTION to invoke debugger each time it is called. 363If you tell the debugger to continue, FUNCTION's execution proceeds. 364This works by modifying the definition of FUNCTION, 365which must be written in Lisp, not predefined. 366Use \\[cancel-debug-on-entry] to cancel the effect of this command. 367Redefining FUNCTION also cancels it." 368 (interactive "aDebug on entry (to function): ") 369 (debugger-reenable) 370 (if (subrp (symbol-function function)) 371 (error "Function %s is a primitive" function)) 372 (or (consp (symbol-function function)) 373 (debug-convert-byte-code function)) 374 (or (consp (symbol-function function)) 375 (error "Definition of %s is not a list" function)) 376 (fset function (debug-on-entry-1 function (symbol-function function) t)) 377 (or (memq function debug-function-list) 378 (setq debug-function-list (cons function debug-function-list))) 379 function) 380 381;;;###autoload 382(defun cancel-debug-on-entry (&optional function) 383 "Undo effect of \\[debug-on-entry] on FUNCTION. 384If argument is nil or an empty string, cancel for all functions." 385 (interactive 386 (list (let ((name 387 (completing-read "Cancel debug on entry (to function): " 388 ;; Make an "alist" of the functions 389 ;; that now have debug on entry. 390 (mapcar 'list 391 (mapcar 'symbol-name 392 debug-function-list)) 393 nil t nil))) 394 (if name (intern name))))) 395 (debugger-reenable) 396 (if (and function (not (string= function ""))) 397 (progn 398 (fset function 399 (debug-on-entry-1 function (symbol-function function) nil)) 400 (setq debug-function-list (delq function debug-function-list)) 401 function) 402 (message "Cancelling debug-on-entry for all functions") 403 (mapcar 'cancel-debug-on-entry debug-function-list))) 404 405(defun debug-convert-byte-code (function) 406 (let ((defn (symbol-function function))) 407 (if (not (consp defn)) 408 ;; Assume a compiled code object. 409 (let* ((contents (append defn nil)) 410 (body 411 (list (list 'byte-code (nth 1 contents) 412 (nth 2 contents) (nth 3 contents))))) 413 (if (nthcdr 5 contents) 414 (setq body (cons (list 'interactive (nth 5 contents)) body))) 415 (if (nth 4 contents) 416 (setq body (cons (nth 4 contents) body))) 417 (fset function (cons 'lambda (cons (car contents) body))))))) 418 419(defun debug-on-entry-1 (function defn flag) 420 (if (subrp defn) 421 (error "%s is a built-in function" function) 422 (if (eq (car defn) 'macro) 423 (debug-on-entry-1 function (cdr defn) flag) 424 (or (eq (car defn) 'lambda) 425 (error "%s not user-defined Lisp function" function)) 426 (let (tail prec) 427 (if (stringp (car (nthcdr 2 defn))) 428 (setq tail (nthcdr 3 defn) 429 prec (list (car defn) (car (cdr defn)) 430 (car (cdr (cdr defn))))) 431 (setq tail (nthcdr 2 defn) 432 prec (list (car defn) (car (cdr defn))))) 433 (if (eq flag (equal (car tail) '(debug 'debug))) 434 defn 435 (if flag 436 (nconc prec (cons '(debug 'debug) tail)) 437 (nconc prec (cdr tail)))))))) 438 439(defun debugger-list-functions () 440 "Display a list of all the functions now set to debug on entry." 441 (interactive) 442 (with-output-to-temp-buffer "*Help*" 443 (if (null debug-function-list) 444 (princ "No debug-on-entry functions now\n") 445 (princ "Functions set to debug on entry:\n\n") 446 (let ((list debug-function-list)) 447 (while list 448 (prin1 (car list)) 449 (terpri) 450 (setq list (cdr list)))) 451 (princ "Note: if you have redefined a function, then it may no longer\n") 452 (princ "be set to debug on entry, even if it is in the list.")))) 453 454;;; debug.el ends here 455