+ (save-window-excursion
+ (with-no-warnings
+ (setq unread-command-char -1))
+ (pop-to-buffer debugger-buffer)
+ (debugger-mode)
+ (debugger-setup-buffer debugger-args)
+ (when noninteractive
+ ;; If the backtrace is long, save the beginning
+ ;; and the end, but discard the middle.
+ (when (> (count-lines (point-min) (point-max))
+ debugger-batch-max-lines)
+ (goto-char (point-min))
+ (forward-line (/ 2 debugger-batch-max-lines))
+ (let ((middlestart (point)))
+ (goto-char (point-max))
+ (forward-line (- (/ 2 debugger-batch-max-lines)
+ debugger-batch-max-lines))
+ (delete-region middlestart (point)))
+ (insert "...\n"))
+ (goto-char (point-min))
+ (message "%s" (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))
+ (message "")
+ ;; Make sure we unbind buffer-read-only in the right buffer.
+ (save-excursion
+ (recursive-edit)))))
+ ;; Kill or at least neuter the backtrace buffer, so that users
+ ;; don't try to execute debugger commands in an invalid context.
+ (if (get-buffer-window debugger-buffer 'visible)
+ ;; Still visible despite the save-window-excursion? Maybe it
+ ;; it's in a pop-up frame. It would be annoying to delete and
+ ;; recreate it every time the debugger stops, so instead we'll
+ ;; erase it but leave it visible.
+ (save-excursion
+ (set-buffer debugger-buffer)
+ (erase-buffer)
+ (fundamental-mode))
+ (kill-buffer debugger-buffer))
+ (set-match-data debugger-outer-match-data)))
+ ;; Put into effect the modified values of these variables
+ ;; in case the user set them with the `e' command.
+ (setq load-read-function debugger-outer-load-read-function)
+ (setq overriding-local-map debugger-outer-overriding-local-map)
+ (setq overriding-terminal-local-map
+ debugger-outer-overriding-terminal-local-map)
+ (setq track-mouse debugger-outer-track-mouse)
+ (setq last-command debugger-outer-last-command)
+ (setq this-command debugger-outer-this-command)
+ (with-no-warnings
+ (setq unread-command-char debugger-outer-unread-command-char))
+ (setq unread-command-events debugger-outer-unread-command-events)
+ (setq unread-post-input-method-events
+ debugger-outer-unread-post-input-method-events)
+ (setq last-input-event debugger-outer-last-input-event)
+ (setq last-command-event debugger-outer-last-command-event)
+ (setq last-nonmenu-event debugger-outer-last-nonmenu-event)
+ (setq last-event-frame debugger-outer-last-event-frame)
+ (setq standard-input debugger-outer-standard-input)
+ (setq standard-output debugger-outer-standard-output)
+ (setq inhibit-redisplay debugger-outer-inhibit-redisplay)
+ (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area)
+ (setq debug-on-next-call debugger-step-after-exit)
+ debugger-value)))
+\f
+(defun debugger-setup-buffer (debugger-args)
+ "Initialize the `*Backtrace*' buffer for entry to the debugger.
+That buffer should be current already."
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (set-buffer-multibyte nil)
+ (let ((standard-output (current-buffer))
+ (print-escape-newlines t)
+ (print-level 8)
+ (print-length 50))
+ (backtrace))
+ (goto-char (point-min))
+ (delete-region (point)
+ (progn
+ (search-forward "\n debug(")
+ (forward-line 1)
+ (point)))
+ (insert "Debugger entered")
+ ;; lambda is for debug-on-call when a function call is next.
+ ;; debug is for debug-on-entry function called.
+ (cond ((memq (car debugger-args) '(lambda debug))
+ (insert "--entering a function:\n")
+ (if (eq (car debugger-args) 'debug)
+ (progn
+ (delete-char 1)
+ (insert ?*)
+ (beginning-of-line))))
+ ;; Exiting a function.
+ ((eq (car debugger-args) 'exit)
+ (insert "--returning value: ")
+ (setq debugger-value (nth 1 debugger-args))
+ (prin1 debugger-value (current-buffer))
+ (insert ?\n)
+ (delete-char 1)
+ (insert ? )
+ (beginning-of-line))
+ ;; Debugger entered for an error.
+ ((eq (car debugger-args) 'error)
+ (insert "--Lisp error: ")
+ (prin1 (nth 1 debugger-args) (current-buffer))
+ (insert ?\n))
+ ;; debug-on-call, when the next thing is an eval.
+ ((eq (car debugger-args) t)
+ (insert "--beginning evaluation of function call form:\n"))
+ ;; User calls debug directly.
+ (t
+ (insert ": ")
+ (prin1 (if (eq (car debugger-args) 'nil)
+ (cdr debugger-args) debugger-args)
+ (current-buffer))
+ (insert ?\n)))
+ ;; After any frame that uses eval-buffer,
+ ;; insert a line that states the buffer position it's reading at.
+ (save-excursion
+ (while (re-search-forward "^ eval-buffer(" nil t)
+ (end-of-line)
+ (insert (format "\n ;;; Reading at buffer position %d"
+ (with-current-buffer (nth 2 (backtrace-frame (debugger-frame-number)))
+ (point))))))
+ (debugger-make-xrefs))
+
+(defun debugger-make-xrefs (&optional buffer)
+ "Attach cross-references to symbol names in the `*Backtrace*' buffer."
+ (interactive "b")
+ (save-excursion
+ (set-buffer (or buffer (current-buffer)))
+ (setq buffer (current-buffer))
+ (let ((buffer-read-only nil)
+ (old-end (point-min)) (new-end (point-min)))
+ ;; If we saved an old backtrace, find the common part
+ ;; between the new and the old.
+ ;; Compare line by line, starting from the end,
+ ;; because that's the part that is likely to be unchanged.
+ (if debugger-previous-backtrace
+ (let (old-start new-start (all-match t))
+ (goto-char (point-max))
+ (with-temp-buffer
+ (insert debugger-previous-backtrace)
+ (while (and all-match (not (bobp)))
+ (setq old-end (point))
+ (forward-line -1)
+ (setq old-start (point))
+ (with-current-buffer buffer
+ (setq new-end (point))
+ (forward-line -1)
+ (setq new-start (point)))
+ (if (not (zerop
+ (compare-buffer-substrings
+ (current-buffer) old-start old-end
+ buffer new-start new-end)))
+ (setq all-match nil))))
+ ;; Now new-end is the position of the start of the
+ ;; unchanged part in the current buffer, and old-end is
+ ;; the position of that same text in the saved old
+ ;; backtrace. But we must subtract (point-min) since strings are
+ ;; indexed in origin 0.
+
+ ;; Replace the unchanged part of the backtrace
+ ;; with the text from debugger-previous-backtrace,
+ ;; since that already has the proper xrefs.
+ ;; With this optimization, we only need to scan
+ ;; the changed part of the backtrace.
+ (delete-region new-end (point-max))
+ (goto-char (point-max))
+ (insert (substring debugger-previous-backtrace
+ (- old-end (point-min))))
+ ;; Make the unchanged part of the backtrace inaccessible
+ ;; so it won't be scanned.
+ (narrow-to-region (point-min) new-end)))
+
+ ;; Scan the new part of the backtrace, inserting xrefs.
+ (goto-char (point-min))
+ (while (progn
+ (skip-syntax-forward "^w_")
+ (not (eobp)))
+ (let* ((beg (point))
+ (end (progn (skip-syntax-forward "w_") (point)))
+ (sym (intern-soft (buffer-substring-no-properties
+ beg end)))
+ (file (and sym (symbol-file sym))))
+ (when file
+ (goto-char beg)
+ ;; help-xref-button needs to operate on something matched
+ ;; by a regexp, so set that up for it.
+ (re-search-forward "\\(\\(\\sw\\|\\s_\\)+\\)")
+ (help-xref-button 1 'help-function-def sym file)))
+ (forward-line 1))
+ (widen))
+ (setq debugger-previous-backtrace (buffer-string))))