Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs

1 files changed, 55 insertions, 57 deletions

diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index e7387e463cb..eb2b2e3e11b 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -276,7 +276,8 @@ DATA is displayed to the user and should state the reason for skipping."
 (defun ert--expand-should-1 (whole form inner-expander)
   "Helper function for the `should' macro and its variants."
   (let ((form
-         (macroexpand form (append byte-compile-macro-environment
+         (macroexpand form (append (bound-and-true-p
+                                    byte-compile-macro-environment)
                                    (cond
                                     ((boundp 'macroexpand-all-environment)
                                      macroexpand-all-environment)
@@ -669,48 +670,12 @@ 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--record-backtrace ()
-  "Record the current backtrace (as a list) and return it."
-  ;; Since the backtrace is stored in the result object, result
-  ;; objects must only be printed with appropriate limits
-  ;; (`print-level' and `print-length') in place.  For interactive
-  ;; use, the cost of ensuring this possibly outweighs the advantage
-  ;; of storing the backtrace for
-  ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
-  ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
-  ;; For batch use, however, printing the backtrace may be useful.
-  (cl-loop
-   ;; 6 is the number of frames our own debugger adds (when
-   ;; compiled; more when interpreted).  FIXME: Need to describe a
-   ;; procedure for determining this constant.
-   for i from 6
-   for frame = (backtrace-frame i)
-   while frame
-   collect frame))
-
-(defun ert--print-backtrace (backtrace)
+(defun ert--print-backtrace (backtrace do-xrefs)
   "Format the backtrace BACKTRACE to the current buffer."
-  ;; This is essentially a reimplementation of Fbacktrace
-  ;; (src/eval.c), but for a saved backtrace, not the current one.
   (let ((print-escape-newlines t)
         (print-level 8)
         (print-length 50))
-    (dolist (frame backtrace)
-      (pcase-exhaustive frame
-        (`(nil ,special-operator . ,arg-forms)
-         ;; Special operator.
-         (insert
-          (format "  %S\n" (cons special-operator arg-forms))))
-        (`(t ,fn . ,args)
-         ;; Function call.
-         (insert (format "  %S(" fn))
-         (cl-loop for firstp = t then nil
-                  for arg in args do
-                  (unless firstp
-                    (insert " "))
-                  (insert (format "%S" arg)))
-         (insert ")\n"))))))
+    (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.
@@ -749,7 +714,19 @@ run.  ARGS are the arguments to `debugger'."
                       ((quit) 'quit)
 		      ((ert-test-skipped) 'skipped)
                       (otherwise 'failed)))
-              (backtrace (ert--record-backtrace))
+              ;; We store the backtrace in the result object for
+              ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+              ;; This means we have to limit `print-level' and
+              ;; `print-length' when printing result objects.  That
+              ;; might not be worth while when we can also use
+              ;; `ert-results-rerun-test-debugging-errors-at-point',
+              ;; (i.e., when running interactively) but having the
+              ;; backtrace ready for printing is important for batch
+              ;; use.
+              ;;
+              ;; Grab the frames starting from `signal', frames below
+              ;; that are all from the debugger.
+              (backtrace (backtrace-frames 'signal))
               (infos (reverse ert--infos)))
          (setf (ert--test-execution-info-result info)
                (cl-ecase type
@@ -1408,8 +1385,9 @@ 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))
+                 (ert--print-backtrace
+                  (ert-test-result-with-condition-backtrace result)
+                  nil)
                  (goto-char (point-min))
                  (while (not (eobp))
                    (let ((start (point))
@@ -1457,6 +1435,12 @@ The exit status will be 0 if all test results were as expected, 1
 on unexpected results, or 2 if the tool detected an error outside
 of the tests (e.g. invalid SELECTOR or bug in the code that runs
 the tests)."
+  (or noninteractive
+      (user-error "This function is only for use in batch mode"))
+  ;; Better crash loudly than attempting to recover from undefined
+  ;; behavior.
+  (setq attempt-stack-overflow-recovery nil
+        attempt-orderly-shutdown-on-fatal-signal nil)
   (unwind-protect
       (let ((stats (ert-run-tests-batch selector)))
         (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
@@ -1474,13 +1458,17 @@ The logfiles should have the `ert-run-tests-batch' format.  When finished,
 this exits Emacs, with status as per `ert-run-tests-batch-and-exit'."
   (or noninteractive
       (user-error "This function is only for use in batch mode"))
+  ;; Better crash loudly than attempting to recover from undefined
+  ;; behavior.
+  (setq attempt-stack-overflow-recovery nil
+        attempt-orderly-shutdown-on-fatal-signal nil)
   (let ((nlogs (length command-line-args-left))
         (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0)
         nnotrun logfile notests badtests unexpected skipped)
     (with-temp-buffer
       (while (setq logfile (pop command-line-args-left))
         (erase-buffer)
-        (insert-file-contents logfile)
+        (when (file-readable-p logfile) (insert-file-contents logfile))
         (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t))
             (push logfile notests)
           (setq ntests (+ ntests (string-to-number (match-string 1))))
@@ -1602,7 +1590,7 @@ Signals an error if no test name was read."
     (let ((sym (intern-soft input)))
       (if (ert-test-boundp sym)
           sym
-        (error "Input does not name a test")))))
+        (user-error "Input does not name a test")))))
 
 (defun ert-read-test-name-at-point (prompt)
   "Read the name of a test and return it as a symbol.
@@ -1628,7 +1616,7 @@ Nothing more than an interactive interface to `ert-make-test-unbound'."
   (interactive)
   (when (called-interactively-p 'any)
     (unless (y-or-n-p "Delete all tests? ")
-      (error "Aborted")))
+      (user-error "Aborted")))
   ;; We can't use `ert-select-tests' here since that gives us only
   ;; test objects, and going from them back to the test name symbols
   ;; can fail if the `ert-test' defstruct has been redefined.
@@ -1817,12 +1805,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'."
 
 BEGIN and END specify a region in the current buffer."
   (save-excursion
-    (save-restriction
-      (narrow-to-region begin end)
-      ;; Inhibit optimization in `debugger-make-xrefs' that would
-      ;; sometimes insert unrelated backtrace info into our buffer.
-      (let ((debugger-previous-backtrace nil))
-        (debugger-make-xrefs)))))
+    (goto-char begin)
+    (while (progn
+             (goto-char (+ (point) 2))
+             (skip-syntax-forward "^w_")
+             (< (point) end))
+      (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 'defun))))
+        (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 0 'help-function-def sym file)))
+      (forward-line 1))))
 
 (defun ert--string-first-line (s)
   "Return the first line of S, or S if it contains no newlines.
@@ -2141,7 +2140,7 @@ To be used in the ERT results buffer."
 
 To be used in the ERT results buffer."
   (or (ert--results-test-node-or-null-at-point)
-      (error "No test at point")))
+      (user-error "No test at point")))
 
 (defun ert-results-next-test ()
   "Move point to the next test.
@@ -2191,7 +2190,7 @@ To be used in the ERT results buffer."
   (interactive)
   (let ((name (ert-test-at-point)))
     (unless name
-      (error "No test at point"))
+      (user-error "No test at point"))
     (ert-find-test-other-window name)))
 
 (defun ert--test-name-button-action (button)
@@ -2352,7 +2351,7 @@ To be used in the ERT results buffer."
   (cl-destructuring-bind (test redefinition-state)
       (ert--results-test-at-point-allow-redefinition)
     (when (null test)
-      (error "No test at point"))
+      (user-error "No test at point"))
     (let* ((stats ert--results-stats)
            (progress-message (format "Running %stest %S"
                                      (cl-ecase redefinition-state
@@ -2409,8 +2408,7 @@ To be used in the ERT results buffer."
            ;; Use unibyte because `debugger-setup-buffer' also does so.
            (set-buffer-multibyte nil)
            (setq truncate-lines t)
-           (ert--print-backtrace backtrace)
-           (debugger-make-xrefs)
+           (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))
@@ -2525,7 +2523,7 @@ To be used in the ERT results buffer."
   "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
   (interactive (list (ert-read-test-name-at-point "Describe test")))
   (when (< emacs-major-version 24)
-    (error "Requires Emacs 24"))
+    (user-error "Requires Emacs 24 or later"))
   (let (test-name
         test-definition)
     (cl-etypecase test-or-test-name