lisp/emacs-lisp/debug.el

   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 the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This is a major mode documented in the Emacs manual.
  28
  29 ;;; Code:
  30
  31 (defgroup debugger nil
  32   "Debuggers and related commands for Emacs."
  33   :prefix "debugger-"
  34   :group 'debug)
  35
  36 (defcustom debugger-mode-hook nil
  37   "*Hooks run when `debugger-mode' is turned on."
  38   :type 'hook
  39   :group 'debugger
  40   :version "20.3")
  41
  42 (defcustom debugger-batch-max-lines 40
  43   "*Maximum lines to show in debugger buffer in a noninteractive Emacs.
  44 When the debugger is entered and Emacs is running in batch mode,
  45 if the backtrace text has more than this many lines,
  46 the middle is discarded, and just the beginning and end are displayed."
  47   :type 'integer
  48   :group 'debugger
  49   :version "21.1")
  50
  51 (defcustom debug-function-list nil
  52   "List of functions currently set for debug on entry."
  53   :type '(repeat function)
  54   :group 'debugger)
  55
  56 (defcustom debugger-step-after-exit nil
  57   "Non-nil means \"single-step\" after the debugger exits."
  58   :type 'boolean
  59   :group 'debugger)
  60
  61 (defvar debugger-value nil
  62   "This is the value for the debugger to return, when it returns.")
  63
  64 (defvar debugger-old-buffer nil
  65   "This is the buffer that was current when the debugger was entered.")
  66
  67 (defvar debugger-previous-backtrace nil
  68   "The contents of the previous backtrace (including text properties).
  69 This is to optimize `debugger-make-xrefs'.")
  70
  71 (defvar debugger-outer-match-data)
  72 (defvar debugger-outer-load-read-function)
  73 (defvar debugger-outer-overriding-local-map)
  74 (defvar debugger-outer-overriding-terminal-local-map)
  75 (defvar debugger-outer-track-mouse)
  76 (defvar debugger-outer-last-command)
  77 (defvar debugger-outer-this-command)
  78 (defvar debugger-outer-unread-command-char)
  79 (defvar debugger-outer-unread-command-events)
  80 (defvar debugger-outer-unread-post-input-method-events)
  81 (defvar debugger-outer-last-input-event)
  82 (defvar debugger-outer-last-command-event)
  83 (defvar debugger-outer-last-nonmenu-event)
  84 (defvar debugger-outer-last-event-frame)
  85 (defvar debugger-outer-standard-input)
  86 (defvar debugger-outer-standard-output)
  87 (defvar debugger-outer-inhibit-redisplay)
  88 (defvar debugger-outer-cursor-in-echo-area)
  89
  90 ;;;###autoload
  91 (setq debugger 'debug)
  92 ;;;###autoload
  93 (defun debug (&rest debugger-args)
  94   "Enter debugger.  To return, type \\<debugger-mode-map>`\\[debugger-continue]'.
  95 Arguments are mainly for use when this is called from the internals
  96 of the evaluator.
  97
  98 You may call with no args, or you may pass nil as the first arg and
  99 any other args you like.  In that case, the list of args after the
 100 first will be printed into the backtrace buffer."
 101   (interactive)
 102   (unless noninteractive
 103     (message "Entering debugger..."))
 104   (let (debugger-value
 105         (debug-on-error nil)
 106         (debug-on-quit nil)
 107         (debugger-buffer (let ((default-major-mode 'fundamental-mode))
 108                            (get-buffer-create "*Backtrace*")))
 109         (debugger-old-buffer (current-buffer))
 110         (debugger-step-after-exit nil)
 111         ;; Don't keep reading from an executing kbd macro!
 112         (executing-kbd-macro nil)
 113         ;; Save the outer values of these vars for the `e' command
 114         ;; before we replace the values.
 115         (debugger-outer-match-data (match-data))
 116         (debugger-outer-load-read-function load-read-function)
 117         (debugger-outer-overriding-local-map overriding-local-map)
 118         (debugger-outer-overriding-terminal-local-map
 119          overriding-terminal-local-map)
 120         (debugger-outer-track-mouse track-mouse)
 121         (debugger-outer-last-command last-command)
 122         (debugger-outer-this-command this-command)
 123         (debugger-outer-unread-command-char unread-command-char)
 124         (debugger-outer-unread-command-events unread-command-events)
 125         (debugger-outer-unread-post-input-method-events
 126          unread-post-input-method-events)
 127         (debugger-outer-last-input-event last-input-event)
 128         (debugger-outer-last-command-event last-command-event)
 129         (debugger-outer-last-nonmenu-event last-nonmenu-event)
 130         (debugger-outer-last-event-frame last-event-frame)
 131         (debugger-outer-standard-input standard-input)
 132         (debugger-outer-standard-output standard-output)
 133         (debugger-outer-inhibit-redisplay inhibit-redisplay)
 134         (debugger-outer-cursor-in-echo-area cursor-in-echo-area))
 135     ;; Set this instead of binding it, so that `q'
 136     ;; will not restore it.
 137     (setq overriding-terminal-local-map nil)
 138     ;; Don't let these magic variables affect the debugger itself.
 139     (let ((last-command nil) this-command track-mouse
 140           (unread-command-char -1) unread-command-events
 141           unread-post-input-method-events
 142           last-input-event last-command-event last-nonmenu-event
 143           last-event-frame
 144           overriding-local-map
 145           load-read-function
 146           ;; If we are inside a minibuffer, allow nesting
 147           ;; so that we don't get an error from the `e' command.
 148           (enable-recursive-minibuffers
 149            (or enable-recursive-minibuffers (> (minibuffer-depth) 0)))
 150           (standard-input t) (standard-output t)
 151           inhibit-redisplay
 152           (cursor-in-echo-area nil))
 153       (unwind-protect
 154           (save-excursion
 155             (save-window-excursion
 156               (pop-to-buffer debugger-buffer)
 157               (debugger-mode)
 158               (debugger-setup-buffer debugger-args)
 159               (when noninteractive
 160                 ;; If the backtrace is long, save the beginning
 161                 ;; and the end, but discard the middle.
 162                 (when (> (count-lines (point-min) (point-max))
 163                          debugger-batch-max-lines)
 164                   (goto-char (point-min))
 165                   (forward-line (/ 2 debugger-batch-max-lines))
 166                   (let ((middlestart (point)))
 167                     (goto-char (point-max))
 168                     (forward-line (- (/ 2 debugger-batch-max-lines)
 169                                      debugger-batch-max-lines))
 170                     (delete-region middlestart (point)))
 171                   (insert "...\n"))
 172                 (goto-char (point-min))
 173                 (message (buffer-string))
 174                 (kill-emacs))
 175               (if (eq (car debugger-args) 'debug)
 176                   ;; Skip the frames for backtrace-debug, byte-code, and debug.
 177                   (backtrace-debug 3 t))
 178               (debugger-reenable)
 179               (message "")
 180               (let ((inhibit-trace t)
 181                     (standard-output nil)
 182                     (buffer-read-only t))
 183                 (message "")
 184                 ;; Make sure we unbind buffer-read-only in the right buffer.
 185                 (save-excursion
 186                   (recursive-edit)))))
 187         ;; Kill or at least neuter the backtrace buffer, so that users
 188         ;; don't try to execute debugger commands in an invalid context.
 189         (if (get-buffer-window debugger-buffer 'visible)
 190             ;; Still visible despite the save-window-excursion?  Maybe it
 191             ;; it's in a pop-up frame.  It would be annoying to delete and
 192             ;; recreate it every time the debugger stops, so instead we'll
 193             ;; erase it but leave it visible.
 194             (save-excursion
 195               (set-buffer debugger-buffer)
 196               (erase-buffer)
 197               (fundamental-mode))
 198           (kill-buffer debugger-buffer))
 199         (set-match-data debugger-outer-match-data)))
 200     ;; Put into effect the modified values of these variables
 201     ;; in case the user set them with the `e' command.
 202     (setq load-read-function debugger-outer-load-read-function)
 203     (setq overriding-local-map debugger-outer-overriding-local-map)
 204     (setq overriding-terminal-local-map
 205           debugger-outer-overriding-terminal-local-map)
 206     (setq track-mouse debugger-outer-track-mouse)
 207     (setq last-command debugger-outer-last-command)
 208     (setq this-command debugger-outer-this-command)
 209     (setq unread-command-char debugger-outer-unread-command-char)
 210     (setq unread-command-events debugger-outer-unread-command-events)
 211     (setq unread-post-input-method-events
 212           debugger-outer-unread-post-input-method-events)
 213     (setq last-input-event debugger-outer-last-input-event)
 214     (setq last-command-event debugger-outer-last-command-event)
 215     (setq last-nonmenu-event debugger-outer-last-nonmenu-event)
 216     (setq last-event-frame debugger-outer-last-event-frame)
 217     (setq standard-input debugger-outer-standard-input)
 218     (setq standard-output debugger-outer-standard-output)
 219     (setq inhibit-redisplay debugger-outer-inhibit-redisplay)
 220     (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
 221     (setq debug-on-next-call debugger-step-after-exit)
 222     debugger-value))
 223 \f
 224 (defun debugger-setup-buffer (debugger-args)
 225   "Initialize the `*Backtrace*' buffer for entry to the debugger.
 226 That buffer should be current already."
 227   (setq buffer-read-only nil)
 228   (erase-buffer)
 229   (set-buffer-multibyte nil)
 230   (let ((standard-output (current-buffer))
 231         (print-escape-newlines t)
 232         (print-level 8)
 233         (print-length 50))
 234     (backtrace))
 235   (goto-char (point-min))
 236   (delete-region (point)
 237                  (progn
 238                    (search-forward "\n  debug(")
 239                    (forward-line 1)
 240                    (point)))
 241   (insert "Debugger entered")
 242   ;; lambda is for debug-on-call when a function call is next.
 243   ;; debug is for debug-on-entry function called.
 244   (cond ((memq (car debugger-args) '(lambda debug))
 245          (insert "--entering a function:\n")
 246          (if (eq (car debugger-args) 'debug)
 247              (progn
 248                (delete-char 1)
 249                (insert ?*)
 250                (beginning-of-line))))
 251         ;; Exiting a function.
 252         ((eq (car debugger-args) 'exit)
 253          (insert "--returning value: ")
 254          (setq debugger-value (nth 1 debugger-args))
 255          (prin1 debugger-value (current-buffer))
 256          (insert ?\n)
 257          (delete-char 1)
 258          (insert ? )
 259          (beginning-of-line))
 260         ;; Debugger entered for an error.
 261         ((eq (car debugger-args) 'error)
 262          (insert "--Lisp error: ")
 263          (prin1 (nth 1 debugger-args) (current-buffer))
 264          (insert ?\n))
 265         ;; debug-on-call, when the next thing is an eval.
 266         ((eq (car debugger-args) t)
 267          (insert "--beginning evaluation of function call form:\n"))
 268         ;; User calls debug directly.
 269         (t
 270          (insert ": ")
 271          (prin1 (if (eq (car debugger-args) 'nil)
 272                     (cdr debugger-args) debugger-args)
 273                 (current-buffer))
 274          (insert ?\n)))
 275   (when (re-search-forward "^  eval-buffer(" nil t)
 276     (end-of-line)
 277     (insert (format "\n  ;;; Reading at buffer position %d"
 278                     (let ((level (+ (debugger-frame-number)
 279                                     debugger-frame-offset -4)))
 280                       (with-current-buffer (nth 2 (backtrace-frame level))
 281                         (point))))))
 282   (debugger-make-xrefs))
 283
 284 (defun debugger-make-xrefs (&optional buffer)
 285   "Attach cross-references to symbol names in the `*Backtrace*' buffer."
 286   (interactive "b")
 287   (save-excursion
 288     (set-buffer (or buffer (current-buffer)))
 289     (setq buffer (current-buffer))
 290     (let ((buffer-read-only nil)
 291           (old-end 1) (new-end 1))
 292       ;; If we saved an old backtrace, find the common part
 293       ;; between the new and the old.
 294       ;; Compare line by line, starting from the end,
 295       ;; because that's the part that is likely to be unchanged.
 296       (if debugger-previous-backtrace
 297           (let (old-start new-start (all-match t))
 298             (goto-char (point-max))
 299             (with-temp-buffer
 300               (insert debugger-previous-backtrace)
 301               (while (and all-match (not (bobp)))
 302                 (setq old-end (point))
 303                 (forward-line -1)
 304                 (setq old-start (point))
 305                 (with-current-buffer buffer
 306                   (setq new-end (point))
 307                   (forward-line -1)
 308                   (setq new-start (point)))
 309                 (if (not (zerop
 310                           (compare-buffer-substrings
 311                            (current-buffer) old-start old-end
 312                            buffer new-start new-end)))
 313                     (setq all-match nil))))
 314             ;; Now new-end is the position of the start of the
 315             ;; unchanged part in the current buffer, and old-end is
 316             ;; the position of that same text in the saved old
 317             ;; backtrace.  But we must subtract 1 since strings are
 318             ;; indexed in origin 0.
 319
 320             ;; Replace the unchanged part of the backtrace
 321             ;; with the text from debugger-previous-backtrace,
 322             ;; since that already has the proper xrefs.
 323             ;; With this optimization, we only need to scan
 324             ;; the changed part of the backtrace.
 325             (delete-region new-end (point-max))
 326             (goto-char (point-max))
 327             (insert (substring debugger-previous-backtrace (1- old-end)))
 328             ;; Make the unchanged part of the backtrace inaccessible
 329             ;; so it won't be scanned.
 330             (narrow-to-region (point-min) new-end)))
 331
 332       ;; Scan the new part of the backtrace, inserting xrefs.
 333       (goto-char (point-min))
 334       (while (progn
 335                (skip-syntax-forward "^w_")
 336                (not (eobp)))
 337         (let* ((beg (point))
 338                (end (progn (skip-syntax-forward "w_") (point)))
 339                (sym (intern-soft (buffer-substring-no-properties
 340                                   beg end)))
 341                (file (and sym (symbol-file sym))))
 342           (when file
 343             (goto-char beg)
 344             ;; help-xref-button needs to operate on something matched
 345             ;; by a regexp, so set that up for it.
 346             (re-search-forward "\\(\\(\\sw\\|\\s_\\)+\\)")
 347             (help-xref-button 1 'help-function-def sym file)))
 348         (forward-line 1))
 349       (widen))
 350     (setq debugger-previous-backtrace (buffer-string))))
 351 \f
 352 (defun debugger-step-through ()
 353   "Proceed, stepping through subexpressions of this expression.
 354 Enter another debugger on next entry to eval, apply or funcall."
 355   (interactive)
 356   (setq debugger-step-after-exit t)
 357   (message "Proceeding, will debug on next eval or call.")
 358   (exit-recursive-edit))
 359
 360 (defun debugger-continue ()
 361   "Continue, evaluating this expression without stopping."
 362   (interactive)
 363   (unless debugger-may-continue
 364     (error "Cannot continue"))
 365   (message "Continuing.")
 366   (exit-recursive-edit))
 367
 368 (defun debugger-return-value (val)
 369   "Continue, specifying value to return.
 370 This is only useful when the value returned from the debugger
 371 will be used, such as in a debug on exit from a frame."
 372   (interactive "XReturn value (evaluated): ")
 373   (setq debugger-value val)
 374   (princ "Returning " t)
 375   (prin1 debugger-value)
 376   (exit-recursive-edit))
 377
 378 ;; Chosen empirically to account for all the frames
 379 ;; that will exist when debugger-frame is called
 380 ;; within the first one that appears in the backtrace buffer.
 381 ;; Assumes debugger-frame is called from a key;
 382 ;; will be wrong if it is called with Meta-x.
 383 (defconst debugger-frame-offset 8 "")
 384
 385 (defun debugger-jump ()
 386   "Continue to exit from this frame, with all debug-on-entry suspended."
 387   (interactive)
 388   ;; Compensate for the two extra stack frames for debugger-jump.
 389   (let ((debugger-frame-offset (+ debugger-frame-offset 2)))
 390     (debugger-frame))
 391   ;; Turn off all debug-on-entry functions
 392   ;; but leave them in the list.
 393   (let ((list debug-function-list))
 394     (while list
 395       (fset (car list)
 396             (debug-on-entry-1 (car list) (symbol-function (car list)) nil))
 397       (setq list (cdr list))))
 398   (message "Continuing through this frame")
 399   (exit-recursive-edit))
 400
 401 (defun debugger-reenable ()
 402   "Turn all debug-on-entry functions back on."
 403   (let ((list debug-function-list))
 404     (while list
 405       (or (consp (symbol-function (car list)))
 406           (debug-convert-byte-code (car list)))
 407       (fset (car list)
 408             (debug-on-entry-1 (car list) (symbol-function (car list)) t))
 409       (setq list (cdr list)))))
 410
 411 (defun debugger-frame-number ()
 412   "Return number of frames in backtrace before the one point points at."
 413   (save-excursion
 414     (beginning-of-line)
 415     (let ((opoint (point))
 416           (count 0))
 417       (goto-char (point-min))
 418       (if (or (equal (buffer-substring (point) (+ (point) 6))
 419                      "Signal")
 420               (equal (buffer-substring (point) (+ (point) 6))
 421                      "Return"))
 422           (progn
 423             (search-forward ":")
 424             (forward-sexp 1)))
 425       (forward-line 1)
 426       (while (progn
 427                (forward-char 2)
 428                (if (= (following-char) ?\()
 429                    (forward-sexp 1)
 430                  (forward-sexp 2))
 431                (forward-line 1)
 432                (<= (point) opoint))
 433         (if (looking-at " *;;;")
 434             (forward-line 1))
 435         (setq count (1+ count)))
 436       count)))
 437
 438 (defun debugger-frame ()
 439   "Request entry to debugger when this frame exits.
 440 Applies to the frame whose line point is on in the backtrace."
 441   (interactive)
 442   (beginning-of-line)
 443   (let ((level (debugger-frame-number)))
 444     (backtrace-debug (+ level debugger-frame-offset) t))
 445   (if (= (following-char) ? )
 446       (let ((buffer-read-only nil))
 447         (delete-char 1)
 448         (insert ?*)))
 449   (beginning-of-line))
 450
 451 (defun debugger-frame-clear ()
 452   "Do not enter debugger when this frame exits.
 453 Applies to the frame whose line point is on in the backtrace."
 454   (interactive)
 455   (beginning-of-line)
 456   (let ((level (debugger-frame-number)))
 457     (backtrace-debug (+ level debugger-frame-offset) nil))
 458   (if (= (following-char) ?*)
 459       (let ((buffer-read-only nil))
 460         (delete-char 1)
 461         (insert ? )))
 462   (beginning-of-line))
 463
 464
 465
 466 (put 'debugger-env-macro 'lisp-indent-function 0)
 467 (defmacro debugger-env-macro (&rest body)
 468   "Run BODY in original environment."
 469   `(save-excursion
 470     (if (null (buffer-name debugger-old-buffer))
 471         ;; old buffer deleted
 472         (setq debugger-old-buffer (current-buffer)))
 473     (set-buffer debugger-old-buffer)
 474     (let ((load-read-function debugger-outer-load-read-function)
 475           (overriding-terminal-local-map
 476            debugger-outer-overriding-terminal-local-map)
 477           (overriding-local-map debugger-outer-overriding-local-map)
 478           (track-mouse debugger-outer-track-mouse)
 479           (last-command debugger-outer-last-command)
 480           (this-command debugger-outer-this-command)
 481           (unread-command-char debugger-outer-unread-command-char)
 482           (unread-command-events debugger-outer-unread-command-events)
 483           (unread-post-input-method-events
 484            debugger-outer-unread-post-input-method-events)
 485           (last-input-event debugger-outer-last-input-event)
 486           (last-command-event debugger-outer-last-command-event)
 487           (last-nonmenu-event debugger-outer-last-nonmenu-event)
 488           (last-event-frame debugger-outer-last-event-frame)
 489           (standard-input debugger-outer-standard-input)
 490           (standard-output debugger-outer-standard-output)
 491           (inhibit-redisplay debugger-outer-inhibit-redisplay)
 492           (cursor-in-echo-area debugger-outer-cursor-in-echo-area))
 493       (set-match-data debugger-outer-match-data)
 494       (prog1 (progn ,@body)
 495         (setq debugger-outer-match-data (match-data))
 496         (setq debugger-outer-load-read-function load-read-function)
 497         (setq debugger-outer-overriding-terminal-local-map
 498               overriding-terminal-local-map)
 499         (setq debugger-outer-overriding-local-map overriding-local-map)
 500         (setq debugger-outer-track-mouse track-mouse)
 501         (setq debugger-outer-last-command last-command)
 502         (setq debugger-outer-this-command this-command)
 503         (setq debugger-outer-unread-command-char unread-command-char)
 504         (setq debugger-outer-unread-command-events unread-command-events)
 505         (setq debugger-outer-unread-post-input-method-events
 506               unread-post-input-method-events)
 507         (setq debugger-outer-last-input-event last-input-event)
 508         (setq debugger-outer-last-command-event last-command-event)
 509         (setq debugger-outer-last-nonmenu-event last-nonmenu-event)
 510         (setq debugger-outer-last-event-frame last-event-frame)
 511         (setq debugger-outer-standard-input standard-input)
 512         (setq debugger-outer-standard-output standard-output)
 513         (setq debugger-outer-inhibit-redisplay inhibit-redisplay)
 514         (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area)
 515         ))))
 516
 517 (defun debugger-eval-expression (exp)
 518   "Eval an expression, in an environment like that outside the debugger."
 519   (interactive
 520    (list (read-from-minibuffer "Eval: "
 521                                nil read-expression-map t
 522                                'read-expression-history)))
 523   (debugger-env-macro (eval-expression exp)))
 524 \f
 525 (defvar debugger-mode-map nil)
 526 (unless debugger-mode-map
 527   (let ((loop ? ))
 528     (setq debugger-mode-map (make-keymap))
 529     (suppress-keymap debugger-mode-map)
 530     (define-key debugger-mode-map "-" 'negative-argument)
 531     (define-key debugger-mode-map "b" 'debugger-frame)
 532     (define-key debugger-mode-map "c" 'debugger-continue)
 533     (define-key debugger-mode-map "j" 'debugger-jump)
 534     (define-key debugger-mode-map "r" 'debugger-return-value)
 535     (define-key debugger-mode-map "u" 'debugger-frame-clear)
 536     (define-key debugger-mode-map "d" 'debugger-step-through)
 537     (define-key debugger-mode-map "l" 'debugger-list-functions)
 538     (define-key debugger-mode-map "h" 'describe-mode)
 539     (define-key debugger-mode-map "q" 'top-level)
 540     (define-key debugger-mode-map "e" 'debugger-eval-expression)
 541     (define-key debugger-mode-map " " 'next-line)
 542     (define-key debugger-mode-map "R" 'debugger-record-expression)
 543     (define-key debugger-mode-map "\C-m" 'help-follow)
 544     (define-key debugger-mode-map [mouse-2] 'push-button)
 545     ))
 546
 547
 548 (defcustom debugger-record-buffer "*Debugger-record*"
 549   "*Buffer name for expression values, for \\[debugger-record-expression]."
 550   :type 'string
 551   :group 'debugger
 552   :version "20.3")
 553
 554 (defun debugger-record-expression  (exp)
 555   "Display a variable's value and record it in `*Backtrace-record*' buffer."
 556   (interactive
 557    (list (read-from-minibuffer
 558           "Record Eval: "
 559           nil
 560           read-expression-map t
 561           'read-expression-history)))
 562   (let* ((buffer (get-buffer-create debugger-record-buffer))
 563          (standard-output buffer))
 564     (princ (format "Debugger Eval (%s): " exp))
 565     (princ (debugger-eval-expression exp))
 566     (terpri))
 567
 568   (with-current-buffer (get-buffer debugger-record-buffer)
 569     (save-excursion
 570       (forward-line -1)
 571       (message
 572        (buffer-substring (point) (progn (end-of-line) (point)))))))
 573
 574 (put 'debugger-mode 'mode-class 'special)
 575
 576 (defun debugger-mode ()
 577   "Mode for backtrace buffers, selected in debugger.
 578 \\<debugger-mode-map>
 579 A line starts with `*' if exiting that frame will call the debugger.
 580 Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'.
 581
 582 When in debugger due to frame being exited,
 583 use the \\[debugger-return-value] command to override the value
 584 being returned from that frame.
 585
 586 Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control
 587 which functions will enter the debugger when called.
 588
 589 Complete list of commands:
 590 \\{debugger-mode-map}"
 591   (kill-all-local-variables)
 592   (setq major-mode 'debugger-mode)
 593   (setq mode-name "Debugger")
 594   (setq truncate-lines t)
 595   (set-syntax-table emacs-lisp-mode-syntax-table)
 596   (use-local-map debugger-mode-map)
 597   (run-hooks 'debugger-mode-hook))
 598 \f
 599 ;;;###autoload
 600 (defun debug-on-entry (function)
 601   "Request FUNCTION to invoke debugger each time it is called.
 602 If you tell the debugger to continue, FUNCTION's execution proceeds.
 603 This works by modifying the definition of FUNCTION,
 604 which must be written in Lisp, not predefined.
 605 Use \\[cancel-debug-on-entry] to cancel the effect of this command.
 606 Redefining FUNCTION also cancels it."
 607   (interactive "aDebug on entry (to function): ")
 608   (debugger-reenable)
 609   ;; Handle a function that has been aliased to some other function.
 610   (if (symbolp (symbol-function function))
 611       (fset function `(lambda (&rest debug-on-entry-args)
 612                         (apply ',(symbol-function function)
 613                                debug-on-entry-args))))
 614   (if (subrp (symbol-function function))
 615       (error "Function %s is a primitive" function))
 616   (or (consp (symbol-function function))
 617       (debug-convert-byte-code function))
 618   (or (consp (symbol-function function))
 619       (error "Definition of %s is not a list" function))
 620   (fset function (debug-on-entry-1 function (symbol-function function) t))
 621   (or (memq function debug-function-list)
 622       (setq debug-function-list (cons function debug-function-list)))
 623   function)
 624
 625 ;;;###autoload
 626 (defun cancel-debug-on-entry (&optional function)
 627   "Undo effect of \\[debug-on-entry] on FUNCTION.
 628 If argument is nil or an empty string, cancel for all functions."
 629   (interactive
 630    (list (let ((name
 631                 (completing-read "Cancel debug on entry (to function): "
 632                                  ;; Make an "alist" of the functions
 633                                  ;; that now have debug on entry.
 634                                  (mapcar 'list
 635                                          (mapcar 'symbol-name
 636                                                  debug-function-list))
 637                                  nil t nil)))
 638            (if name (intern name)))))
 639   (debugger-reenable)
 640   (if (and function (not (string= function "")))
 641       (progn
 642         (fset function
 643               (debug-on-entry-1 function (symbol-function function) nil))
 644         (setq debug-function-list (delq function debug-function-list))
 645         function)
 646     (message "Cancelling debug-on-entry for all functions")
 647     (mapcar 'cancel-debug-on-entry debug-function-list)))
 648
 649 (defun debug-convert-byte-code (function)
 650   (let ((defn (symbol-function function)))
 651     (if (not (consp defn))
 652         ;; Assume a compiled code object.
 653         (let* ((contents (append defn nil))
 654                (body
 655                 (list (list 'byte-code (nth 1 contents)
 656                             (nth 2 contents) (nth 3 contents)))))
 657           (if (nthcdr 5 contents)
 658               (setq body (cons (list 'interactive (nth 5 contents)) body)))
 659           (if (nth 4 contents)
 660               ;; Use `documentation' here, to get the actual string,
 661               ;; in case the compiled function has a reference
 662               ;; to the .elc file.
 663               (setq body (cons (documentation function) body)))
 664           (fset function (cons 'lambda (cons (car contents) body)))))))
 665
 666 (defun debug-on-entry-1 (function defn flag)
 667   (if (subrp defn)
 668       (error "%s is a built-in function" function)
 669     (if (eq (car defn) 'macro)
 670         (debug-on-entry-1 function (cdr defn) flag)
 671       (or (eq (car defn) 'lambda)
 672           (error "%s not user-defined Lisp function" function))
 673       (let (tail prec)
 674         (if (stringp (car (nthcdr 2 defn)))
 675             (setq tail (nthcdr 3 defn)
 676                   prec (list (car defn) (car (cdr defn))
 677                              (car (cdr (cdr defn)))))
 678           (setq tail (nthcdr 2 defn)
 679                 prec (list (car defn) (car (cdr defn)))))
 680         (if (eq flag (equal (car tail) '(debug 'debug)))
 681             defn
 682           (if flag
 683               (nconc prec (cons '(debug 'debug) tail))
 684             (nconc prec (cdr tail))))))))
 685
 686 (defun debugger-list-functions ()
 687   "Display a list of all the functions now set to debug on entry."
 688   (interactive)
 689   (with-output-to-temp-buffer "*Help*"
 690     (if (null debug-function-list)
 691         (princ "No debug-on-entry functions now\n")
 692       (princ "Functions set to debug on entry:\n\n")
 693       (let ((list debug-function-list))
 694         (while list
 695           (prin1 (car list))
 696           (terpri)
 697           (setq list (cdr list))))
 698       (princ "Note: if you have redefined a function, then it may no longer\n")
 699       (princ "be set to debug on entry, even if it is in the list."))
 700     (save-excursion
 701       (set-buffer standard-output)
 702       (help-mode))))
 703
 704 (provide 'debug)
 705
 706 ;;; debug.el ends here