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   (debugger-make-xrefs))
 276
 277 (defun debugger-make-xrefs (&optional buffer)
 278   "Attach cross-references to symbol names in the `*Backtrace*' buffer."
 279   (interactive "b")
 280   (save-excursion
 281     (set-buffer (or buffer (current-buffer)))
 282     (setq buffer (current-buffer))
 283     (let ((buffer-read-only nil)
 284           (old-end 1) (new-end 1))
 285       ;; If we saved an old backtrace, find the common part
 286       ;; between the new and the old.
 287       ;; Compare line by line, starting from the end,
 288       ;; because that's the part that is likely to be unchanged.
 289       (if debugger-previous-backtrace
 290           (let (old-start new-start (all-match t))
 291             (goto-char (point-max))
 292             (with-temp-buffer
 293               (insert debugger-previous-backtrace)
 294               (while (and all-match (not (bobp)))
 295                 (setq old-end (point))
 296                 (forward-line -1)
 297                 (setq old-start (point))
 298                 (with-current-buffer buffer
 299                   (setq new-end (point))
 300                   (forward-line -1)
 301                   (setq new-start (point)))
 302                 (if (not (zerop
 303                           (compare-buffer-substrings
 304                            (current-buffer) old-start old-end
 305                            buffer new-start new-end)))
 306                     (setq all-match nil))))
 307             ;; Now new-end is the position of the start of the
 308             ;; unchanged part in the current buffer, and old-end is
 309             ;; the position of that same text in the saved old
 310             ;; backtrace.  But we must subtract 1 since strings are
 311             ;; indexed in origin 0.
 312
 313             ;; Replace the unchanged part of the backtrace
 314             ;; with the text from debugger-previous-backtrace,
 315             ;; since that already has the proper xrefs.
 316             ;; With this optimization, we only need to scan
 317             ;; the changed part of the backtrace.
 318             (delete-region new-end (point-max))
 319             (goto-char (point-max))
 320             (insert (substring debugger-previous-backtrace (1- old-end)))
 321             ;; Make the unchanged part of the backtrace inaccessible
 322             ;; so it won't be scanned.
 323             (narrow-to-region (point-min) new-end)))
 324
 325       ;; Scan the new part of the backtrace, inserting xrefs.
 326       (goto-char (point-min))
 327       (while (progn
 328                (skip-syntax-forward "^w_")
 329                (not (eobp)))
 330         (let* ((beg (point))
 331                (end (progn (skip-syntax-forward "w_") (point)))
 332                (sym (intern-soft (buffer-substring-no-properties
 333                                   beg end)))
 334                (file (and sym (symbol-file sym))))
 335           (when file
 336             (goto-char beg)
 337             ;; help-xref-button needs to operate on something matched
 338             ;; by a regexp, so set that up for it.
 339             (re-search-forward "\\(\\(\\sw\\|\\s_\\)+\\)")
 340             (help-xref-button 1 'help-function-def sym file)))
 341         (forward-line 1))
 342       (widen))
 343     (setq debugger-previous-backtrace (buffer-string))))
 344 \f
 345 (defun debugger-step-through ()
 346   "Proceed, stepping through subexpressions of this expression.
 347 Enter another debugger on next entry to eval, apply or funcall."
 348   (interactive)
 349   (setq debugger-step-after-exit t)
 350   (message "Proceeding, will debug on next eval or call.")
 351   (exit-recursive-edit))
 352
 353 (defun debugger-continue ()
 354   "Continue, evaluating this expression without stopping."
 355   (interactive)
 356   (unless debugger-may-continue
 357     (error "Cannot continue"))
 358   (message "Continuing.")
 359   (exit-recursive-edit))
 360
 361 (defun debugger-return-value (val)
 362   "Continue, specifying value to return.
 363 This is only useful when the value returned from the debugger
 364 will be used, such as in a debug on exit from a frame."
 365   (interactive "XReturn value (evaluated): ")
 366   (setq debugger-value val)
 367   (princ "Returning " t)
 368   (prin1 debugger-value)
 369   (exit-recursive-edit))
 370
 371 ;; Chosen empirically to account for all the frames
 372 ;; that will exist when debugger-frame is called
 373 ;; within the first one that appears in the backtrace buffer.
 374 ;; Assumes debugger-frame is called from a key;
 375 ;; will be wrong if it is called with Meta-x.
 376 (defconst debugger-frame-offset 8 "")
 377
 378 (defun debugger-jump ()
 379   "Continue to exit from this frame, with all debug-on-entry suspended."
 380   (interactive)
 381   ;; Compensate for the two extra stack frames for debugger-jump.
 382   (let ((debugger-frame-offset (+ debugger-frame-offset 2)))
 383     (debugger-frame))
 384   ;; Turn off all debug-on-entry functions
 385   ;; but leave them in the list.
 386   (let ((list debug-function-list))
 387     (while list
 388       (fset (car list)
 389             (debug-on-entry-1 (car list) (symbol-function (car list)) nil))
 390       (setq list (cdr list))))
 391   (message "Continuing through this frame")
 392   (exit-recursive-edit))
 393
 394 (defun debugger-reenable ()
 395   "Turn all debug-on-entry functions back on."
 396   (let ((list debug-function-list))
 397     (while list
 398       (or (consp (symbol-function (car list)))
 399           (debug-convert-byte-code (car list)))
 400       (fset (car list)
 401             (debug-on-entry-1 (car list) (symbol-function (car list)) t))
 402       (setq list (cdr list)))))
 403
 404 (defun debugger-frame-number ()
 405   "Return number of frames in backtrace before the one point points at."
 406   (save-excursion
 407     (beginning-of-line)
 408     (let ((opoint (point))
 409           (count 0))
 410       (goto-char (point-min))
 411       (if (or (equal (buffer-substring (point) (+ (point) 6))
 412                      "Signal")
 413               (equal (buffer-substring (point) (+ (point) 6))
 414                      "Return"))
 415           (progn
 416             (search-forward ":")
 417             (forward-sexp 1)))
 418       (forward-line 1)
 419       (while (progn
 420                (forward-char 2)
 421                (if (= (following-char) ?\()
 422                    (forward-sexp 1)
 423                  (forward-sexp 2))
 424                (forward-line 1)
 425                (<= (point) opoint))
 426         (setq count (1+ count)))
 427       count)))
 428
 429 (defun debugger-frame ()
 430   "Request entry to debugger when this frame exits.
 431 Applies to the frame whose line point is on in the backtrace."
 432   (interactive)
 433   (beginning-of-line)
 434   (let ((level (debugger-frame-number)))
 435     (backtrace-debug (+ level debugger-frame-offset) t))
 436   (if (= (following-char) ? )
 437       (let ((buffer-read-only nil))
 438         (delete-char 1)
 439         (insert ?*)))
 440   (beginning-of-line))
 441
 442 (defun debugger-frame-clear ()
 443   "Do not enter debugger when this frame exits.
 444 Applies to the frame whose line point is on in the backtrace."
 445   (interactive)
 446   (beginning-of-line)
 447   (let ((level (debugger-frame-number)))
 448     (backtrace-debug (+ level debugger-frame-offset) nil))
 449   (if (= (following-char) ?*)
 450       (let ((buffer-read-only nil))
 451         (delete-char 1)
 452         (insert ? )))
 453   (beginning-of-line))
 454
 455
 456
 457 (put 'debugger-env-macro 'lisp-indent-function 0)
 458 (defmacro debugger-env-macro (&rest body)
 459   "Run BODY in original environment."
 460   `(save-excursion
 461     (if (null (buffer-name debugger-old-buffer))
 462         ;; old buffer deleted
 463         (setq debugger-old-buffer (current-buffer)))
 464     (set-buffer debugger-old-buffer)
 465     (let ((load-read-function debugger-outer-load-read-function)
 466           (overriding-terminal-local-map
 467            debugger-outer-overriding-terminal-local-map)
 468           (overriding-local-map debugger-outer-overriding-local-map)
 469           (track-mouse debugger-outer-track-mouse)
 470           (last-command debugger-outer-last-command)
 471           (this-command debugger-outer-this-command)
 472           (unread-command-char debugger-outer-unread-command-char)
 473           (unread-command-events debugger-outer-unread-command-events)
 474           (unread-post-input-method-events
 475            debugger-outer-unread-post-input-method-events)
 476           (last-input-event debugger-outer-last-input-event)
 477           (last-command-event debugger-outer-last-command-event)
 478           (last-nonmenu-event debugger-outer-last-nonmenu-event)
 479           (last-event-frame debugger-outer-last-event-frame)
 480           (standard-input debugger-outer-standard-input)
 481           (standard-output debugger-outer-standard-output)
 482           (inhibit-redisplay debugger-outer-inhibit-redisplay)
 483           (cursor-in-echo-area debugger-outer-cursor-in-echo-area))
 484       (set-match-data debugger-outer-match-data)
 485       (prog1 (progn ,@body)
 486         (setq debugger-outer-match-data (match-data))
 487         (setq debugger-outer-load-read-function load-read-function)
 488         (setq debugger-outer-overriding-terminal-local-map
 489               overriding-terminal-local-map)
 490         (setq debugger-outer-overriding-local-map overriding-local-map)
 491         (setq debugger-outer-track-mouse track-mouse)
 492         (setq debugger-outer-last-command last-command)
 493         (setq debugger-outer-this-command this-command)
 494         (setq debugger-outer-unread-command-char unread-command-char)
 495         (setq debugger-outer-unread-command-events unread-command-events)
 496         (setq debugger-outer-unread-post-input-method-events
 497               unread-post-input-method-events)
 498         (setq debugger-outer-last-input-event last-input-event)
 499         (setq debugger-outer-last-command-event last-command-event)
 500         (setq debugger-outer-last-nonmenu-event last-nonmenu-event)
 501         (setq debugger-outer-last-event-frame last-event-frame)
 502         (setq debugger-outer-standard-input standard-input)
 503         (setq debugger-outer-standard-output standard-output)
 504         (setq debugger-outer-inhibit-redisplay inhibit-redisplay)
 505         (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area)
 506         ))))
 507
 508 (defun debugger-eval-expression (exp)
 509   "Eval an expression, in an environment like that outside the debugger."
 510   (interactive
 511    (list (read-from-minibuffer "Eval: "
 512                                nil read-expression-map t
 513                                'read-expression-history)))
 514   (debugger-env-macro (eval-expression exp)))
 515 \f
 516 (defvar debugger-mode-map nil)
 517 (unless debugger-mode-map
 518   (let ((loop ? ))
 519     (setq debugger-mode-map (make-keymap))
 520     (suppress-keymap debugger-mode-map)
 521     (define-key debugger-mode-map "-" 'negative-argument)
 522     (define-key debugger-mode-map "b" 'debugger-frame)
 523     (define-key debugger-mode-map "c" 'debugger-continue)
 524     (define-key debugger-mode-map "j" 'debugger-jump)
 525     (define-key debugger-mode-map "r" 'debugger-return-value)
 526     (define-key debugger-mode-map "u" 'debugger-frame-clear)
 527     (define-key debugger-mode-map "d" 'debugger-step-through)
 528     (define-key debugger-mode-map "l" 'debugger-list-functions)
 529     (define-key debugger-mode-map "h" 'describe-mode)
 530     (define-key debugger-mode-map "q" 'top-level)
 531     (define-key debugger-mode-map "e" 'debugger-eval-expression)
 532     (define-key debugger-mode-map " " 'next-line)
 533     (define-key debugger-mode-map "R" 'debugger-record-expression)
 534     (define-key debugger-mode-map "\C-m" 'help-follow)
 535     (define-key debugger-mode-map [mouse-2] 'push-button)
 536     ))
 537
 538
 539 (defcustom debugger-record-buffer "*Debugger-record*"
 540   "*Buffer name for expression values, for \\[debugger-record-expression]."
 541   :type 'string
 542   :group 'debugger
 543   :version "20.3")
 544
 545 (defun debugger-record-expression  (exp)
 546   "Display a variable's value and record it in `*Backtrace-record*' buffer."
 547   (interactive
 548    (list (read-from-minibuffer
 549           "Record Eval: "
 550           nil
 551           read-expression-map t
 552           'read-expression-history)))
 553   (let* ((buffer (get-buffer-create debugger-record-buffer))
 554          (standard-output buffer))
 555     (princ (format "Debugger Eval (%s): " exp))
 556     (princ (debugger-eval-expression exp))
 557     (terpri))
 558
 559   (with-current-buffer (get-buffer debugger-record-buffer)
 560     (save-excursion
 561       (forward-line -1)
 562       (message
 563        (buffer-substring (point) (progn (end-of-line) (point)))))))
 564
 565 (put 'debugger-mode 'mode-class 'special)
 566
 567 (defun debugger-mode ()
 568   "Mode for backtrace buffers, selected in debugger.
 569 \\<debugger-mode-map>
 570 A line starts with `*' if exiting that frame will call the debugger.
 571 Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'.
 572
 573 When in debugger due to frame being exited,
 574 use the \\[debugger-return-value] command to override the value
 575 being returned from that frame.
 576
 577 Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control
 578 which functions will enter the debugger when called.
 579
 580 Complete list of commands:
 581 \\{debugger-mode-map}"
 582   (kill-all-local-variables)
 583   (setq major-mode 'debugger-mode)
 584   (setq mode-name "Debugger")
 585   (setq truncate-lines t)
 586   (set-syntax-table emacs-lisp-mode-syntax-table)
 587   (use-local-map debugger-mode-map)
 588   (run-hooks 'debugger-mode-hook))
 589 \f
 590 ;;;###autoload
 591 (defun debug-on-entry (function)
 592   "Request FUNCTION to invoke debugger each time it is called.
 593 If you tell the debugger to continue, FUNCTION's execution proceeds.
 594 This works by modifying the definition of FUNCTION,
 595 which must be written in Lisp, not predefined.
 596 Use \\[cancel-debug-on-entry] to cancel the effect of this command.
 597 Redefining FUNCTION also cancels it."
 598   (interactive "aDebug on entry (to function): ")
 599   (debugger-reenable)
 600   ;; Handle a function that has been aliased to some other function.
 601   (if (symbolp (symbol-function function))
 602       (fset function `(lambda (&rest debug-on-entry-args)
 603                         (apply ',(symbol-function function)
 604                                debug-on-entry-args))))
 605   (if (subrp (symbol-function function))
 606       (error "Function %s is a primitive" function))
 607   (or (consp (symbol-function function))
 608       (debug-convert-byte-code function))
 609   (or (consp (symbol-function function))
 610       (error "Definition of %s is not a list" function))
 611   (fset function (debug-on-entry-1 function (symbol-function function) t))
 612   (or (memq function debug-function-list)
 613       (setq debug-function-list (cons function debug-function-list)))
 614   function)
 615
 616 ;;;###autoload
 617 (defun cancel-debug-on-entry (&optional function)
 618   "Undo effect of \\[debug-on-entry] on FUNCTION.
 619 If argument is nil or an empty string, cancel for all functions."
 620   (interactive
 621    (list (let ((name
 622                 (completing-read "Cancel debug on entry (to function): "
 623                                  ;; Make an "alist" of the functions
 624                                  ;; that now have debug on entry.
 625                                  (mapcar 'list
 626                                          (mapcar 'symbol-name
 627                                                  debug-function-list))
 628                                  nil t nil)))
 629            (if name (intern name)))))
 630   (debugger-reenable)
 631   (if (and function (not (string= function "")))
 632       (progn
 633         (fset function
 634               (debug-on-entry-1 function (symbol-function function) nil))
 635         (setq debug-function-list (delq function debug-function-list))
 636         function)
 637     (message "Cancelling debug-on-entry for all functions")
 638     (mapcar 'cancel-debug-on-entry debug-function-list)))
 639
 640 (defun debug-convert-byte-code (function)
 641   (let ((defn (symbol-function function)))
 642     (if (not (consp defn))
 643         ;; Assume a compiled code object.
 644         (let* ((contents (append defn nil))
 645                (body
 646                 (list (list 'byte-code (nth 1 contents)
 647                             (nth 2 contents) (nth 3 contents)))))
 648           (if (nthcdr 5 contents)
 649               (setq body (cons (list 'interactive (nth 5 contents)) body)))
 650           (if (nth 4 contents)
 651               ;; Use `documentation' here, to get the actual string,
 652               ;; in case the compiled function has a reference
 653               ;; to the .elc file.
 654               (setq body (cons (documentation function) body)))
 655           (fset function (cons 'lambda (cons (car contents) body)))))))
 656
 657 (defun debug-on-entry-1 (function defn flag)
 658   (if (subrp defn)
 659       (error "%s is a built-in function" function)
 660     (if (eq (car defn) 'macro)
 661         (debug-on-entry-1 function (cdr defn) flag)
 662       (or (eq (car defn) 'lambda)
 663           (error "%s not user-defined Lisp function" function))
 664       (let (tail prec)
 665         (if (stringp (car (nthcdr 2 defn)))
 666             (setq tail (nthcdr 3 defn)
 667                   prec (list (car defn) (car (cdr defn))
 668                              (car (cdr (cdr defn)))))
 669           (setq tail (nthcdr 2 defn)
 670                 prec (list (car defn) (car (cdr defn)))))
 671         (if (eq flag (equal (car tail) '(debug 'debug)))
 672             defn
 673           (if flag
 674               (nconc prec (cons '(debug 'debug) tail))
 675             (nconc prec (cdr tail))))))))
 676
 677 (defun debugger-list-functions ()
 678   "Display a list of all the functions now set to debug on entry."
 679   (interactive)
 680   (with-output-to-temp-buffer "*Help*"
 681     (if (null debug-function-list)
 682         (princ "No debug-on-entry functions now\n")
 683       (princ "Functions set to debug on entry:\n\n")
 684       (let ((list debug-function-list))
 685         (while list
 686           (prin1 (car list))
 687           (terpri)
 688           (setq list (cdr list))))
 689       (princ "Note: if you have redefined a function, then it may no longer\n")
 690       (princ "be set to debug on entry, even if it is in the list."))
 691     (save-excursion
 692       (set-buffer standard-output)
 693       (help-mode))))
 694
 695 (provide 'debug)
 696
 697 ;;; debug.el ends here