767 changes: 767 additions & 0 deletions lisp/emacs-lisp/backtrace.el
View file

Large diffs are not rendered by default.

390 changes: 138 additions & 252 deletions lisp/emacs-lisp/debug.el
View file

Large diffs are not rendered by default.

178 changes: 131 additions & 47 deletions lisp/emacs-lisp/edebug.el
View file
Expand Up @@ -52,6 +52,7 @@

;;; Code:

(require 'backtrace)
(require 'macroexp)
(require 'cl-lib)
(eval-when-compile (require 'pcase))
Expand Down Expand Up @@ -206,8 +207,7 @@ Use this with caution since it is not debugged."
"Non-nil if Edebug should unwrap results of expressions.
That is, Edebug will try to remove its own instrumentation from the result.
This is useful when debugging macros where the results of expressions
are instrumented expressions. But don't do this when results might be
circular or an infinite loop will result."
are instrumented expressions."
:type 'boolean
:group 'edebug)

Expand Down Expand Up @@ -1265,25 +1265,59 @@ purpose by adding an entry to this alist, and setting
(defun edebug-unwrap (sexp)
"Return the unwrapped SEXP or return it as is if it is not wrapped.
The SEXP might be the result of wrapping a body, which is a list of
expressions; a `progn' form will be returned enclosing these forms."
(if (consp sexp)
(cond
((eq 'edebug-after (car sexp))
(nth 3 sexp))
((eq 'edebug-enter (car sexp))
(macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp)))))
(t sexp);; otherwise it is not wrapped, so just return it.
)
sexp))
expressions; a `progn' form will be returned enclosing these forms.
Does not unwrap inside vectors, records, structures, or hash tables."
(pcase sexp
(`(edebug-after ,_before-form ,_after-index ,form)
form)
(`(lambda ,args (edebug-enter ',_sym ,_arglist
(function (lambda nil . ,body))))
`(lambda ,args ,@body))
(`(closure ,env ,args (edebug-enter ',_sym ,_arglist
(function (lambda nil . ,body))))
`(closure ,env ,args ,@body))
(`(edebug-enter ',_sym ,_args (function (lambda nil . ,body)))
(macroexp-progn body))
(_ sexp)))

(defun edebug-unwrap* (sexp)
"Return the SEXP recursively unwrapped."
(let ((ht (make-hash-table :test 'eq)))
(edebug--unwrap1 sexp ht)))

(defun edebug--unwrap1 (sexp hash-table)
"Unwrap SEXP using HASH-TABLE of things already unwrapped.
HASH-TABLE contains the results of unwrapping cons cells within
SEXP, which are reused to avoid infinite loops when SEXP is or
contains a circular object."
(let ((new-sexp (edebug-unwrap sexp)))
(while (not (eq sexp new-sexp))
(setq sexp new-sexp
new-sexp (edebug-unwrap sexp)))
(if (consp new-sexp)
(mapcar #'edebug-unwrap* new-sexp)
(let ((result (gethash new-sexp hash-table nil)))
(unless result
(let ((remainder new-sexp)
current)
(setq result (cons nil nil)
current result)
(while
(progn
(puthash remainder current hash-table)
(setf (car current)
(edebug--unwrap1 (car remainder) hash-table))
(setq remainder (cdr remainder))
(cond
((atom remainder)
(setf (cdr current)
(edebug--unwrap1 remainder hash-table))
nil)
((gethash remainder hash-table nil)
(setf (cdr current) (gethash remainder hash-table nil))
nil)
(t (setq current
(setf (cdr current) (cons nil nil)))))))))
result)
new-sexp)))


Expand Down Expand Up @@ -3916,8 +3950,10 @@ Global commands prefixed by `global-edebug-prefix':
;; (setq debugger 'debug) ; use the standard debugger

;; Note that debug and its utilities must be byte-compiled to work,
;; since they depend on the backtrace looking a certain way. But
;; edebug is not dependent on this, yet.
;; since they depend on the backtrace looking a certain way. Edebug
;; will work if not byte-compiled, but it will not be able correctly
;; remove its instrumentation from backtraces unless it is
;; byte-compiled.

(defun edebug (&optional arg-mode &rest args)
"Replacement for `debug'.
Expand Down Expand Up @@ -3947,48 +3983,96 @@ Otherwise call `debug' normally."
(apply #'debug arg-mode args)
))

;;; Backtrace buffer

;; Data structure for backtrace frames with information
;; from Edebug instrumentation found in the backtrace.
(cl-defstruct
(edebug--frame
(:constructor edebug--make-frame)
(:include backtrace-frame))
def-name before-index after-index)

(defun edebug-backtrace ()
"Display a non-working backtrace. Better than nothing..."
"Display the current backtrace in a `backtrace-mode' window."
(interactive)
(if (or (not edebug-backtrace-buffer)
(null (buffer-name edebug-backtrace-buffer)))
(setq edebug-backtrace-buffer
(generate-new-buffer "*Backtrace*"))
(generate-new-buffer "*Edebug Backtrace*"))
;; Else, could just display edebug-backtrace-buffer.
)
(with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer)
(setq edebug-backtrace-buffer standard-output)
(let ((print-escape-newlines t)
(print-length 50) ; FIXME cf edebug-safe-prin1-to-string
last-ok-point)
(backtrace)

;; Clean up the backtrace.
;; Not quite right for current edebug scheme.
(set-buffer edebug-backtrace-buffer)
(setq truncate-lines t)
(goto-char (point-min))
(setq last-ok-point (point))
(if t (progn

;; Delete interspersed edebug internals.
(while (re-search-forward "^ (?edebug" nil t)
(beginning-of-line)
(cond
((looking-at "^ (edebug-after")
;; Previous lines may contain code, so just delete this line.
(setq last-ok-point (point))
(forward-line 1)
(delete-region last-ok-point (point)))

((looking-at (if debugger-stack-frame-as-list
"^ (edebug"
"^ edebug"))
(forward-line 1)
(delete-region last-ok-point (point))
)))
)))))
(with-current-buffer edebug-backtrace-buffer
(unless (derived-mode-p 'backtrace-mode)
(backtrace-mode))
(setq backtrace-frames (edebug--backtrace-frames)
backtrace-view '(:do-xrefs t))
(backtrace-print)
(goto-char (point-min)))))

(defun edebug--backtrace-frames ()
"Return backtrace frames with instrumentation removed.
Remove frames for Edebug's functions and the lambdas in
`edebug-enter' wrappers."
(let* ((frames (backtrace-get-frames 'edebug-debugger
:constructor #'edebug--make-frame))
skip-next-lambda def-name before-index after-index
results
(index (length frames)))
(dolist (frame (reverse frames))
(let ((fun (edebug--frame-fun frame))
(args (edebug--frame-args frame)))
(cl-decf index)
(when (edebug--frame-evald frame)
(setq before-index nil
after-index nil))
(pcase fun
('edebug-enter
(setq skip-next-lambda t
def-name (nth 0 args)))
('edebug-after
(setq before-index (if (consp (nth 0 args))
(nth 1 (nth 0 args))
(nth 0 args))
after-index (nth 1 args)))
((pred edebug--symbol-not-prefixed-p)
(edebug--unwrap-and-add-info frame def-name before-index after-index)
(setf (edebug--frame-def-name frame) (and before-index def-name))
(setf (edebug--frame-before-index frame) before-index)
(setf (edebug--frame-after-index frame) after-index)
(push frame results)
(setq before-index nil
after-index nil))
(`(,(or 'lambda 'closure) . ,_)
(unless skip-next-lambda
(edebug--unwrap-and-add-info frame def-name before-index after-index)
(push frame results))
(setq before-index nil
after-index nil
skip-next-lambda nil)))))
results))

(defun edebug--symbol-not-prefixed-p (sym)
"Return non-nil if SYM is a symbol not prefixed by \"edebug-\"."
(and (symbolp sym)
(not (string-prefix-p "edebug-" (symbol-name sym)))))

(defun edebug--unwrap-and-add-info (frame def-name before-index after-index)
"Update FRAME with the additional info needed by an edebug--frame.
Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME. Also
remove Edebug's instrumentation from the function and any
unevaluated arguments in FRAME."
(setf (edebug--frame-def-name frame) (and before-index def-name))
(setf (edebug--frame-before-index frame) before-index)
(setf (edebug--frame-after-index frame) after-index)
(setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame)))
(unless (edebug--frame-evald frame)
(let (results)
(dolist (arg (edebug--frame-args frame))
(push (edebug-unwrap* arg) results))
(setf (edebug--frame-args frame) (nreverse results)))))


;;; Trace display
Expand Down
42 changes: 18 additions & 24 deletions lisp/emacs-lisp/ert.el
View file
Expand Up @@ -60,6 +60,7 @@
(require 'cl-lib)
(require 'button)
(require 'debug)
(require 'backtrace)
(require 'easymenu)
(require 'ewoc)
(require 'find-func)
Expand Down Expand Up @@ -677,13 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM."
(cl-defstruct (ert-test-aborted-with-non-local-exit
(:include ert-test-result)))

(defun ert--print-backtrace (backtrace do-xrefs)
"Format the backtrace BACKTRACE to the current buffer."
(let ((print-escape-newlines t)
(print-level 8)
(print-length 50))
(debugger-insert-backtrace backtrace do-xrefs)))

;; A container for the state of the execution of a single test and
;; environment data needed during its execution.
(cl-defstruct ert--test-execution-info
Expand Down Expand Up @@ -732,7 +726,7 @@ run. ARGS are the arguments to `debugger'."
;; use.
;;
;; Grab the frames above the debugger.
(backtrace (cdr (backtrace-frames debugger)))
(backtrace (cdr (backtrace-get-frames debugger)))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
Expand Down Expand Up @@ -1406,9 +1400,8 @@ Returns the stats object."
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
(ert--print-backtrace
(ert-test-result-with-condition-backtrace result)
nil)
(insert (backtrace-to-string
(ert-test-result-with-condition-backtrace result)))
(if (not ert-batch-backtrace-right-margin)
(message "%s"
(buffer-substring-no-properties (point-min)
Expand Down Expand Up @@ -2450,20 +2443,21 @@ To be used in the ERT results buffer."
(cl-etypecase result
(ert-test-passed (error "Test passed, no backtrace available"))
(ert-test-result-with-condition
(let ((backtrace (ert-test-result-with-condition-backtrace result))
(buffer (get-buffer-create "*ERT Backtrace*")))
(let ((buffer (get-buffer-create "*ERT Backtrace*")))
(pop-to-buffer buffer)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
(ert-simple-view-mode)
(set-buffer-multibyte t) ; mimic debugger-setup-buffer
(setq truncate-lines t)
(ert--print-backtrace backtrace t)
(goto-char (point-min))
(insert (substitute-command-keys "Backtrace for test `"))
(ert-insert-test-name-button (ert-test-name test))
(insert (substitute-command-keys "':\n"))))))))
(unless (derived-mode-p 'backtrace-mode)
(backtrace-mode))
(setq backtrace-insert-header-function
(lambda () (ert--insert-backtrace-header (ert-test-name test)))
backtrace-frames (ert-test-result-with-condition-backtrace result)
backtrace-view '(:do-xrefs t))
(backtrace-print)
(goto-char (point-min)))))))

(defun ert--insert-backtrace-header (name)
(insert (substitute-command-keys "Backtrace for test `"))
(ert-insert-test-name-button name)
(insert (substitute-command-keys "':\n")))

(defun ert-results-pop-to-messages-for-test-at-point ()
"Display the part of the *Messages* buffer generated during the test at point.
Expand Down
10 changes: 10 additions & 0 deletions lisp/emacs-lisp/lisp-mode.el
View file
Expand Up @@ -517,6 +517,16 @@ This will generate compile-time constants from BINDINGS."
(defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1
"Default expressions to highlight in Lisp modes.")

;; Support backtrace mode.
(defconst lisp-el-font-lock-keywords-for-backtraces lisp-el-font-lock-keywords
"Default highlighting from Emacs Lisp mod used in Backtrace mode.")
(defconst lisp-el-font-lock-keywords-for-backtraces-1 lisp-el-font-lock-keywords-1
"Subdued highlighting from Emacs Lisp mode used in Backtrace mode.")
(defconst lisp-el-font-lock-keywords-for-backtraces-2
(remove (assoc 'lisp--match-hidden-arg lisp-el-font-lock-keywords-2)
lisp-el-font-lock-keywords-2)
"Gaudy highlighting from Emacs Lisp mode used in Backtrace mode.")

(defun lisp-string-in-doc-position-p (listbeg startpos)
"Return true if a doc string may occur at STARTPOS inside a list.
LISTBEG is the position of the start of the innermost list
Expand Down
89 changes: 89 additions & 0 deletions test/lisp/emacs-lisp/backtrace-tests.el
View file
@@ -0,0 +1,89 @@
;;; backtrace-tests.el --- Tests for emacs-lisp/backtrace.el -*- lexical-binding: t; -*-

;; Copyright (C) 2018 Free Software Foundation, Inc.

;; Author: Gemini Lasswell

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.

;;; Code:

(require 'backtrace)
(require 'ert)
(require 'seq)

;; Create a backtrace frames list with several frames.
;; TODO load this from an el file in backtrace-resources/ so the tests
;; can be byte-compiled.
(defvar backtrace-tests--frames nil)

(defun backtrace-tests--func1 (arg1 arg2)
(setq backtrace-tests--frames (backtrace-get-frames nil))
(list arg1 arg2))

(defun backtrace-tests--func2 (arg)
(list arg))

(defun backtrace-tests--func3 (arg)
(let ((foo (list 'a arg 'b)))
(list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0))))

(defun backtrace-tests--create-backtrace-frames ()
(backtrace-tests--func3 "string")
;; Discard frames before this one.
(let (this-index)
(dotimes (index (length backtrace-tests--frames))
(when (eq (backtrace-frame-fun (nth index backtrace-tests--frames))
'backtrace-tests--create-backtrace-frames)
(setq this-index index)))
(setq backtrace-tests--frames (seq-subseq backtrace-tests--frames
0 (1+ this-index)))))

(backtrace-tests--create-backtrace-frames)

;; TODO check that debugger-batch-max-lines still works

(defun backtrace-tests--insert-header ()
(insert "Test header\n"))

(defmacro backtrace-tests--with-buffer (&rest body)
`(with-temp-buffer
(backtrace-mode)
(setq backtrace-frames backtrace-tests--frames)
(setq backtrace-insert-header-function #'backtrace-tests--insert-header)
(backtrace-print)
,@body))

;;; Tests
(ert-deftest backtrace-tests--to-string ()
(should (string= (backtrace-to-string backtrace-tests--frames)
" backtrace-get-frames(nil)
(setq backtrace-tests--frames (backtrace-get-frames nil))
backtrace-tests--func1(\"string\" 0)
(list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0))
(let ((foo (list 'a arg 'b))) (list foo (backtrace-tests--func2 arg) (backtrace-tests--func1 arg 0)))
backtrace-tests--func3(\"string\")
backtrace-tests--create-backtrace-frames()
")))

(provide 'backtrace-tests)

;; These tests expect to see non-byte compiled stack frames.
;; Local Variables:
;; no-byte-compile: t
;; End:

;;; backtrace-tests.el ends here
2 changes: 1 addition & 1 deletion test/lisp/emacs-lisp/ert-tests.el
View file
Expand Up @@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works."
(test (make-ert-test :body test-body))
(result (ert-run-test test)))
(should (ert-test-failed-p result))
(should (eq (nth 1 (car (ert-test-failed-backtrace result)))
(should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result)))
'signal))))

(ert-deftest ert-test-messages ()
Expand Down