LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - debug.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 22 388 5.7 %
Date: 2017-08-30 10:12:24 Functions: 2 35 5.7 %

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

Generated by: LCOV version 1.12