/[emacs]/emacs/lisp/emacs-lisp/debug.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/debug.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.55 by monnier, Fri Apr 12 03:19:09 2002 UTC revision 1.55.2.1 by miles, Fri Apr 4 06:20:16 2003 UTC
# Line 77  This is to optimize `debugger-make-xrefs Line 77  This is to optimize `debugger-make-xrefs
77  (defvar debugger-outer-track-mouse)  (defvar debugger-outer-track-mouse)
78  (defvar debugger-outer-last-command)  (defvar debugger-outer-last-command)
79  (defvar debugger-outer-this-command)  (defvar debugger-outer-this-command)
80    ;; unread-command-char is obsolete,
81    ;; but we still save and restore it
82    ;; in case some user program still tries to set it.
83  (defvar debugger-outer-unread-command-char)  (defvar debugger-outer-unread-command-char)
84  (defvar debugger-outer-unread-command-events)  (defvar debugger-outer-unread-command-events)
85  (defvar debugger-outer-unread-post-input-method-events)  (defvar debugger-outer-unread-post-input-method-events)
# Line 101  You may call with no args, or you may pa Line 104  You may call with no args, or you may pa
104  any other args you like.  In that case, the list of args after the  any other args you like.  In that case, the list of args after the
105  first will be printed into the backtrace buffer."  first will be printed into the backtrace buffer."
106    (interactive)    (interactive)
107    (unless noninteractive    (if inhibit-redisplay
108      (message "Entering debugger..."))        ;; Don't really try to enter debugger within an eval from redisplay.
109    (let (debugger-value        debugger-value
110          (debug-on-error nil)      (unless noninteractive
111          (debug-on-quit nil)        (message "Entering debugger..."))
112          (debugger-buffer (let ((default-major-mode 'fundamental-mode))      (let (debugger-value
113                             (get-buffer-create "*Backtrace*")))            (debug-on-error nil)
114          (debugger-old-buffer (current-buffer))            (debug-on-quit nil)
115          (debugger-step-after-exit nil)            (debugger-buffer (let ((default-major-mode 'fundamental-mode))
116          ;; Don't keep reading from an executing kbd macro!                               (get-buffer-create "*Backtrace*")))
117          (executing-kbd-macro nil)            (debugger-old-buffer (current-buffer))
118          ;; Save the outer values of these vars for the `e' command            (debugger-step-after-exit nil)
119          ;; before we replace the values.            ;; Don't keep reading from an executing kbd macro!
120          (debugger-outer-match-data (match-data))            (executing-kbd-macro nil)
121          (debugger-outer-load-read-function load-read-function)            ;; Save the outer values of these vars for the `e' command
122          (debugger-outer-overriding-local-map overriding-local-map)            ;; before we replace the values.
123          (debugger-outer-overriding-terminal-local-map            (debugger-outer-match-data (match-data))
124           overriding-terminal-local-map)            (debugger-outer-load-read-function load-read-function)
125          (debugger-outer-track-mouse track-mouse)            (debugger-outer-overriding-local-map overriding-local-map)
126          (debugger-outer-last-command last-command)            (debugger-outer-overriding-terminal-local-map
127          (debugger-outer-this-command this-command)             overriding-terminal-local-map)
128          (debugger-outer-unread-command-char unread-command-char)            (debugger-outer-track-mouse track-mouse)
129          (debugger-outer-unread-command-events unread-command-events)            (debugger-outer-last-command last-command)
130          (debugger-outer-unread-post-input-method-events            (debugger-outer-this-command this-command)
131           unread-post-input-method-events)            (debugger-outer-unread-command-char unread-command-char)
132          (debugger-outer-last-input-event last-input-event)            (debugger-outer-unread-command-events unread-command-events)
133          (debugger-outer-last-command-event last-command-event)            (debugger-outer-unread-post-input-method-events
134          (debugger-outer-last-nonmenu-event last-nonmenu-event)             unread-post-input-method-events)
135          (debugger-outer-last-event-frame last-event-frame)            (debugger-outer-last-input-event last-input-event)
136          (debugger-outer-standard-input standard-input)            (debugger-outer-last-command-event last-command-event)
137          (debugger-outer-standard-output standard-output)            (debugger-outer-last-nonmenu-event last-nonmenu-event)
138          (debugger-outer-inhibit-redisplay inhibit-redisplay)            (debugger-outer-last-event-frame last-event-frame)
139          (debugger-outer-cursor-in-echo-area cursor-in-echo-area))            (debugger-outer-standard-input standard-input)
140      ;; Set this instead of binding it, so that `q'            (debugger-outer-standard-output standard-output)
141      ;; will not restore it.            (debugger-outer-inhibit-redisplay inhibit-redisplay)
142      (setq overriding-terminal-local-map nil)            (debugger-outer-cursor-in-echo-area cursor-in-echo-area))
143      ;; Don't let these magic variables affect the debugger itself.        ;; Set this instead of binding it, so that `q'
144      (let ((last-command nil) this-command track-mouse        ;; will not restore it.
145            (unread-command-char -1) unread-command-events        (setq overriding-terminal-local-map nil)
146            unread-post-input-method-events        ;; Don't let these magic variables affect the debugger itself.
147            last-input-event last-command-event last-nonmenu-event        (let ((last-command nil) this-command track-mouse
148            last-event-frame              (unread-command-char -1) unread-command-events
149            overriding-local-map              unread-post-input-method-events
150            load-read-function              last-input-event last-command-event last-nonmenu-event
151            ;; If we are inside a minibuffer, allow nesting              last-event-frame
152            ;; so that we don't get an error from the `e' command.              overriding-local-map
153            (enable-recursive-minibuffers              load-read-function
154             (or enable-recursive-minibuffers (> (minibuffer-depth) 0)))              ;; If we are inside a minibuffer, allow nesting
155            (standard-input t) (standard-output t)              ;; so that we don't get an error from the `e' command.
156            inhibit-redisplay              (enable-recursive-minibuffers
157            (cursor-in-echo-area nil))               (or enable-recursive-minibuffers (> (minibuffer-depth) 0)))
158        (unwind-protect              (standard-input t) (standard-output t)
159            (save-excursion              inhibit-redisplay
160              (save-window-excursion              (cursor-in-echo-area nil))
161                (pop-to-buffer debugger-buffer)          (unwind-protect
162                (debugger-mode)              (save-excursion
163                (debugger-setup-buffer debugger-args)                (save-window-excursion
164                (when noninteractive                  (pop-to-buffer debugger-buffer)
165                  ;; If the backtrace is long, save the beginning                  (debugger-mode)
166                  ;; and the end, but discard the middle.                  (debugger-setup-buffer debugger-args)
167                  (when (> (count-lines (point-min) (point-max))                  (when noninteractive
168                           debugger-batch-max-lines)                    ;; If the backtrace is long, save the beginning
169                      ;; and the end, but discard the middle.
170                      (when (> (count-lines (point-min) (point-max))
171                               debugger-batch-max-lines)
172                        (goto-char (point-min))
173                        (forward-line (/ 2 debugger-batch-max-lines))
174                        (let ((middlestart (point)))
175                          (goto-char (point-max))
176                          (forward-line (- (/ 2 debugger-batch-max-lines)
177                                           debugger-batch-max-lines))
178                          (delete-region middlestart (point)))
179                        (insert "...\n"))
180                    (goto-char (point-min))                    (goto-char (point-min))
181                    (forward-line (/ 2 debugger-batch-max-lines))                    (message (buffer-string))
182                    (let ((middlestart (point)))                    (kill-emacs))
183                      (goto-char (point-max))                  (if (eq (car debugger-args) 'debug)
184                      (forward-line (- (/ 2 debugger-batch-max-lines)                      ;; Skip the frames for backtrace-debug, byte-code, and debug.
185                                       debugger-batch-max-lines))                      (backtrace-debug 3 t))
186                      (delete-region middlestart (point)))                  (debugger-reenable)
                   (insert "...\n"))  
                 (goto-char (point-min))  
                 (message (buffer-string))  
                 (kill-emacs))  
               (if (eq (car debugger-args) 'debug)  
                   ;; Skip the frames for backtrace-debug, byte-code, and debug.  
                   (backtrace-debug 3 t))  
               (debugger-reenable)  
               (message "")  
               (let ((inhibit-trace t)  
                     (standard-output nil)  
                     (buffer-read-only t))  
187                  (message "")                  (message "")
188                  ;; Make sure we unbind buffer-read-only in the right buffer.                  (let ((inhibit-trace t)
189                  (save-excursion                        (standard-output nil)
190                    (recursive-edit)))))                        (buffer-read-only t))
191          ;; Kill or at least neuter the backtrace buffer, so that users                    (message "")
192          ;; don't try to execute debugger commands in an invalid context.                    ;; Make sure we unbind buffer-read-only in the right buffer.
193          (if (get-buffer-window debugger-buffer 'visible)                    (save-excursion
194              ;; Still visible despite the save-window-excursion?  Maybe it                      (recursive-edit)))))
195              ;; it's in a pop-up frame.  It would be annoying to delete and            ;; Kill or at least neuter the backtrace buffer, so that users
196              ;; recreate it every time the debugger stops, so instead we'll            ;; don't try to execute debugger commands in an invalid context.
197              ;; erase it but leave it visible.            (if (get-buffer-window debugger-buffer 'visible)
198              (save-excursion                ;; Still visible despite the save-window-excursion?  Maybe it
199                (set-buffer debugger-buffer)                ;; it's in a pop-up frame.  It would be annoying to delete and
200                (erase-buffer)                ;; recreate it every time the debugger stops, so instead we'll
201                (fundamental-mode))                ;; erase it but leave it visible.
202            (kill-buffer debugger-buffer))                (save-excursion
203          (set-match-data debugger-outer-match-data)))                  (set-buffer debugger-buffer)
204      ;; Put into effect the modified values of these variables                  (erase-buffer)
205      ;; in case the user set them with the `e' command.                  (fundamental-mode))
206      (setq load-read-function debugger-outer-load-read-function)              (kill-buffer debugger-buffer))
207      (setq overriding-local-map debugger-outer-overriding-local-map)            (set-match-data debugger-outer-match-data)))
208      (setq overriding-terminal-local-map        ;; Put into effect the modified values of these variables
209            debugger-outer-overriding-terminal-local-map)        ;; in case the user set them with the `e' command.
210      (setq track-mouse debugger-outer-track-mouse)        (setq load-read-function debugger-outer-load-read-function)
211      (setq last-command debugger-outer-last-command)        (setq overriding-local-map debugger-outer-overriding-local-map)
212      (setq this-command debugger-outer-this-command)        (setq overriding-terminal-local-map
213      (setq unread-command-char debugger-outer-unread-command-char)              debugger-outer-overriding-terminal-local-map)
214      (setq unread-command-events debugger-outer-unread-command-events)        (setq track-mouse debugger-outer-track-mouse)
215      (setq unread-post-input-method-events        (setq last-command debugger-outer-last-command)
216            debugger-outer-unread-post-input-method-events)        (setq this-command debugger-outer-this-command)
217      (setq last-input-event debugger-outer-last-input-event)        (setq unread-command-char debugger-outer-unread-command-char)
218      (setq last-command-event debugger-outer-last-command-event)        (setq unread-command-events debugger-outer-unread-command-events)
219      (setq last-nonmenu-event debugger-outer-last-nonmenu-event)        (setq unread-post-input-method-events
220      (setq last-event-frame debugger-outer-last-event-frame)              debugger-outer-unread-post-input-method-events)
221      (setq standard-input debugger-outer-standard-input)        (setq last-input-event debugger-outer-last-input-event)
222      (setq standard-output debugger-outer-standard-output)        (setq last-command-event debugger-outer-last-command-event)
223      (setq inhibit-redisplay debugger-outer-inhibit-redisplay)        (setq last-nonmenu-event debugger-outer-last-nonmenu-event)
224      (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)        (setq last-event-frame debugger-outer-last-event-frame)
225      (setq debug-on-next-call debugger-step-after-exit)        (setq standard-input debugger-outer-standard-input)
226      debugger-value))        (setq standard-output debugger-outer-standard-output)
227          (setq inhibit-redisplay debugger-outer-inhibit-redisplay)
228          (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
229          (setq debug-on-next-call debugger-step-after-exit)
230          debugger-value)))
231    
232  (defun debugger-setup-buffer (debugger-args)  (defun debugger-setup-buffer (debugger-args)
233    "Initialize the `*Backtrace*' buffer for entry to the debugger.    "Initialize the `*Backtrace*' buffer for entry to the debugger.
# Line 332  That buffer should be current already." Line 338  That buffer should be current already."
338              ;; Make the unchanged part of the backtrace inaccessible              ;; Make the unchanged part of the backtrace inaccessible
339              ;; so it won't be scanned.              ;; so it won't be scanned.
340              (narrow-to-region (point-min) new-end)))              (narrow-to-region (point-min) new-end)))
341                
342        ;; Scan the new part of the backtrace, inserting xrefs.        ;; Scan the new part of the backtrace, inserting xrefs.
343        (goto-char (point-min))        (goto-char (point-min))
344        (while (progn        (while (progn
# Line 611  Redefining FUNCTION also cancels it." Line 617  Redefining FUNCTION also cancels it."
617    (interactive "aDebug on entry (to function): ")    (interactive "aDebug on entry (to function): ")
618    (debugger-reenable)    (debugger-reenable)
619    ;; Handle a function that has been aliased to some other function.    ;; Handle a function that has been aliased to some other function.
620    (if (symbolp (symbol-function function))    (if (and (subrp (symbol-function function))
621               (eq (cdr (subr-arity (symbol-function function))) 'unevalled))
622          (error "Function %s is a special form" function))
623      (if (or (symbolp (symbol-function function))
624              (subrp (symbol-function function)))
625          ;; Create a wrapper in which we can then add the necessary debug call.
626        (fset function `(lambda (&rest debug-on-entry-args)        (fset function `(lambda (&rest debug-on-entry-args)
627                            ,(interactive-form (symbol-function function))
628                          (apply ',(symbol-function function)                          (apply ',(symbol-function function)
629                                 debug-on-entry-args))))                                 debug-on-entry-args))))
   (if (subrp (symbol-function function))  
       (error "Function %s is a primitive" function))  
630    (or (consp (symbol-function function))    (or (consp (symbol-function function))
631        (debug-convert-byte-code function))        (debug-convert-byte-code function))
632    (or (consp (symbol-function function))    (or (consp (symbol-function function))
# Line 633  If argument is nil or an empty string, c Line 643  If argument is nil or an empty string, c
643    (interactive    (interactive
644     (list (let ((name     (list (let ((name
645                  (completing-read "Cancel debug on entry (to function): "                  (completing-read "Cancel debug on entry (to function): "
646                                   ;; Make an "alist" of the functions                                   (mapcar 'symbol-name debug-function-list)
                                  ;; that now have debug on entry.  
                                  (mapcar 'list  
                                          (mapcar 'symbol-name  
                                                  debug-function-list))  
647                                   nil t nil)))                                   nil t nil)))
648             (if name (intern name)))))             (if name (intern name)))))
649    (debugger-reenable)    (debugger-reenable)
650    (if (and function (not (string= function "")))    (if (and function (not (string= function "")))
651        (progn        (progn
652          (fset function          (let ((f (debug-on-entry-1 function (symbol-function function) nil)))
653                (debug-on-entry-1 function (symbol-function function) nil))            (condition-case nil
654                  (if (and (equal (nth 1 f) '(&rest debug-on-entry-args))
655                           (eq (car (nth 3 f)) 'apply))
656                      ;; `f' is a wrapper introduced in debug-on-entry.
657                      ;; Get rid of it since we don't need it any more.
658                      (setq f (nth 1 (nth 1 (nth 3 f)))))
659                (error nil))
660              (fset function f))
661          (setq debug-function-list (delq function debug-function-list))          (setq debug-function-list (delq function debug-function-list))
662          function)          function)
663      (message "Cancelling debug-on-entry for all functions")      (message "Cancelling debug-on-entry for all functions")
# Line 674  If argument is nil or an empty string, c Line 687  If argument is nil or an empty string, c
687          (debug-on-entry-1 function (cdr defn) flag)          (debug-on-entry-1 function (cdr defn) flag)
688        (or (eq (car defn) 'lambda)        (or (eq (car defn) 'lambda)
689            (error "%s not user-defined Lisp function" function))            (error "%s not user-defined Lisp function" function))
690        (let (tail prec)        (let ((tail (cddr defn)))
691          (if (stringp (car (nthcdr 2 defn)))          ;; Skip the docstring.
692              (setq tail (nthcdr 3 defn)          (if (stringp (car tail)) (setq tail (cdr tail)))
693                    prec (list (car defn) (car (cdr defn))          ;; Skip the interactive form.
694                               (car (cdr (cdr defn)))))          (if (eq 'interactive (car-safe (car tail))) (setq tail (cdr tail)))
695            (setq tail (nthcdr 2 defn)          (unless (eq flag (equal (car tail) '(debug 'debug)))
696                  prec (list (car defn) (car (cdr defn)))))            ;; Add/remove debug statement as needed.
697          (if (eq flag (equal (car tail) '(debug 'debug)))            (if (not flag)
698              defn                (progn (setcar tail (cadr tail))
699            (if flag                       (setcdr tail (cddr tail)))
700                (nconc prec (cons '(debug 'debug) tail))              (setcdr tail (cons (car tail) (cdr tail)))
701              (nconc prec (cdr tail))))))))              (setcar tail '(debug 'debug))))
702            defn))))
703    
704  (defun debugger-list-functions ()  (defun debugger-list-functions ()
705    "Display a list of all the functions now set to debug on entry."    "Display a list of all the functions now set to debug on entry."

Legend:
Removed from v.1.55  
changed lines
  Added in v.1.55.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26