Merge from origin/emacs-25

[gnu-emacs] / lisp / emacs-lisp / ert.el

diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 4ffd8cd85584ed9f3f4e22014cd16a360a7d2dbc..7a914da3977b207a4d13f71a95bd5075fef6c11a 100644 (file)
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -1,6 +1,6 @@
 ;;; ert.el --- Emacs Lisp Regression Testing  -*- lexical-binding: t -*-
 
 ;;; ert.el --- Emacs Lisp Regression Testing  -*- lexical-binding: t -*-
 

-;; Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc.

 
 ;; Author: Christian Ohler <ohler@gnu.org>
 ;; Keywords: lisp, tools
 
 ;; Author: Christian Ohler <ohler@gnu.org>
 ;; Keywords: lisp, tools


@@ -64,7 +64,7 @@
 (require 'ewoc)
 (require 'find-func)
 (require 'help)
 (require 'ewoc)
 (require 'find-func)
 (require 'help)

-
+(require 'pp)

 
 ;;; UI customization options.
 
 
 ;;; UI customization options.
 


@@ -187,7 +187,7 @@ using :expected-result.  See `ert-test-result-type-p' for a
 description of valid values for RESULT-TYPE.
 
 \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
 description of valid values for RESULT-TYPE.
 
 \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \

-\[:tags '(TAG...)] BODY...)"
+[:tags \\='(TAG...)] BODY...)"

   (declare (debug (&define :name test
                            name sexp [&optional stringp]
                           [&rest keywordp sexp] def-body))
   (declare (debug (&define :name test
                            name sexp [&optional stringp]
                           [&rest keywordp sexp] def-body))


@@ -269,7 +269,7 @@ DATA is displayed to the user and should state the reason for skipping."
 (defun ert--special-operator-p (thing)
   "Return non-nil if THING is a symbol naming a special operator."
   (and (symbolp thing)
 (defun ert--special-operator-p (thing)
   "Return non-nil if THING is a symbol naming a special operator."
   (and (symbolp thing)

-       (let ((definition (indirect-function thing t)))
+       (let ((definition (indirect-function thing)))

          (and (subrp definition)
               (eql (cdr (subr-arity definition)) 'unevalled)))))
 
          (and (subrp definition)
               (eql (cdr (subr-arity definition)) 'unevalled)))))
 


@@ -374,9 +374,9 @@ Returns nil."
 Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
 and aborts the current test as failed if it doesn't."
   (let ((signaled-conditions (get (car condition) 'error-conditions))
 Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
 and aborts the current test as failed if it doesn't."
   (let ((signaled-conditions (get (car condition) 'error-conditions))

-        (handled-conditions (cl-etypecase type
-                              (list type)
-                              (symbol (list type)))))
+        (handled-conditions (pcase-exhaustive type
+                              ((pred listp) type)
+                              ((pred symbolp) (list type)))))

     (cl-assert signaled-conditions)
     (unless (cl-intersection signaled-conditions handled-conditions)
       (ert-fail (append
     (cl-assert signaled-conditions)
     (unless (cl-intersection signaled-conditions handled-conditions)
       (ert-fail (append


@@ -466,18 +466,18 @@ Errors during evaluation are caught and handled like nil."
 
 (defun ert--explain-format-atom (x)
   "Format the atom X for `ert--explain-equal'."
 
 (defun ert--explain-format-atom (x)
   "Format the atom X for `ert--explain-equal'."

-  (cl-typecase x
-    (character (list x (format "#x%x" x) (format "?%c" x)))
-    (fixnum (list x (format "#x%x" x)))
-    (t x)))
+  (pcase x
+    ((pred characterp) (list x (format "#x%x" x) (format "?%c" x)))
+    ((pred integerp) (list x (format "#x%x" x)))
+    (_ x)))

 
 (defun ert--explain-equal-rec (a b)
   "Return a programmer-readable explanation of why A and B are not `equal'.
 Returns nil if they are."
   (if (not (equal (type-of a) (type-of b)))
       `(different-types ,a ,b)
 
 (defun ert--explain-equal-rec (a b)
   "Return a programmer-readable explanation of why A and B are not `equal'.
 Returns nil if they are."
   (if (not (equal (type-of a) (type-of b)))
       `(different-types ,a ,b)

-    (cl-etypecase a
-      (cons
+    (pcase-exhaustive a
+      ((pred consp)

        (let ((a-proper-p (ert--proper-list-p a))
              (b-proper-p (ert--proper-list-p b)))
          (if (not (eql (not a-proper-p) (not b-proper-p)))
        (let ((a-proper-p (ert--proper-list-p a))
              (b-proper-p (ert--proper-list-p b)))
          (if (not (eql (not a-proper-p) (not b-proper-p)))


@@ -502,24 +502,26 @@ Returns nil if they are."
                        `(cdr ,cdr-x)
                      (cl-assert (equal a b) t)
                      nil))))))))
                        `(cdr ,cdr-x)
                      (cl-assert (equal a b) t)
                      nil))))))))

-      (array (if (not (equal (length a) (length b)))
-                 `(arrays-of-different-length ,(length a) ,(length b)
-                                              ,a ,b
-                                              ,@(unless (char-table-p a)
-                                                  `(first-mismatch-at
-                                                    ,(cl-mismatch a b :test 'equal))))
-               (cl-loop for i from 0
-                        for ai across a
-                        for bi across b
-                        for xi = (ert--explain-equal-rec ai bi)
-                        do (when xi (cl-return `(array-elt ,i ,xi)))
-                        finally (cl-assert (equal a b) t))))
-      (atom (if (not (equal a b))
-                (if (and (symbolp a) (symbolp b) (string= a b))
-                    `(different-symbols-with-the-same-name ,a ,b)
-                  `(different-atoms ,(ert--explain-format-atom a)
-                                    ,(ert--explain-format-atom b)))
-              nil)))))
+      ((pred arrayp)
+       (if (not (equal (length a) (length b)))
+           `(arrays-of-different-length ,(length a) ,(length b)
+                                        ,a ,b
+                                        ,@(unless (char-table-p a)
+                                            `(first-mismatch-at
+                                              ,(cl-mismatch a b :test 'equal))))
+         (cl-loop for i from 0
+                  for ai across a
+                  for bi across b
+                  for xi = (ert--explain-equal-rec ai bi)
+                  do (when xi (cl-return `(array-elt ,i ,xi)))
+                  finally (cl-assert (equal a b) t))))
+      ((pred atom)
+       (if (not (equal a b))
+           (if (and (symbolp a) (symbolp b) (string= a b))
+               `(different-symbols-with-the-same-name ,a ,b)
+             `(different-atoms ,(ert--explain-format-atom a)
+                               ,(ert--explain-format-atom b)))
+         nil)))))

 
 (defun ert--explain-equal (a b)
   "Explainer function for `equal'."
 
 (defun ert--explain-equal (a b)
   "Explainer function for `equal'."


@@ -694,23 +696,20 @@ and is displayed in front of the value of MESSAGE-FORM."
         (print-level 8)
         (print-length 50))
     (dolist (frame backtrace)
         (print-level 8)
         (print-length 50))
     (dolist (frame backtrace)

-      (cl-ecase (car frame)
-        ((nil)
+      (pcase-exhaustive frame
+        (`(nil ,special-operator . ,arg-forms)

          ;; Special operator.
          ;; Special operator.

-         (cl-destructuring-bind (special-operator &rest arg-forms)
-             (cdr frame)
-           (insert
-            (format "  %S\n" (cons special-operator arg-forms)))))
-        ((t)
+         (insert
+          (format "  %S\n" (cons special-operator arg-forms))))
+        (`(t ,fn . ,args)

          ;; Function call.
          ;; Function call.

-         (cl-destructuring-bind (fn &rest args) (cdr frame)
-           (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")))))))
+         (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"))))))

 
 ;; A container for the state of the execution of a single test and
 ;; environment data needed during its execution.
 
 ;; A container for the state of the execution of a single test and
 ;; environment data needed during its execution.


@@ -887,40 +886,39 @@ Valid result types:
 nil -- Never matches.
 t -- Always matches.
 :failed, :passed, :skipped -- Matches corresponding results.
 nil -- Never matches.
 t -- Always matches.
 :failed, :passed, :skipped -- Matches corresponding results.

-\(and TYPES...\) -- Matches if all TYPES match.
-\(or TYPES...\) -- Matches if some TYPES match.
-\(not TYPE\) -- Matches if TYPE does not match.
-\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
+\(and TYPES...) -- Matches if all TYPES match.
+\(or TYPES...) -- Matches if some TYPES match.
+\(not TYPE) -- Matches if TYPE does not match.
+\(satisfies PREDICATE) -- Matches if PREDICATE returns true when called with

                            RESULT."
   ;; It would be easy to add `member' and `eql' types etc., but I
   ;; haven't bothered yet.
                            RESULT."
   ;; It would be easy to add `member' and `eql' types etc., but I
   ;; haven't bothered yet.

-  (cl-etypecase result-type
-    ((member nil) nil)
-    ((member t) t)
-    ((member :failed) (ert-test-failed-p result))
-    ((member :passed) (ert-test-passed-p result))
-    ((member :skipped) (ert-test-skipped-p result))
-    (cons
-     (cl-destructuring-bind (operator &rest operands) result-type
-       (cl-ecase operator
-         (and
-          (cl-case (length operands)
-            (0 t)
-            (t
-             (and (ert-test-result-type-p result (car operands))
-                  (ert-test-result-type-p result `(and ,@(cdr operands)))))))
-         (or
-          (cl-case (length operands)
-            (0 nil)
-            (t
-             (or (ert-test-result-type-p result (car operands))
-                 (ert-test-result-type-p result `(or ,@(cdr operands)))))))
-         (not
-          (cl-assert (eql (length operands) 1))
-          (not (ert-test-result-type-p result (car operands))))
-         (satisfies
-          (cl-assert (eql (length operands) 1))
-          (funcall (car operands) result)))))))
+  (pcase-exhaustive result-type
+    ('nil nil)
+    ('t t)
+    (:failed (ert-test-failed-p result))
+    (:passed (ert-test-passed-p result))
+    (:skipped (ert-test-skipped-p result))
+    (`(,operator . ,operands)
+     (cl-ecase operator
+       (and
+        (cl-case (length operands)
+          (0 t)
+          (t
+           (and (ert-test-result-type-p result (car operands))
+                (ert-test-result-type-p result `(and ,@(cdr operands)))))))
+       (or
+        (cl-case (length operands)
+          (0 nil)
+          (t
+           (or (ert-test-result-type-p result (car operands))
+               (ert-test-result-type-p result `(or ,@(cdr operands)))))))
+       (not
+        (cl-assert (eql (length operands) 1))
+        (not (ert-test-result-type-p result (car operands))))
+       (satisfies
+        (cl-assert (eql (length operands) 1))
+        (funcall (car operands) result))))))

 
 (defun ert-test-result-expected-p (test result)
   "Return non-nil if TEST's expected result type matches RESULT."
 
 (defun ert-test-result-expected-p (test result)
   "Return non-nil if TEST's expected result type matches RESULT."


@@ -946,7 +944,7 @@ a test   -- (i.e., an object of the ert-test data-type) Selects that test.
 a symbol -- Selects the test that the symbol names, errors if none.
 \(member TESTS...) -- Selects the elements of TESTS, a list of tests
     or symbols naming tests.
 a symbol -- Selects the test that the symbol names, errors if none.
 \(member TESTS...) -- Selects the elements of TESTS, a list of tests
     or symbols naming tests.

-\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
+\(eql TEST) -- Selects TEST, a test or a symbol naming a test.

 \(and SELECTORS...) -- Selects the tests that match all SELECTORS.
 \(or SELECTORS...)  -- Selects the tests that match any of the SELECTORS.
 \(not SELECTOR)     -- Selects all tests that do not match SELECTOR.
 \(and SELECTORS...) -- Selects the tests that match all SELECTORS.
 \(or SELECTORS...)  -- Selects the tests that match any of the SELECTORS.
 \(not SELECTOR)     -- Selects all tests that do not match SELECTOR.


@@ -961,95 +959,96 @@ as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
 Selectors that do not, such as (member ...), just return the
 set implied by them without checking whether it is really
 contained in UNIVERSE."
 Selectors that do not, such as (member ...), just return the
 set implied by them without checking whether it is really
 contained in UNIVERSE."

-  ;; This code needs to match the etypecase in
+  ;; This code needs to match the cases in

   ;; `ert-insert-human-readable-selector'.
   ;; `ert-insert-human-readable-selector'.

-  (cl-etypecase selector
-    ((member nil) nil)
-    ((member t) (cl-etypecase universe
-                  (list universe)
-                  ((member t) (ert-select-tests "" universe))))
-    ((member :new) (ert-select-tests
-                    `(satisfies ,(lambda (test)
-                                   (null (ert-test-most-recent-result test))))
-                    universe))
-    ((member :failed) (ert-select-tests
-                       `(satisfies ,(lambda (test)
-                                      (ert-test-result-type-p
-                                       (ert-test-most-recent-result test)
-                                       ':failed)))
-                       universe))
-    ((member :passed) (ert-select-tests
-                       `(satisfies ,(lambda (test)
-                                      (ert-test-result-type-p
-                                       (ert-test-most-recent-result test)
-                                       ':passed)))
-                       universe))
-    ((member :expected) (ert-select-tests
-                         `(satisfies
-                           ,(lambda (test)
-                              (ert-test-result-expected-p
-                               test
-                               (ert-test-most-recent-result test))))
-                         universe))
-    ((member :unexpected) (ert-select-tests `(not :expected) universe))
-    (string
-     (cl-etypecase universe
-       ((member t) (mapcar #'ert-get-test
-                           (apropos-internal selector #'ert-test-boundp)))
-       (list (cl-remove-if-not (lambda (test)
-                                   (and (ert-test-name test)
-                                        (string-match selector
-                                                      (symbol-name
-                                                       (ert-test-name test)))))
-                                 universe))))
-    (ert-test (list selector))
-    (symbol
+  (pcase-exhaustive selector
+    ('nil nil)
+    ('t (pcase-exhaustive universe
+          ((pred listp) universe)
+          (`t (ert-select-tests "" universe))))
+    (:new (ert-select-tests
+           `(satisfies ,(lambda (test)
+                          (null (ert-test-most-recent-result test))))
+           universe))
+    (:failed (ert-select-tests
+              `(satisfies ,(lambda (test)
+                             (ert-test-result-type-p
+                              (ert-test-most-recent-result test)
+                              ':failed)))
+              universe))
+    (:passed (ert-select-tests
+              `(satisfies ,(lambda (test)
+                             (ert-test-result-type-p
+                              (ert-test-most-recent-result test)
+                              ':passed)))
+              universe))
+    (:expected (ert-select-tests
+                `(satisfies
+                  ,(lambda (test)
+                     (ert-test-result-expected-p
+                      test
+                      (ert-test-most-recent-result test))))
+                universe))
+    (:unexpected (ert-select-tests `(not :expected) universe))
+    ((pred stringp)
+     (pcase-exhaustive universe
+       (`t (mapcar #'ert-get-test
+                   (apropos-internal selector #'ert-test-boundp)))
+       ((pred listp)
+        (cl-remove-if-not (lambda (test)
+                            (and (ert-test-name test)
+                                 (string-match selector
+                                               (symbol-name
+                                                (ert-test-name test)))))
+                          universe))))
+    ((pred ert-test-p) (list selector))
+    ((pred symbolp)

      (cl-assert (ert-test-boundp selector))
      (list (ert-get-test selector)))
      (cl-assert (ert-test-boundp selector))
      (list (ert-get-test selector)))

-    (cons
-     (cl-destructuring-bind (operator &rest operands) selector
-       (cl-ecase operator
-         (member
-          (mapcar (lambda (purported-test)
-                    (cl-etypecase purported-test
-                      (symbol (cl-assert (ert-test-boundp purported-test))
-                              (ert-get-test purported-test))
-                      (ert-test purported-test)))
-                  operands))
-         (eql
-          (cl-assert (eql (length operands) 1))
-          (ert-select-tests `(member ,@operands) universe))
-         (and
-          ;; Do these definitions of AND, NOT and OR satisfy de
-          ;; Morgan's laws?  Should they?
-          (cl-case (length operands)
-            (0 (ert-select-tests 't universe))
-            (t (ert-select-tests `(and ,@(cdr operands))
-                                 (ert-select-tests (car operands)
-                                                   universe)))))
-         (not
-          (cl-assert (eql (length operands) 1))
-          (let ((all-tests (ert-select-tests 't universe)))
-            (cl-set-difference all-tests
-                                 (ert-select-tests (car operands)
-                                                   all-tests))))
-         (or
-          (cl-case (length operands)
-            (0 (ert-select-tests 'nil universe))
-            (t (cl-union (ert-select-tests (car operands) universe)
-                           (ert-select-tests `(or ,@(cdr operands))
-                                             universe)))))
-         (tag
-          (cl-assert (eql (length operands) 1))
-          (let ((tag (car operands)))
-            (ert-select-tests `(satisfies
-                                ,(lambda (test)
-                                   (member tag (ert-test-tags test))))
-                              universe)))
-         (satisfies
-          (cl-assert (eql (length operands) 1))
-          (cl-remove-if-not (car operands)
-                              (ert-select-tests 't universe))))))))
+    (`(,operator . ,operands)
+     (cl-ecase operator
+       (member
+        (mapcar (lambda (purported-test)
+                  (pcase-exhaustive purported-test
+                    ((pred symbolp)
+                     (cl-assert (ert-test-boundp purported-test))
+                     (ert-get-test purported-test))
+                    ((pred ert-test-p) purported-test)))
+                operands))
+       (eql
+        (cl-assert (eql (length operands) 1))
+        (ert-select-tests `(member ,@operands) universe))
+       (and
+        ;; Do these definitions of AND, NOT and OR satisfy de
+        ;; Morgan's laws?  Should they?
+        (cl-case (length operands)
+          (0 (ert-select-tests 't universe))
+          (t (ert-select-tests `(and ,@(cdr operands))
+                               (ert-select-tests (car operands)
+                                                 universe)))))
+       (not
+        (cl-assert (eql (length operands) 1))
+        (let ((all-tests (ert-select-tests 't universe)))
+          (cl-set-difference all-tests
+                             (ert-select-tests (car operands)
+                                               all-tests))))
+       (or
+        (cl-case (length operands)
+          (0 (ert-select-tests 'nil universe))
+          (t (cl-union (ert-select-tests (car operands) universe)
+                       (ert-select-tests `(or ,@(cdr operands))
+                                         universe)))))
+       (tag
+        (cl-assert (eql (length operands) 1))
+        (let ((tag (car operands)))
+          (ert-select-tests `(satisfies
+                              ,(lambda (test)
+                                 (member tag (ert-test-tags test))))
+                            universe)))
+       (satisfies
+        (cl-assert (eql (length operands) 1))
+        (cl-remove-if-not (car operands)
+                          (ert-select-tests 't universe)))))))

 
 (defun ert--insert-human-readable-selector (selector)
   "Insert a human-readable presentation of SELECTOR into the current buffer."
 
 (defun ert--insert-human-readable-selector (selector)
   "Insert a human-readable presentation of SELECTOR into the current buffer."


@@ -1058,26 +1057,24 @@ contained in UNIVERSE."
   ;; `most-recent-result' slots of test case objects in (eql ...) or
   ;; (member ...) selectors.
   (cl-labels ((rec (selector)
   ;; `most-recent-result' slots of test case objects in (eql ...) or
   ;; (member ...) selectors.
   (cl-labels ((rec (selector)

-                ;; This code needs to match the etypecase in
+                ;; This code needs to match the cases in

                 ;; `ert-select-tests'.
                 ;; `ert-select-tests'.

-                (cl-etypecase selector
-                  ((or (member nil t
-                               :new :failed :passed
-                               :expected :unexpected)
-                       string
-                       symbol)
+                (pcase-exhaustive selector
+                  ((or
+                    ;; 'nil 't :new :failed :passed :expected :unexpected
+                    (pred stringp)
+                    (pred symbolp))

                    selector)
                    selector)

-                  (ert-test
+                  ((pred ert-test-p)

                    (if (ert-test-name selector)
                        (make-symbol (format "<%S>" (ert-test-name selector)))
                      (make-symbol "<unnamed test>")))
                    (if (ert-test-name selector)
                        (make-symbol (format "<%S>" (ert-test-name selector)))
                      (make-symbol "<unnamed test>")))

-                  (cons
-                   (cl-destructuring-bind (operator &rest operands) selector
-                     (cl-ecase operator
-                       ((member eql and not or)
-                        `(,operator ,@(mapcar #'rec operands)))
-                       ((member tag satisfies)
-                        selector)))))))
+                  (`(,operator . ,operands)
+                   (pcase operator
+                     ((or 'member 'eql 'and 'not 'or)
+                      `(,operator ,@(mapcar #'rec operands)))
+                     ((or 'tag 'satisfies)
+                      selector))))))

     (insert (format "%S" (rec selector)))))
 
 
     (insert (format "%S" (rec selector)))))
 
 


@@ -1300,7 +1297,8 @@ EXPECTEDP specifies whether the result was expected."
 (defun ert--pp-with-indentation-and-newline (object)
   "Pretty-print OBJECT, indenting it to the current column of point.
 Ensures a final newline is inserted."
 (defun ert--pp-with-indentation-and-newline (object)
   "Pretty-print OBJECT, indenting it to the current column of point.
 Ensures a final newline is inserted."

-  (let ((begin (point)))
+  (let ((begin (point))
+        (pp-escape-newlines nil))

     (pp object (current-buffer))
     (unless (bolp) (insert "\n"))
     (save-excursion
     (pp object (current-buffer))
     (unless (bolp) (insert "\n"))
     (save-excursion


@@ -1849,7 +1847,9 @@ non-nil, returns the face for expected results.."
              (when (ert-test-documentation test)
                (insert "    "
                        (propertize
              (when (ert-test-documentation test)
                (insert "    "
                        (propertize

-                        (ert--string-first-line (ert-test-documentation test))
+                        (ert--string-first-line
+                         (substitute-command-keys
+                          (ert-test-documentation test)))

                         'font-lock-face 'font-lock-doc-face)
                        "\n"))
              (cl-etypecase result
                         'font-lock-face 'font-lock-doc-face)
                        "\n"))
              (cl-etypecase result


@@ -2128,12 +2128,12 @@ To be used in the ERT results buffer."
   "Move point from NODE to the previous or next node.
 
 EWOC-FN specifies the direction and should be either `ewoc-prev'
   "Move point from NODE to the previous or next node.
 
 EWOC-FN specifies the direction and should be either `ewoc-prev'

-or `ewoc-next'.  If there are no more nodes in that direction, an
-error is signaled with the message ERROR-MESSAGE."
+or `ewoc-next'.  If there are no more nodes in that direction, a
+user-error is signaled with the message ERROR-MESSAGE."

   (cl-loop
    (setq node (funcall ewoc-fn ert--results-ewoc node))
    (when (null node)
   (cl-loop
    (setq node (funcall ewoc-fn ert--results-ewoc node))
    (when (null node)

-     (error "%s" error-message))
+     (user-error "%s" error-message))

    (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
      (goto-char (ewoc-location node))
      (cl-return))))
    (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
      (goto-char (ewoc-location node))
      (cl-return))))


@@ -2375,9 +2375,9 @@ To be used in the ERT results buffer."
            (ert--print-backtrace backtrace)
            (debugger-make-xrefs)
            (goto-char (point-min))
            (ert--print-backtrace backtrace)
            (debugger-make-xrefs)
            (goto-char (point-min))

-           (insert "Backtrace for test `")
+           (insert (substitute-command-keys "Backtrace for test `"))

            (ert-insert-test-name-button (ert-test-name test))
            (ert-insert-test-name-button (ert-test-name test))

-           (insert "':\n")))))))
+           (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.
 
 (defun ert-results-pop-to-messages-for-test-at-point ()
   "Display the part of the *Messages* buffer generated during the test at point.


@@ -2396,9 +2396,9 @@ To be used in the ERT results buffer."
         (ert-simple-view-mode)
         (insert (ert-test-result-messages result))
         (goto-char (point-min))
         (ert-simple-view-mode)
         (insert (ert-test-result-messages result))
         (goto-char (point-min))

-        (insert "Messages for test `")
+        (insert (substitute-command-keys "Messages for test `"))

         (ert-insert-test-name-button (ert-test-name test))
         (ert-insert-test-name-button (ert-test-name test))

-        (insert "':\n")))))
+        (insert (substitute-command-keys "':\n"))))))

 
 (defun ert-results-pop-to-should-forms-for-test-at-point ()
   "Display the list of `should' forms executed during the test at point.
 
 (defun ert-results-pop-to-should-forms-for-test-at-point ()
   "Display the list of `should' forms executed during the test at point.


@@ -2426,9 +2426,10 @@ To be used in the ERT results buffer."
                      (ert--pp-with-indentation-and-newline form-description)
                      (ert--make-xrefs-region begin (point)))))
         (goto-char (point-min))
                      (ert--pp-with-indentation-and-newline form-description)
                      (ert--make-xrefs-region begin (point)))))
         (goto-char (point-min))

-        (insert "`should' forms executed during test `")
+        (insert (substitute-command-keys
+                 "`should' forms executed during test `"))

         (ert-insert-test-name-button (ert-test-name test))
         (ert-insert-test-name-button (ert-test-name test))

-        (insert "':\n")
+        (insert (substitute-command-keys "':\n"))

         (insert "\n")
         (insert (concat "(Values are shallow copies and may have "
                         "looked different during the test if they\n"
         (insert "\n")
         (insert (concat "(Values are shallow copies and may have "
                         "looked different during the test if they\n"


@@ -2505,9 +2506,11 @@ To be used in the ERT results buffer."
           (let ((file-name (and test-name
                                 (symbol-file test-name 'ert-deftest))))
             (when file-name
           (let ((file-name (and test-name
                                 (symbol-file test-name 'ert-deftest))))
             (when file-name

-              (insert " defined in `" (file-name-nondirectory file-name) "'")
+              (insert (format-message " defined in `%s'"
+                                      (file-name-nondirectory file-name)))

               (save-excursion
               (save-excursion

-                (re-search-backward "`\\([^`']+\\)'" nil t)
+                (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
+                                    nil t)

                 (help-xref-button 1 'help-function-def test-name file-name)))
             (insert ".")
             (fill-region-as-paragraph (point-min) (point))
                 (help-xref-button 1 'help-function-def test-name file-name)))
             (insert ".")
             (fill-region-as-paragraph (point-min) (point))


@@ -2519,8 +2522,9 @@ To be used in the ERT results buffer."
                         "this documentation refers to an old definition.")
                 (fill-region-as-paragraph begin (point)))
               (insert "\n\n"))
                         "this documentation refers to an old definition.")
                 (fill-region-as-paragraph begin (point)))
               (insert "\n\n"))

-            (insert (or (ert-test-documentation test-definition)
-                        "It is not documented.")
+            (insert (substitute-command-keys
+                     (or (ert-test-documentation test-definition)
+                         "It is not documented."))

                     "\n")))))))
 
 (defun ert-results-describe-test-at-point ()
                     "\n")))))))
 
 (defun ert-results-describe-test-at-point ()


@@ -2537,7 +2541,7 @@ To be used in the ERT results buffer."
 (add-to-list 'minor-mode-alist '(ert--current-run-stats
                                  (:eval
                                   (ert--tests-running-mode-line-indicator))))
 (add-to-list 'minor-mode-alist '(ert--current-run-stats
                                  (:eval
                                   (ert--tests-running-mode-line-indicator))))

-(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords)
+(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords)

 
 (defun ert--unload-function ()
   "Unload function to undo the side-effects of loading ert.el."
 
 (defun ert--unload-function ()
   "Unload function to undo the side-effects of loading ert.el."


@@ -2548,7 +2552,7 @@ To be used in the ERT results buffer."
   nil)
 
 (defvar ert-unload-hook '())
   nil)
 
 (defvar ert-unload-hook '())

-(add-hook 'ert-unload-hook 'ert--unload-function)
+(add-hook 'ert-unload-hook #'ert--unload-function)

 
 
 (provide 'ert)
 
 
 (provide 'ert)