aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2012-11-22 22:26:09 -0500
committerStefan Monnier2012-11-22 22:26:09 -0500
commit15c9d04ea4b75254aef346161998e08509736fc0 (patch)
tree98600640d98fffd8a91734bba4943134067aca02
parentaa8715fbdb6c619666f7213a9ec8615b31b01517 (diff)
downloademacs-15c9d04ea4b75254aef346161998e08509736fc0.tar.gz
emacs-15c9d04ea4b75254aef346161998e08509736fc0.zip
* emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding.
-rw-r--r--lisp/ChangeLog8
-rw-r--r--lisp/emacs-lisp/ert-x.el47
-rw-r--r--lisp/emacs-lisp/ert.el789
3 files changed, 429 insertions, 415 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 01d6ce0d865..1fb8ca6d67e 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,7 @@
12012-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding.
4
12012-11-22 Paul Eggert <eggert@cs.ucla.edu> 52012-11-22 Paul Eggert <eggert@cs.ucla.edu>
2 6
3 * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh 7 * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh
@@ -5,8 +9,8 @@
5 (calc-gregorian-switch): In menu, put dates before regions. 9 (calc-gregorian-switch): In menu, put dates before regions.
6 This is easier to follow, lines up better in the menu, and lets us 10 This is easier to follow, lines up better in the menu, and lets us
7 coalesce regions that switch at the same time. Give country 11 coalesce regions that switch at the same time. Give country
8 names, not "Vatican", as that's better for non-expert users. Use 12 names, not "Vatican", as that's better for non-expert users.
9 names that are stable between the date of switch and now, e.g., 13 Use names that are stable between the date of switch and now, e.g.,
10 Bohemia and Moravia (which existed then and now) and not 14 Bohemia and Moravia (which existed then and now) and not
11 Czechoslovakia (which didn't exist then and doesn't exist now). 15 Czechoslovakia (which didn't exist then and doesn't exist now).
12 What is now the U.S. mostly did not switch at the same time as 16 What is now the U.S. mostly did not switch at the same time as
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index c3b8e5e10d4..60d74774e87 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -1,4 +1,4 @@
1;;; ert-x.el --- Staging area for experimental extensions to ERT 1;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. 3;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
4 4
@@ -28,8 +28,7 @@
28 28
29;;; Code: 29;;; Code:
30 30
31(eval-when-compile 31(eval-when-compile (require 'cl-lib))
32 (require 'cl))
33(require 'ert) 32(require 'ert)
34 33
35 34
@@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current."
90 (kill-buffer ert--buffer) 89 (kill-buffer ert--buffer)
91 (remhash ert--buffer ert--test-buffers)))) 90 (remhash ert--buffer ert--test-buffers))))
92 91
93(defmacro* ert-with-test-buffer ((&key ((:name name-form))) 92(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)))
94 &body body) 93 &body body)
95 "Create a test buffer and run BODY in that buffer. 94 "Create a test buffer and run BODY in that buffer.
96 95
97To be used in ERT tests. If BODY finishes successfully, the test 96To be used in ERT tests. If BODY finishes successfully, the test
@@ -116,10 +115,10 @@ the name of the test and the result of NAME-FORM."
116 "Kill all test buffers that are still live." 115 "Kill all test buffers that are still live."
117 (interactive) 116 (interactive)
118 (let ((count 0)) 117 (let ((count 0))
119 (maphash (lambda (buffer dummy) 118 (maphash (lambda (buffer _dummy)
120 (when (or (not (buffer-live-p buffer)) 119 (when (or (not (buffer-live-p buffer))
121 (kill-buffer buffer)) 120 (kill-buffer buffer))
122 (incf count))) 121 (cl-incf count)))
123 ert--test-buffers) 122 ert--test-buffers)
124 (message "%s out of %s test buffers killed" 123 (message "%s out of %s test buffers killed"
125 count (hash-table-count ert--test-buffers))) 124 count (hash-table-count ert--test-buffers)))
@@ -149,9 +148,9 @@ the rest are arguments to the command.
149 148
150NOTE: Since the command is not called by `call-interactively' 149NOTE: Since the command is not called by `call-interactively'
151test for `called-interactively' in the command will fail." 150test for `called-interactively' in the command will fail."
152 (assert (listp command) t) 151 (cl-assert (listp command) t)
153 (assert (commandp (car command)) t) 152 (cl-assert (commandp (car command)) t)
154 (assert (not unread-command-events) t) 153 (cl-assert (not unread-command-events) t)
155 (let (return-value) 154 (let (return-value)
156 ;; For the order of things here see command_loop_1 in keyboard.c. 155 ;; For the order of things here see command_loop_1 in keyboard.c.
157 ;; 156 ;;
@@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail."
175 (when (boundp 'last-repeatable-command) 174 (when (boundp 'last-repeatable-command)
176 (setq last-repeatable-command real-last-command)) 175 (setq last-repeatable-command real-last-command))
177 (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) 176 (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
178 (assert (not unread-command-events) t) 177 (cl-assert (not unread-command-events) t)
179 return-value)) 178 return-value))
180 179
181(defun ert-run-idle-timers () 180(defun ert-run-idle-timers ()
@@ -198,7 +197,7 @@ rather than the entire match."
198 (with-temp-buffer 197 (with-temp-buffer
199 (insert s) 198 (insert s)
200 (dolist (x regexps) 199 (dolist (x regexps)
201 (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) 200 (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
202 (goto-char (point-min)) 201 (goto-char (point-min))
203 (while (re-search-forward regexp nil t) 202 (while (re-search-forward regexp nil t)
204 (replace-match "" t t nil subexp)))) 203 (replace-match "" t t nil subexp))))
@@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring
224None of the ARGS are modified, but the return value may share 223None of the ARGS are modified, but the return value may share
225structure with the plists in ARGS." 224structure with the plists in ARGS."
226 (with-temp-buffer 225 (with-temp-buffer
227 (loop with current-plist = nil 226 (cl-loop with current-plist = nil
228 for x in args do 227 for x in args do
229 (etypecase x 228 (cl-etypecase x
230 (string (let ((begin (point))) 229 (string (let ((begin (point)))
231 (insert x) 230 (insert x)
232 (set-text-properties begin (point) current-plist))) 231 (set-text-properties begin (point) current-plist)))
233 (list (unless (zerop (mod (length x) 2)) 232 (list (unless (zerop (mod (length x) 2))
234 (error "Odd number of args in plist: %S" x)) 233 (error "Odd number of args in plist: %S" x))
235 (setq current-plist x)))) 234 (setq current-plist x))))
236 (buffer-string))) 235 (buffer-string)))
237 236
238 237
@@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME.
245 244
246This is useful if THUNK has undesirable side-effects on an Emacs 245This is useful if THUNK has undesirable side-effects on an Emacs
247buffer with a fixed name such as *Messages*." 246buffer with a fixed name such as *Messages*."
248 (lexical-let ((new-buffer-name (generate-new-buffer-name 247 (let ((new-buffer-name (generate-new-buffer-name
249 (format "%s orig buffer" buffer-name)))) 248 (format "%s orig buffer" buffer-name))))
250 (with-current-buffer (get-buffer-create buffer-name) 249 (with-current-buffer (get-buffer-create buffer-name)
251 (rename-buffer new-buffer-name)) 250 (rename-buffer new-buffer-name))
252 (unwind-protect 251 (unwind-protect
@@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*."
258 (with-current-buffer new-buffer-name 257 (with-current-buffer new-buffer-name
259 (rename-buffer buffer-name))))) 258 (rename-buffer buffer-name)))))
260 259
261(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) 260(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body)
262 "Protect the buffer named BUFFER-NAME from side-effects and run BODY. 261 "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
263 262
264See `ert-call-with-buffer-renamed' for details." 263See `ert-call-with-buffer-renamed' for details."
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 9cbf417d876..ab6dcb58143 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -1,4 +1,4 @@
1;;; ert.el --- Emacs Lisp Regression Testing 1;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. 3;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
4 4
@@ -54,8 +54,7 @@
54 54
55;;; Code: 55;;; Code:
56 56
57(eval-when-compile 57(eval-when-compile (require 'cl-lib))
58 (require 'cl))
59(require 'button) 58(require 'button)
60(require 'debug) 59(require 'debug)
61(require 'easymenu) 60(require 'easymenu)
@@ -105,33 +104,33 @@
105 "A reimplementation of `remove-if-not'. 104 "A reimplementation of `remove-if-not'.
106 105
107ERT-PRED is a predicate, ERT-LIST is the input list." 106ERT-PRED is a predicate, ERT-LIST is the input list."
108 (loop for ert-x in ert-list 107 (cl-loop for ert-x in ert-list
109 if (funcall ert-pred ert-x) 108 if (funcall ert-pred ert-x)
110 collect ert-x)) 109 collect ert-x))
111 110
112(defun ert--intersection (a b) 111(defun ert--intersection (a b)
113 "A reimplementation of `intersection'. Intersect the sets A and B. 112 "A reimplementation of `intersection'. Intersect the sets A and B.
114 113
115Elements are compared using `eql'." 114Elements are compared using `eql'."
116 (loop for x in a 115 (cl-loop for x in a
117 if (memql x b) 116 if (memql x b)
118 collect x)) 117 collect x))
119 118
120(defun ert--set-difference (a b) 119(defun ert--set-difference (a b)
121 "A reimplementation of `set-difference'. Subtract the set B from the set A. 120 "A reimplementation of `set-difference'. Subtract the set B from the set A.
122 121
123Elements are compared using `eql'." 122Elements are compared using `eql'."
124 (loop for x in a 123 (cl-loop for x in a
125 unless (memql x b) 124 unless (memql x b)
126 collect x)) 125 collect x))
127 126
128(defun ert--set-difference-eq (a b) 127(defun ert--set-difference-eq (a b)
129 "A reimplementation of `set-difference'. Subtract the set B from the set A. 128 "A reimplementation of `set-difference'. Subtract the set B from the set A.
130 129
131Elements are compared using `eq'." 130Elements are compared using `eq'."
132 (loop for x in a 131 (cl-loop for x in a
133 unless (memq x b) 132 unless (memq x b)
134 collect x)) 133 collect x))
135 134
136(defun ert--union (a b) 135(defun ert--union (a b)
137 "A reimplementation of `union'. Compute the union of the sets A and B. 136 "A reimplementation of `union'. Compute the union of the sets A and B.
@@ -149,7 +148,7 @@ Elements are compared using `eql'."
149 (make-symbol (format "%s%s" 148 (make-symbol (format "%s%s"
150 prefix 149 prefix
151 (prog1 ert--gensym-counter 150 (prog1 ert--gensym-counter
152 (incf ert--gensym-counter)))))) 151 (cl-incf ert--gensym-counter))))))
153 152
154(defun ert--coerce-to-vector (x) 153(defun ert--coerce-to-vector (x)
155 "Coerce X to a vector." 154 "Coerce X to a vector."
@@ -158,19 +157,19 @@ Elements are compared using `eql'."
158 x 157 x
159 (vconcat x))) 158 (vconcat x)))
160 159
161(defun* ert--remove* (x list &key key test) 160(cl-defun ert--remove* (x list &key key test)
162 "Does not support all the keywords of remove*." 161 "Does not support all the keywords of remove*."
163 (unless key (setq key #'identity)) 162 (unless key (setq key #'identity))
164 (unless test (setq test #'eql)) 163 (unless test (setq test #'eql))
165 (loop for y in list 164 (cl-loop for y in list
166 unless (funcall test x (funcall key y)) 165 unless (funcall test x (funcall key y))
167 collect y)) 166 collect y))
168 167
169(defun ert--string-position (c s) 168(defun ert--string-position (c s)
170 "Return the position of the first occurrence of C in S, or nil if none." 169 "Return the position of the first occurrence of C in S, or nil if none."
171 (loop for i from 0 170 (cl-loop for i from 0
172 for x across s 171 for x across s
173 when (eql x c) return i)) 172 when (eql x c) return i))
174 173
175(defun ert--mismatch (a b) 174(defun ert--mismatch (a b)
176 "Return index of first element that differs between A and B. 175 "Return index of first element that differs between A and B.
@@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison."
184 (t 183 (t
185 (let ((la (length a)) 184 (let ((la (length a))
186 (lb (length b))) 185 (lb (length b)))
187 (assert (arrayp a) t) 186 (cl-assert (arrayp a) t)
188 (assert (arrayp b) t) 187 (cl-assert (arrayp b) t)
189 (assert (<= la lb) t) 188 (cl-assert (<= la lb) t)
190 (loop for i below la 189 (cl-loop for i below la
191 when (not (equal (aref a i) (aref b i))) return i 190 when (not (equal (aref a i) (aref b i))) return i
192 finally (return (if (/= la lb) 191 finally (cl-return (if (/= la lb)
193 la 192 la
194 (assert (equal a b) t) 193 (cl-assert (equal a b) t)
195 nil))))))) 194 nil)))))))
196 195
197(defun ert--subseq (seq start &optional end) 196(defun ert--subseq (seq start &optional end)
198 "Return a subsequence of SEQ from START to END." 197 "Return a subsequence of SEQ from START to END."
199 (when (char-table-p seq) (error "Not supported")) 198 (when (char-table-p seq) (error "Not supported"))
200 (let ((vector (substring (ert--coerce-to-vector seq) start end))) 199 (let ((vector (substring (ert--coerce-to-vector seq) start end)))
201 (etypecase seq 200 (cl-etypecase seq
202 (vector vector) 201 (vector vector)
203 (string (concat vector)) 202 (string (concat vector))
204 (list (append vector nil)) 203 (list (append vector nil))
205 (bool-vector (loop with result = (make-bool-vector (length vector) nil) 204 (bool-vector (cl-loop with result
206 for i below (length vector) do 205 = (make-bool-vector (length vector) nil)
207 (setf (aref result i) (aref vector i)) 206 for i below (length vector) do
208 finally (return result))) 207 (setf (aref result i) (aref vector i))
209 (char-table (assert nil))))) 208 finally (cl-return result)))
209 (char-table (cl-assert nil)))))
210 210
211(defun ert-equal-including-properties (a b) 211(defun ert-equal-including-properties (a b)
212 "Return t if A and B have similar structure and contents. 212 "Return t if A and B have similar structure and contents.
@@ -225,10 +225,10 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
225;;; Defining and locating tests. 225;;; Defining and locating tests.
226 226
227;; The data structure that represents a test case. 227;; The data structure that represents a test case.
228(defstruct ert-test 228(cl-defstruct ert-test
229 (name nil) 229 (name nil)
230 (documentation nil) 230 (documentation nil)
231 (body (assert nil)) 231 (body (cl-assert nil))
232 (most-recent-result nil) 232 (most-recent-result nil)
233 (expected-result-type ':passed) 233 (expected-result-type ':passed)
234 (tags '())) 234 (tags '()))
@@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist
273and the body." 273and the body."
274 (let ((extracted-key-accu '()) 274 (let ((extracted-key-accu '())
275 (remaining keys-and-body)) 275 (remaining keys-and-body))
276 (while (and (consp remaining) (keywordp (first remaining))) 276 (while (keywordp (car-safe remaining))
277 (let ((keyword (pop remaining))) 277 (let ((keyword (pop remaining)))
278 (unless (consp remaining) 278 (unless (consp remaining)
279 (error "Value expected after keyword %S in %S" 279 (error "Value expected after keyword %S in %S"
@@ -283,13 +283,13 @@ and the body."
283 keys-and-body)) 283 keys-and-body))
284 (push (cons keyword (pop remaining)) extracted-key-accu))) 284 (push (cons keyword (pop remaining)) extracted-key-accu)))
285 (setq extracted-key-accu (nreverse extracted-key-accu)) 285 (setq extracted-key-accu (nreverse extracted-key-accu))
286 (list (loop for (key . value) in extracted-key-accu 286 (list (cl-loop for (key . value) in extracted-key-accu
287 collect key 287 collect key
288 collect value) 288 collect value)
289 remaining))) 289 remaining)))
290 290
291;;;###autoload 291;;;###autoload
292(defmacro* ert-deftest (name () &body docstring-keys-and-body) 292(cl-defmacro ert-deftest (name () &body docstring-keys-and-body)
293 "Define NAME (a symbol) as a test. 293 "Define NAME (a symbol) as a test.
294 294
295BODY is evaluated as a `progn' when the test is run. It should 295BODY is evaluated as a `progn' when the test is run. It should
@@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE.
313 (indent 2)) 313 (indent 2))
314 (let ((documentation nil) 314 (let ((documentation nil)
315 (documentation-supplied-p nil)) 315 (documentation-supplied-p nil))
316 (when (stringp (first docstring-keys-and-body)) 316 (when (stringp (car docstring-keys-and-body))
317 (setq documentation (pop docstring-keys-and-body) 317 (setq documentation (pop docstring-keys-and-body)
318 documentation-supplied-p t)) 318 documentation-supplied-p t))
319 (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) 319 (cl-destructuring-bind
320 (tags nil tags-supplied-p)) 320 ((&key (expected-result nil expected-result-supplied-p)
321 body) 321 (tags nil tags-supplied-p))
322 body)
322 (ert--parse-keys-and-body docstring-keys-and-body) 323 (ert--parse-keys-and-body docstring-keys-and-body)
323 `(progn 324 `(progn
324 (ert-set-test ',name 325 (ert-set-test ',name
@@ -405,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure."
405 (t 406 (t
406 (let ((fn-name (car form)) 407 (let ((fn-name (car form))
407 (arg-forms (cdr form))) 408 (arg-forms (cdr form)))
408 (assert (or (symbolp fn-name) 409 (cl-assert (or (symbolp fn-name)
409 (and (consp fn-name) 410 (and (consp fn-name)
410 (eql (car fn-name) 'lambda) 411 (eql (car fn-name) 'lambda)
411 (listp (cdr fn-name))))) 412 (listp (cdr fn-name)))))
412 (let ((fn (ert--gensym "fn-")) 413 (let ((fn (ert--gensym "fn-"))
413 (args (ert--gensym "args-")) 414 (args (ert--gensym "args-"))
414 (value (ert--gensym "value-")) 415 (value (ert--gensym "value-"))
@@ -446,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks
446and error signaling specific to the particular variant of 447and error signaling specific to the particular variant of
447`should'. The code that INNER-EXPANDER returns must not call 448`should'. The code that INNER-EXPANDER returns must not call
448FORM-DESCRIPTION-FORM before it has called INNER-FORM." 449FORM-DESCRIPTION-FORM before it has called INNER-FORM."
449 (lexical-let ((inner-expander inner-expander)) 450 (ert--expand-should-1
450 (ert--expand-should-1 451 whole form
451 whole form 452 (lambda (inner-form form-description-form value-var)
452 (lambda (inner-form form-description-form value-var) 453 (let ((form-description (ert--gensym "form-description-")))
453 (let ((form-description (ert--gensym "form-description-"))) 454 `(let (,form-description)
454 `(let (,form-description) 455 ,(funcall inner-expander
455 ,(funcall inner-expander 456 `(unwind-protect
456 `(unwind-protect 457 ,inner-form
457 ,inner-form 458 (setq ,form-description ,form-description-form)
458 (setq ,form-description ,form-description-form) 459 (ert--signal-should-execution ,form-description))
459 (ert--signal-should-execution ,form-description)) 460 `,form-description
460 `,form-description 461 value-var))))))
461 value-var))))))) 462
462 463(cl-defmacro should (form)
463(defmacro* should (form)
464 "Evaluate FORM. If it returns nil, abort the current test as failed. 464 "Evaluate FORM. If it returns nil, abort the current test as failed.
465 465
466Returns the value of FORM." 466Returns the value of FORM."
467 (ert--expand-should `(should ,form) form 467 (ert--expand-should `(should ,form) form
468 (lambda (inner-form form-description-form value-var) 468 (lambda (inner-form form-description-form _value-var)
469 `(unless ,inner-form 469 `(unless ,inner-form
470 (ert-fail ,form-description-form))))) 470 (ert-fail ,form-description-form)))))
471 471
472(defmacro* should-not (form) 472(cl-defmacro should-not (form)
473 "Evaluate FORM. If it returns non-nil, abort the current test as failed. 473 "Evaluate FORM. If it returns non-nil, abort the current test as failed.
474 474
475Returns nil." 475Returns nil."
476 (ert--expand-should `(should-not ,form) form 476 (ert--expand-should `(should-not ,form) form
477 (lambda (inner-form form-description-form value-var) 477 (lambda (inner-form form-description-form _value-var)
478 `(unless (not ,inner-form) 478 `(unless (not ,inner-form)
479 (ert-fail ,form-description-form))))) 479 (ert-fail ,form-description-form)))))
480 480
@@ -485,10 +485,10 @@ Returns nil."
485Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, 485Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
486and aborts the current test as failed if it doesn't." 486and aborts the current test as failed if it doesn't."
487 (let ((signaled-conditions (get (car condition) 'error-conditions)) 487 (let ((signaled-conditions (get (car condition) 'error-conditions))
488 (handled-conditions (etypecase type 488 (handled-conditions (cl-etypecase type
489 (list type) 489 (list type)
490 (symbol (list type))))) 490 (symbol (list type)))))
491 (assert signaled-conditions) 491 (cl-assert signaled-conditions)
492 (unless (ert--intersection signaled-conditions handled-conditions) 492 (unless (ert--intersection signaled-conditions handled-conditions)
493 (ert-fail (append 493 (ert-fail (append
494 (funcall form-description-fn) 494 (funcall form-description-fn)
@@ -507,7 +507,7 @@ and aborts the current test as failed if it doesn't."
507 507
508;; FIXME: The expansion will evaluate the keyword args (if any) in 508;; FIXME: The expansion will evaluate the keyword args (if any) in
509;; nonstandard order. 509;; nonstandard order.
510(defmacro* should-error (form &rest keys &key type exclude-subtypes) 510(cl-defmacro should-error (form &rest keys &key type exclude-subtypes)
511 "Evaluate FORM and check that it signals an error. 511 "Evaluate FORM and check that it signals an error.
512 512
513The error signaled needs to match TYPE. TYPE should be a list 513The error signaled needs to match TYPE. TYPE should be a list
@@ -555,19 +555,19 @@ failed."
555 555
556(defun ert--proper-list-p (x) 556(defun ert--proper-list-p (x)
557 "Return non-nil if X is a proper list, nil otherwise." 557 "Return non-nil if X is a proper list, nil otherwise."
558 (loop 558 (cl-loop
559 for firstp = t then nil 559 for firstp = t then nil
560 for fast = x then (cddr fast) 560 for fast = x then (cddr fast)
561 for slow = x then (cdr slow) do 561 for slow = x then (cdr slow) do
562 (when (null fast) (return t)) 562 (when (null fast) (cl-return t))
563 (when (not (consp fast)) (return nil)) 563 (when (not (consp fast)) (cl-return nil))
564 (when (null (cdr fast)) (return t)) 564 (when (null (cdr fast)) (cl-return t))
565 (when (not (consp (cdr fast))) (return nil)) 565 (when (not (consp (cdr fast))) (cl-return nil))
566 (when (and (not firstp) (eq fast slow)) (return nil)))) 566 (when (and (not firstp) (eq fast slow)) (cl-return nil))))
567 567
568(defun ert--explain-format-atom (x) 568(defun ert--explain-format-atom (x)
569 "Format the atom X for `ert--explain-equal'." 569 "Format the atom X for `ert--explain-equal'."
570 (typecase x 570 (cl-typecase x
571 (fixnum (list x (format "#x%x" x) (format "?%c" x))) 571 (fixnum (list x (format "#x%x" x) (format "?%c" x)))
572 (t x))) 572 (t x)))
573 573
@@ -576,7 +576,7 @@ failed."
576Returns nil if they are." 576Returns nil if they are."
577 (if (not (equal (type-of a) (type-of b))) 577 (if (not (equal (type-of a) (type-of b)))
578 `(different-types ,a ,b) 578 `(different-types ,a ,b)
579 (etypecase a 579 (cl-etypecase a
580 (cons 580 (cons
581 (let ((a-proper-p (ert--proper-list-p a)) 581 (let ((a-proper-p (ert--proper-list-p a))
582 (b-proper-p (ert--proper-list-p b))) 582 (b-proper-p (ert--proper-list-p b)))
@@ -588,19 +588,19 @@ Returns nil if they are."
588 ,a ,b 588 ,a ,b
589 first-mismatch-at 589 first-mismatch-at
590 ,(ert--mismatch a b)) 590 ,(ert--mismatch a b))
591 (loop for i from 0 591 (cl-loop for i from 0
592 for ai in a 592 for ai in a
593 for bi in b 593 for bi in b
594 for xi = (ert--explain-equal-rec ai bi) 594 for xi = (ert--explain-equal-rec ai bi)
595 do (when xi (return `(list-elt ,i ,xi))) 595 do (when xi (cl-return `(list-elt ,i ,xi)))
596 finally (assert (equal a b) t))) 596 finally (cl-assert (equal a b) t)))
597 (let ((car-x (ert--explain-equal-rec (car a) (car b)))) 597 (let ((car-x (ert--explain-equal-rec (car a) (car b))))
598 (if car-x 598 (if car-x
599 `(car ,car-x) 599 `(car ,car-x)
600 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) 600 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
601 (if cdr-x 601 (if cdr-x
602 `(cdr ,cdr-x) 602 `(cdr ,cdr-x)
603 (assert (equal a b) t) 603 (cl-assert (equal a b) t)
604 nil)))))))) 604 nil))))))))
605 (array (if (not (equal (length a) (length b))) 605 (array (if (not (equal (length a) (length b)))
606 `(arrays-of-different-length ,(length a) ,(length b) 606 `(arrays-of-different-length ,(length a) ,(length b)
@@ -608,12 +608,12 @@ Returns nil if they are."
608 ,@(unless (char-table-p a) 608 ,@(unless (char-table-p a)
609 `(first-mismatch-at 609 `(first-mismatch-at
610 ,(ert--mismatch a b)))) 610 ,(ert--mismatch a b))))
611 (loop for i from 0 611 (cl-loop for i from 0
612 for ai across a 612 for ai across a
613 for bi across b 613 for bi across b
614 for xi = (ert--explain-equal-rec ai bi) 614 for xi = (ert--explain-equal-rec ai bi)
615 do (when xi (return `(array-elt ,i ,xi))) 615 do (when xi (cl-return `(array-elt ,i ,xi)))
616 finally (assert (equal a b) t)))) 616 finally (cl-assert (equal a b) t))))
617 (atom (if (not (equal a b)) 617 (atom (if (not (equal a b))
618 (if (and (symbolp a) (symbolp b) (string= a b)) 618 (if (and (symbolp a) (symbolp b) (string= a b))
619 `(different-symbols-with-the-same-name ,a ,b) 619 `(different-symbols-with-the-same-name ,a ,b)
@@ -632,10 +632,10 @@ Returns nil if they are."
632 632
633(defun ert--significant-plist-keys (plist) 633(defun ert--significant-plist-keys (plist)
634 "Return the keys of PLIST that have non-null values, in order." 634 "Return the keys of PLIST that have non-null values, in order."
635 (assert (zerop (mod (length plist) 2)) t) 635 (cl-assert (zerop (mod (length plist) 2)) t)
636 (loop for (key value . rest) on plist by #'cddr 636 (cl-loop for (key value . rest) on plist by #'cddr
637 unless (or (null value) (memq key accu)) collect key into accu 637 unless (or (null value) (memq key accu)) collect key into accu
638 finally (return accu))) 638 finally (cl-return accu)))
639 639
640(defun ert--plist-difference-explanation (a b) 640(defun ert--plist-difference-explanation (a b)
641 "Return a programmer-readable explanation of why A and B are different plists. 641 "Return a programmer-readable explanation of why A and B are different plists.
@@ -643,8 +643,8 @@ Returns nil if they are."
643Returns nil if they are equivalent, i.e., have the same value for 643Returns nil if they are equivalent, i.e., have the same value for
644each key, where absent values are treated as nil. The order of 644each key, where absent values are treated as nil. The order of
645key/value pairs in each list does not matter." 645key/value pairs in each list does not matter."
646 (assert (zerop (mod (length a) 2)) t) 646 (cl-assert (zerop (mod (length a) 2)) t)
647 (assert (zerop (mod (length b) 2)) t) 647 (cl-assert (zerop (mod (length b) 2)) t)
648 ;; Normalizing the plists would be another way to do this but it 648 ;; Normalizing the plists would be another way to do this but it
649 ;; requires a total ordering on all lisp objects (since any object 649 ;; requires a total ordering on all lisp objects (since any object
650 ;; is valid as a text property key). Perhaps defining such an 650 ;; is valid as a text property key). Perhaps defining such an
@@ -654,21 +654,21 @@ key/value pairs in each list does not matter."
654 (keys-b (ert--significant-plist-keys b)) 654 (keys-b (ert--significant-plist-keys b))
655 (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) 655 (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
656 (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) 656 (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
657 (flet ((explain-with-key (key) 657 (cl-flet ((explain-with-key (key)
658 (let ((value-a (plist-get a key)) 658 (let ((value-a (plist-get a key))
659 (value-b (plist-get b key))) 659 (value-b (plist-get b key)))
660 (assert (not (equal value-a value-b)) t) 660 (cl-assert (not (equal value-a value-b)) t)
661 `(different-properties-for-key 661 `(different-properties-for-key
662 ,key ,(ert--explain-equal-including-properties value-a 662 ,key ,(ert--explain-equal-including-properties value-a
663 value-b))))) 663 value-b)))))
664 (cond (keys-in-a-not-in-b 664 (cond (keys-in-a-not-in-b
665 (explain-with-key (first keys-in-a-not-in-b))) 665 (explain-with-key (car keys-in-a-not-in-b)))
666 (keys-in-b-not-in-a 666 (keys-in-b-not-in-a
667 (explain-with-key (first keys-in-b-not-in-a))) 667 (explain-with-key (car keys-in-b-not-in-a)))
668 (t 668 (t
669 (loop for key in keys-a 669 (cl-loop for key in keys-a
670 when (not (equal (plist-get a key) (plist-get b key))) 670 when (not (equal (plist-get a key) (plist-get b key)))
671 return (explain-with-key key))))))) 671 return (explain-with-key key)))))))
672 672
673(defun ert--abbreviate-string (s len suffixp) 673(defun ert--abbreviate-string (s len suffixp)
674 "Shorten string S to at most LEN chars. 674 "Shorten string S to at most LEN chars.
@@ -692,29 +692,30 @@ Returns a programmer-readable explanation of why A and B are not
692`ert-equal-including-properties', or nil if they are." 692`ert-equal-including-properties', or nil if they are."
693 (if (not (equal a b)) 693 (if (not (equal a b))
694 (ert--explain-equal a b) 694 (ert--explain-equal a b)
695 (assert (stringp a) t) 695 (cl-assert (stringp a) t)
696 (assert (stringp b) t) 696 (cl-assert (stringp b) t)
697 (assert (eql (length a) (length b)) t) 697 (cl-assert (eql (length a) (length b)) t)
698 (loop for i from 0 to (length a) 698 (cl-loop for i from 0 to (length a)
699 for props-a = (text-properties-at i a) 699 for props-a = (text-properties-at i a)
700 for props-b = (text-properties-at i b) 700 for props-b = (text-properties-at i b)
701 for difference = (ert--plist-difference-explanation props-a props-b) 701 for difference = (ert--plist-difference-explanation
702 do (when difference 702 props-a props-b)
703 (return `(char ,i ,(substring-no-properties a i (1+ i)) 703 do (when difference
704 ,difference 704 (cl-return `(char ,i ,(substring-no-properties a i (1+ i))
705 context-before 705 ,difference
706 ,(ert--abbreviate-string 706 context-before
707 (substring-no-properties a 0 i) 707 ,(ert--abbreviate-string
708 10 t) 708 (substring-no-properties a 0 i)
709 context-after 709 10 t)
710 ,(ert--abbreviate-string 710 context-after
711 (substring-no-properties a (1+ i)) 711 ,(ert--abbreviate-string
712 10 nil)))) 712 (substring-no-properties a (1+ i))
713 ;; TODO(ohler): Get `equal-including-properties' fixed in 713 10 nil))))
714 ;; Emacs, delete `ert-equal-including-properties', and 714 ;; TODO(ohler): Get `equal-including-properties' fixed in
715 ;; re-enable this assertion. 715 ;; Emacs, delete `ert-equal-including-properties', and
716 ;;finally (assert (equal-including-properties a b) t) 716 ;; re-enable this assertion.
717 ))) 717 ;;finally (cl-assert (equal-including-properties a b) t)
718 )))
718(put 'ert-equal-including-properties 719(put 'ert-equal-including-properties
719 'ert-explainer 720 'ert-explainer
720 'ert--explain-equal-including-properties) 721 'ert--explain-equal-including-properties)
@@ -729,8 +730,8 @@ Returns a programmer-readable explanation of why A and B are not
729 730
730Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") 731Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.")
731 732
732(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) 733(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
733 &body body) 734 &body body)
734 "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. 735 "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
735 736
736To be used within ERT tests. MESSAGE-FORM should evaluate to a 737To be used within ERT tests. MESSAGE-FORM should evaluate to a
@@ -750,18 +751,19 @@ and is displayed in front of the value of MESSAGE-FORM."
750 "Non-nil means enter debugger when a test fails or terminates with an error.") 751 "Non-nil means enter debugger when a test fails or terminates with an error.")
751 752
752;; The data structures that represent the result of running a test. 753;; The data structures that represent the result of running a test.
753(defstruct ert-test-result 754(cl-defstruct ert-test-result
754 (messages nil) 755 (messages nil)
755 (should-forms nil) 756 (should-forms nil)
756 ) 757 )
757(defstruct (ert-test-passed (:include ert-test-result))) 758(cl-defstruct (ert-test-passed (:include ert-test-result)))
758(defstruct (ert-test-result-with-condition (:include ert-test-result)) 759(cl-defstruct (ert-test-result-with-condition (:include ert-test-result))
759 (condition (assert nil)) 760 (condition (cl-assert nil))
760 (backtrace (assert nil)) 761 (backtrace (cl-assert nil))
761 (infos (assert nil))) 762 (infos (cl-assert nil)))
762(defstruct (ert-test-quit (:include ert-test-result-with-condition))) 763(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition)))
763(defstruct (ert-test-failed (:include ert-test-result-with-condition))) 764(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition)))
764(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) 765(cl-defstruct (ert-test-aborted-with-non-local-exit
766 (:include ert-test-result)))
765 767
766 768
767(defun ert--record-backtrace () 769(defun ert--record-backtrace ()
@@ -774,7 +776,7 @@ and is displayed in front of the value of MESSAGE-FORM."
774 ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we 776 ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
775 ;; already have `ert-results-rerun-test-debugging-errors-at-point'. 777 ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
776 ;; For batch use, however, printing the backtrace may be useful. 778 ;; For batch use, however, printing the backtrace may be useful.
777 (loop 779 (cl-loop
778 ;; 6 is the number of frames our own debugger adds (when 780 ;; 6 is the number of frames our own debugger adds (when
779 ;; compiled; more when interpreted). FIXME: Need to describe a 781 ;; compiled; more when interpreted). FIXME: Need to describe a
780 ;; procedure for determining this constant. 782 ;; procedure for determining this constant.
@@ -791,33 +793,33 @@ and is displayed in front of the value of MESSAGE-FORM."
791 (print-level 8) 793 (print-level 8)
792 (print-length 50)) 794 (print-length 50))
793 (dolist (frame backtrace) 795 (dolist (frame backtrace)
794 (ecase (first frame) 796 (cl-ecase (car frame)
795 ((nil) 797 ((nil)
796 ;; Special operator. 798 ;; Special operator.
797 (destructuring-bind (special-operator &rest arg-forms) 799 (cl-destructuring-bind (special-operator &rest arg-forms)
798 (cdr frame) 800 (cdr frame)
799 (insert 801 (insert
800 (format " %S\n" (list* special-operator arg-forms))))) 802 (format " %S\n" (cons special-operator arg-forms)))))
801 ((t) 803 ((t)
802 ;; Function call. 804 ;; Function call.
803 (destructuring-bind (fn &rest args) (cdr frame) 805 (cl-destructuring-bind (fn &rest args) (cdr frame)
804 (insert (format " %S(" fn)) 806 (insert (format " %S(" fn))
805 (loop for firstp = t then nil 807 (cl-loop for firstp = t then nil
806 for arg in args do 808 for arg in args do
807 (unless firstp 809 (unless firstp
808 (insert " ")) 810 (insert " "))
809 (insert (format "%S" arg))) 811 (insert (format "%S" arg)))
810 (insert ")\n"))))))) 812 (insert ")\n")))))))
811 813
812;; A container for the state of the execution of a single test and 814;; A container for the state of the execution of a single test and
813;; environment data needed during its execution. 815;; environment data needed during its execution.
814(defstruct ert--test-execution-info 816(cl-defstruct ert--test-execution-info
815 (test (assert nil)) 817 (test (cl-assert nil))
816 (result (assert nil)) 818 (result (cl-assert nil))
817 ;; A thunk that may be called when RESULT has been set to its final 819 ;; A thunk that may be called when RESULT has been set to its final
818 ;; value and test execution should be terminated. Should not 820 ;; value and test execution should be terminated. Should not
819 ;; return. 821 ;; return.
820 (exit-continuation (assert nil)) 822 (exit-continuation (cl-assert nil))
821 ;; The binding of `debugger' outside of the execution of the test. 823 ;; The binding of `debugger' outside of the execution of the test.
822 next-debugger 824 next-debugger
823 ;; The binding of `ert-debug-on-error' that is in effect for the 825 ;; The binding of `ert-debug-on-error' that is in effect for the
@@ -826,7 +828,7 @@ and is displayed in front of the value of MESSAGE-FORM."
826 ;; don't remember whether this feature is important.) 828 ;; don't remember whether this feature is important.)
827 ert-debug-on-error) 829 ert-debug-on-error)
828 830
829(defun ert--run-test-debugger (info debugger-args) 831(defun ert--run-test-debugger (info args)
830 "During a test run, `debugger' is bound to a closure that calls this function. 832 "During a test run, `debugger' is bound to a closure that calls this function.
831 833
832This function records failures and errors and either terminates 834This function records failures and errors and either terminates
@@ -834,21 +836,21 @@ the test silently or calls the interactive debugger, as
834appropriate. 836appropriate.
835 837
836INFO is the ert--test-execution-info corresponding to this test 838INFO is the ert--test-execution-info corresponding to this test
837run. DEBUGGER-ARGS are the arguments to `debugger'." 839run. ARGS are the arguments to `debugger'."
838 (destructuring-bind (first-debugger-arg &rest more-debugger-args) 840 (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
839 debugger-args 841 args
840 (ecase first-debugger-arg 842 (cl-ecase first-debugger-arg
841 ((lambda debug t exit nil) 843 ((lambda debug t exit nil)
842 (apply (ert--test-execution-info-next-debugger info) debugger-args)) 844 (apply (ert--test-execution-info-next-debugger info) args))
843 (error 845 (error
844 (let* ((condition (first more-debugger-args)) 846 (let* ((condition (car more-debugger-args))
845 (type (case (car condition) 847 (type (cl-case (car condition)
846 ((quit) 'quit) 848 ((quit) 'quit)
847 (otherwise 'failed))) 849 (otherwise 'failed)))
848 (backtrace (ert--record-backtrace)) 850 (backtrace (ert--record-backtrace))
849 (infos (reverse ert--infos))) 851 (infos (reverse ert--infos)))
850 (setf (ert--test-execution-info-result info) 852 (setf (ert--test-execution-info-result info)
851 (ecase type 853 (cl-ecase type
852 (quit 854 (quit
853 (make-ert-test-quit :condition condition 855 (make-ert-test-quit :condition condition
854 :backtrace backtrace 856 :backtrace backtrace
@@ -859,39 +861,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'."
859 :infos infos)))) 861 :infos infos))))
860 ;; Work around Emacs's heuristic (in eval.c) for detecting 862 ;; Work around Emacs's heuristic (in eval.c) for detecting
861 ;; errors in the debugger. 863 ;; errors in the debugger.
862 (incf num-nonmacro-input-events) 864 (cl-incf num-nonmacro-input-events)
863 ;; FIXME: We should probably implement more fine-grained 865 ;; FIXME: We should probably implement more fine-grained
864 ;; control a la non-t `debug-on-error' here. 866 ;; control a la non-t `debug-on-error' here.
865 (cond 867 (cond
866 ((ert--test-execution-info-ert-debug-on-error info) 868 ((ert--test-execution-info-ert-debug-on-error info)
867 (apply (ert--test-execution-info-next-debugger info) debugger-args)) 869 (apply (ert--test-execution-info-next-debugger info) args))
868 (t)) 870 (t))
869 (funcall (ert--test-execution-info-exit-continuation info))))))) 871 (funcall (ert--test-execution-info-exit-continuation info)))))))
870 872
871(defun ert--run-test-internal (ert-test-execution-info) 873(defun ert--run-test-internal (test-execution-info)
872 "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. 874 "Low-level function to run a test according to TEST-EXECUTION-INFO.
873 875
874This mainly sets up debugger-related bindings." 876This mainly sets up debugger-related bindings."
875 (lexical-let ((info ert-test-execution-info)) 877 (setf (ert--test-execution-info-next-debugger test-execution-info) debugger
876 (setf (ert--test-execution-info-next-debugger info) debugger 878 (ert--test-execution-info-ert-debug-on-error test-execution-info)
877 (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) 879 ert-debug-on-error)
878 (catch 'ert--pass 880 (catch 'ert--pass
879 ;; For now, each test gets its own temp buffer and its own 881 ;; For now, each test gets its own temp buffer and its own
880 ;; window excursion, just to be safe. If this turns out to be 882 ;; window excursion, just to be safe. If this turns out to be
881 ;; too expensive, we can remove it. 883 ;; too expensive, we can remove it.
882 (with-temp-buffer 884 (with-temp-buffer
883 (save-window-excursion 885 (save-window-excursion
884 (let ((debugger (lambda (&rest debugger-args) 886 (let ((debugger (lambda (&rest args)
885 (ert--run-test-debugger info debugger-args))) 887 (ert--run-test-debugger test-execution-info
886 (debug-on-error t) 888 args)))
887 (debug-on-quit t) 889 (debug-on-error t)
888 ;; FIXME: Do we need to store the old binding of this 890 (debug-on-quit t)
889 ;; and consider it in `ert--run-test-debugger'? 891 ;; FIXME: Do we need to store the old binding of this
890 (debug-ignored-errors nil) 892 ;; and consider it in `ert--run-test-debugger'?
891 (ert--infos '())) 893 (debug-ignored-errors nil)
892 (funcall (ert-test-body (ert--test-execution-info-test info)))))) 894 (ert--infos '()))
893 (ert-pass)) 895 (funcall (ert-test-body (ert--test-execution-info-test
894 (setf (ert--test-execution-info-result info) (make-ert-test-passed))) 896 test-execution-info))))))
897 (ert-pass))
898 (setf (ert--test-execution-info-result test-execution-info)
899 (make-ert-test-passed))
895 nil) 900 nil)
896 901
897(defun ert--force-message-log-buffer-truncation () 902(defun ert--force-message-log-buffer-truncation ()
@@ -929,18 +934,18 @@ The elements are of type `ert-test'.")
929 934
930Returns the result and stores it in ERT-TEST's `most-recent-result' slot." 935Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
931 (setf (ert-test-most-recent-result ert-test) nil) 936 (setf (ert-test-most-recent-result ert-test) nil)
932 (block error 937 (cl-block error
933 (lexical-let ((begin-marker 938 (let ((begin-marker
934 (with-current-buffer (get-buffer-create "*Messages*") 939 (with-current-buffer (get-buffer-create "*Messages*")
935 (set-marker (make-marker) (point-max))))) 940 (set-marker (make-marker) (point-max)))))
936 (unwind-protect 941 (unwind-protect
937 (lexical-let ((info (make-ert--test-execution-info 942 (let ((info (make-ert--test-execution-info
938 :test ert-test 943 :test ert-test
939 :result 944 :result
940 (make-ert-test-aborted-with-non-local-exit) 945 (make-ert-test-aborted-with-non-local-exit)
941 :exit-continuation (lambda () 946 :exit-continuation (lambda ()
942 (return-from error nil)))) 947 (cl-return-from error nil))))
943 (should-form-accu (list))) 948 (should-form-accu (list)))
944 (unwind-protect 949 (unwind-protect
945 (let ((ert--should-execution-observer 950 (let ((ert--should-execution-observer
946 (lambda (form-description) 951 (lambda (form-description)
@@ -982,32 +987,32 @@ t -- Always matches.
982 RESULT." 987 RESULT."
983 ;; It would be easy to add `member' and `eql' types etc., but I 988 ;; It would be easy to add `member' and `eql' types etc., but I
984 ;; haven't bothered yet. 989 ;; haven't bothered yet.
985 (etypecase result-type 990 (cl-etypecase result-type
986 ((member nil) nil) 991 ((member nil) nil)
987 ((member t) t) 992 ((member t) t)
988 ((member :failed) (ert-test-failed-p result)) 993 ((member :failed) (ert-test-failed-p result))
989 ((member :passed) (ert-test-passed-p result)) 994 ((member :passed) (ert-test-passed-p result))
990 (cons 995 (cons
991 (destructuring-bind (operator &rest operands) result-type 996 (cl-destructuring-bind (operator &rest operands) result-type
992 (ecase operator 997 (cl-ecase operator
993 (and 998 (and
994 (case (length operands) 999 (cl-case (length operands)
995 (0 t) 1000 (0 t)
996 (t 1001 (t
997 (and (ert-test-result-type-p result (first operands)) 1002 (and (ert-test-result-type-p result (car operands))
998 (ert-test-result-type-p result `(and ,@(rest operands))))))) 1003 (ert-test-result-type-p result `(and ,@(cdr operands)))))))
999 (or 1004 (or
1000 (case (length operands) 1005 (cl-case (length operands)
1001 (0 nil) 1006 (0 nil)
1002 (t 1007 (t
1003 (or (ert-test-result-type-p result (first operands)) 1008 (or (ert-test-result-type-p result (car operands))
1004 (ert-test-result-type-p result `(or ,@(rest operands))))))) 1009 (ert-test-result-type-p result `(or ,@(cdr operands)))))))
1005 (not 1010 (not
1006 (assert (eql (length operands) 1)) 1011 (cl-assert (eql (length operands) 1))
1007 (not (ert-test-result-type-p result (first operands)))) 1012 (not (ert-test-result-type-p result (car operands))))
1008 (satisfies 1013 (satisfies
1009 (assert (eql (length operands) 1)) 1014 (cl-assert (eql (length operands) 1))
1010 (funcall (first operands) result))))))) 1015 (funcall (car operands) result)))))))
1011 1016
1012(defun ert-test-result-expected-p (test result) 1017(defun ert-test-result-expected-p (test result)
1013 "Return non-nil if TEST's expected result type matches RESULT." 1018 "Return non-nil if TEST's expected result type matches RESULT."
@@ -1048,9 +1053,9 @@ set implied by them without checking whether it is really
1048contained in UNIVERSE." 1053contained in UNIVERSE."
1049 ;; This code needs to match the etypecase in 1054 ;; This code needs to match the etypecase in
1050 ;; `ert-insert-human-readable-selector'. 1055 ;; `ert-insert-human-readable-selector'.
1051 (etypecase selector 1056 (cl-etypecase selector
1052 ((member nil) nil) 1057 ((member nil) nil)
1053 ((member t) (etypecase universe 1058 ((member t) (cl-etypecase universe
1054 (list universe) 1059 (list universe)
1055 ((member t) (ert-select-tests "" universe)))) 1060 ((member t) (ert-select-tests "" universe))))
1056 ((member :new) (ert-select-tests 1061 ((member :new) (ert-select-tests
@@ -1078,7 +1083,7 @@ contained in UNIVERSE."
1078 universe)) 1083 universe))
1079 ((member :unexpected) (ert-select-tests `(not :expected) universe)) 1084 ((member :unexpected) (ert-select-tests `(not :expected) universe))
1080 (string 1085 (string
1081 (etypecase universe 1086 (cl-etypecase universe
1082 ((member t) (mapcar #'ert-get-test 1087 ((member t) (mapcar #'ert-get-test
1083 (apropos-internal selector #'ert-test-boundp))) 1088 (apropos-internal selector #'ert-test-boundp)))
1084 (list (ert--remove-if-not (lambda (test) 1089 (list (ert--remove-if-not (lambda (test)
@@ -1088,51 +1093,51 @@ contained in UNIVERSE."
1088 universe)))) 1093 universe))))
1089 (ert-test (list selector)) 1094 (ert-test (list selector))
1090 (symbol 1095 (symbol
1091 (assert (ert-test-boundp selector)) 1096 (cl-assert (ert-test-boundp selector))
1092 (list (ert-get-test selector))) 1097 (list (ert-get-test selector)))
1093 (cons 1098 (cons
1094 (destructuring-bind (operator &rest operands) selector 1099 (cl-destructuring-bind (operator &rest operands) selector
1095 (ecase operator 1100 (cl-ecase operator
1096 (member 1101 (member
1097 (mapcar (lambda (purported-test) 1102 (mapcar (lambda (purported-test)
1098 (etypecase purported-test 1103 (cl-etypecase purported-test
1099 (symbol (assert (ert-test-boundp purported-test)) 1104 (symbol (cl-assert (ert-test-boundp purported-test))
1100 (ert-get-test purported-test)) 1105 (ert-get-test purported-test))
1101 (ert-test purported-test))) 1106 (ert-test purported-test)))
1102 operands)) 1107 operands))
1103 (eql 1108 (eql
1104 (assert (eql (length operands) 1)) 1109 (cl-assert (eql (length operands) 1))
1105 (ert-select-tests `(member ,@operands) universe)) 1110 (ert-select-tests `(member ,@operands) universe))
1106 (and 1111 (and
1107 ;; Do these definitions of AND, NOT and OR satisfy de 1112 ;; Do these definitions of AND, NOT and OR satisfy de
1108 ;; Morgan's laws? Should they? 1113 ;; Morgan's laws? Should they?
1109 (case (length operands) 1114 (cl-case (length operands)
1110 (0 (ert-select-tests 't universe)) 1115 (0 (ert-select-tests 't universe))
1111 (t (ert-select-tests `(and ,@(rest operands)) 1116 (t (ert-select-tests `(and ,@(cdr operands))
1112 (ert-select-tests (first operands) 1117 (ert-select-tests (car operands)
1113 universe))))) 1118 universe)))))
1114 (not 1119 (not
1115 (assert (eql (length operands) 1)) 1120 (cl-assert (eql (length operands) 1))
1116 (let ((all-tests (ert-select-tests 't universe))) 1121 (let ((all-tests (ert-select-tests 't universe)))
1117 (ert--set-difference all-tests 1122 (ert--set-difference all-tests
1118 (ert-select-tests (first operands) 1123 (ert-select-tests (car operands)
1119 all-tests)))) 1124 all-tests))))
1120 (or 1125 (or
1121 (case (length operands) 1126 (cl-case (length operands)
1122 (0 (ert-select-tests 'nil universe)) 1127 (0 (ert-select-tests 'nil universe))
1123 (t (ert--union (ert-select-tests (first operands) universe) 1128 (t (ert--union (ert-select-tests (car operands) universe)
1124 (ert-select-tests `(or ,@(rest operands)) 1129 (ert-select-tests `(or ,@(cdr operands))
1125 universe))))) 1130 universe)))))
1126 (tag 1131 (tag
1127 (assert (eql (length operands) 1)) 1132 (cl-assert (eql (length operands) 1))
1128 (let ((tag (first operands))) 1133 (let ((tag (car operands)))
1129 (ert-select-tests `(satisfies 1134 (ert-select-tests `(satisfies
1130 ,(lambda (test) 1135 ,(lambda (test)
1131 (member tag (ert-test-tags test)))) 1136 (member tag (ert-test-tags test))))
1132 universe))) 1137 universe)))
1133 (satisfies 1138 (satisfies
1134 (assert (eql (length operands) 1)) 1139 (cl-assert (eql (length operands) 1))
1135 (ert--remove-if-not (first operands) 1140 (ert--remove-if-not (car operands)
1136 (ert-select-tests 't universe)))))))) 1141 (ert-select-tests 't universe))))))))
1137 1142
1138(defun ert--insert-human-readable-selector (selector) 1143(defun ert--insert-human-readable-selector (selector)
@@ -1141,26 +1146,27 @@ contained in UNIVERSE."
1141 ;; `backtrace' slot of the result objects in the 1146 ;; `backtrace' slot of the result objects in the
1142 ;; `most-recent-result' slots of test case objects in (eql ...) or 1147 ;; `most-recent-result' slots of test case objects in (eql ...) or
1143 ;; (member ...) selectors. 1148 ;; (member ...) selectors.
1144 (labels ((rec (selector) 1149 (cl-labels ((rec (selector)
1145 ;; This code needs to match the etypecase in `ert-select-tests'. 1150 ;; This code needs to match the etypecase in
1146 (etypecase selector 1151 ;; `ert-select-tests'.
1147 ((or (member nil t 1152 (cl-etypecase selector
1148 :new :failed :passed 1153 ((or (member nil t
1149 :expected :unexpected) 1154 :new :failed :passed
1150 string 1155 :expected :unexpected)
1151 symbol) 1156 string
1152 selector) 1157 symbol)
1153 (ert-test 1158 selector)
1154 (if (ert-test-name selector) 1159 (ert-test
1155 (make-symbol (format "<%S>" (ert-test-name selector))) 1160 (if (ert-test-name selector)
1156 (make-symbol "<unnamed test>"))) 1161 (make-symbol (format "<%S>" (ert-test-name selector)))
1157 (cons 1162 (make-symbol "<unnamed test>")))
1158 (destructuring-bind (operator &rest operands) selector 1163 (cons
1159 (ecase operator 1164 (cl-destructuring-bind (operator &rest operands) selector
1160 ((member eql and not or) 1165 (cl-ecase operator
1161 `(,operator ,@(mapcar #'rec operands))) 1166 ((member eql and not or)
1162 ((member tag satisfies) 1167 `(,operator ,@(mapcar #'rec operands)))
1163 selector))))))) 1168 ((member tag satisfies)
1169 selector)))))))
1164 (insert (format "%S" (rec selector))))) 1170 (insert (format "%S" (rec selector)))))
1165 1171
1166 1172
@@ -1177,21 +1183,21 @@ contained in UNIVERSE."
1177;; that corresponds to this run in order to be able to update the 1183;; that corresponds to this run in order to be able to update the
1178;; statistics correctly when a test is re-run interactively and has a 1184;; statistics correctly when a test is re-run interactively and has a
1179;; different result than before. 1185;; different result than before.
1180(defstruct ert--stats 1186(cl-defstruct ert--stats
1181 (selector (assert nil)) 1187 (selector (cl-assert nil))
1182 ;; The tests, in order. 1188 ;; The tests, in order.
1183 (tests (assert nil) :type vector) 1189 (tests (cl-assert nil) :type vector)
1184 ;; A map of test names (or the test objects themselves for unnamed 1190 ;; A map of test names (or the test objects themselves for unnamed
1185 ;; tests) to indices into the `tests' vector. 1191 ;; tests) to indices into the `tests' vector.
1186 (test-map (assert nil) :type hash-table) 1192 (test-map (cl-assert nil) :type hash-table)
1187 ;; The results of the tests during this run, in order. 1193 ;; The results of the tests during this run, in order.
1188 (test-results (assert nil) :type vector) 1194 (test-results (cl-assert nil) :type vector)
1189 ;; The start times of the tests, in order, as reported by 1195 ;; The start times of the tests, in order, as reported by
1190 ;; `current-time'. 1196 ;; `current-time'.
1191 (test-start-times (assert nil) :type vector) 1197 (test-start-times (cl-assert nil) :type vector)
1192 ;; The end times of the tests, in order, as reported by 1198 ;; The end times of the tests, in order, as reported by
1193 ;; `current-time'. 1199 ;; `current-time'.
1194 (test-end-times (assert nil) :type vector) 1200 (test-end-times (cl-assert nil) :type vector)
1195 (passed-expected 0) 1201 (passed-expected 0)
1196 (passed-unexpected 0) 1202 (passed-unexpected 0)
1197 (failed-expected 0) 1203 (failed-expected 0)
@@ -1241,21 +1247,25 @@ Also changes the counters in STATS to match."
1241 (results (ert--stats-test-results stats)) 1247 (results (ert--stats-test-results stats))
1242 (old-test (aref tests pos)) 1248 (old-test (aref tests pos))
1243 (map (ert--stats-test-map stats))) 1249 (map (ert--stats-test-map stats)))
1244 (flet ((update (d) 1250 (cl-flet ((update (d)
1245 (if (ert-test-result-expected-p (aref tests pos) 1251 (if (ert-test-result-expected-p (aref tests pos)
1246 (aref results pos)) 1252 (aref results pos))
1247 (etypecase (aref results pos) 1253 (cl-etypecase (aref results pos)
1248 (ert-test-passed (incf (ert--stats-passed-expected stats) d)) 1254 (ert-test-passed
1249 (ert-test-failed (incf (ert--stats-failed-expected stats) d)) 1255 (cl-incf (ert--stats-passed-expected stats) d))
1250 (null) 1256 (ert-test-failed
1251 (ert-test-aborted-with-non-local-exit) 1257 (cl-incf (ert--stats-failed-expected stats) d))
1252 (ert-test-quit)) 1258 (null)
1253 (etypecase (aref results pos) 1259 (ert-test-aborted-with-non-local-exit)
1254 (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) 1260 (ert-test-quit))
1255 (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) 1261 (cl-etypecase (aref results pos)
1256 (null) 1262 (ert-test-passed
1257 (ert-test-aborted-with-non-local-exit) 1263 (cl-incf (ert--stats-passed-unexpected stats) d))
1258 (ert-test-quit))))) 1264 (ert-test-failed
1265 (cl-incf (ert--stats-failed-unexpected stats) d))
1266 (null)
1267 (ert-test-aborted-with-non-local-exit)
1268 (ert-test-quit)))))
1259 ;; Adjust counters to remove the result that is currently in stats. 1269 ;; Adjust counters to remove the result that is currently in stats.
1260 (update -1) 1270 (update -1)
1261 ;; Put new test and result into stats. 1271 ;; Put new test and result into stats.
@@ -1273,11 +1283,11 @@ Also changes the counters in STATS to match."
1273SELECTOR is the selector that was used to select TESTS." 1283SELECTOR is the selector that was used to select TESTS."
1274 (setq tests (ert--coerce-to-vector tests)) 1284 (setq tests (ert--coerce-to-vector tests))
1275 (let ((map (make-hash-table :size (length tests)))) 1285 (let ((map (make-hash-table :size (length tests))))
1276 (loop for i from 0 1286 (cl-loop for i from 0
1277 for test across tests 1287 for test across tests
1278 for key = (ert--stats-test-key test) do 1288 for key = (ert--stats-test-key test) do
1279 (assert (not (gethash key map))) 1289 (cl-assert (not (gethash key map)))
1280 (setf (gethash key map) i)) 1290 (setf (gethash key map) i))
1281 (make-ert--stats :selector selector 1291 (make-ert--stats :selector selector
1282 :tests tests 1292 :tests tests
1283 :test-map map 1293 :test-map map
@@ -1319,8 +1329,8 @@ SELECTOR is the selector that was used to select TESTS."
1319 (force-mode-line-update) 1329 (force-mode-line-update)
1320 (unwind-protect 1330 (unwind-protect
1321 (progn 1331 (progn
1322 (loop for test in tests do 1332 (cl-loop for test in tests do
1323 (ert-run-or-rerun-test stats test listener)) 1333 (ert-run-or-rerun-test stats test listener))
1324 (setq abortedp nil)) 1334 (setq abortedp nil))
1325 (setf (ert--stats-aborted-p stats) abortedp) 1335 (setf (ert--stats-aborted-p stats) abortedp)
1326 (setf (ert--stats-end-time stats) (current-time)) 1336 (setf (ert--stats-end-time stats) (current-time))
@@ -1344,7 +1354,7 @@ SELECTOR is the selector that was used to select TESTS."
1344 "Return a character that represents the test result RESULT. 1354 "Return a character that represents the test result RESULT.
1345 1355
1346EXPECTEDP specifies whether the result was expected." 1356EXPECTEDP specifies whether the result was expected."
1347 (let ((s (etypecase result 1357 (let ((s (cl-etypecase result
1348 (ert-test-passed ".P") 1358 (ert-test-passed ".P")
1349 (ert-test-failed "fF") 1359 (ert-test-failed "fF")
1350 (null "--") 1360 (null "--")
@@ -1356,7 +1366,7 @@ EXPECTEDP specifies whether the result was expected."
1356 "Return a string that represents the test result RESULT. 1366 "Return a string that represents the test result RESULT.
1357 1367
1358EXPECTEDP specifies whether the result was expected." 1368EXPECTEDP specifies whether the result was expected."
1359 (let ((s (etypecase result 1369 (let ((s (cl-etypecase result
1360 (ert-test-passed '("passed" "PASSED")) 1370 (ert-test-passed '("passed" "PASSED"))
1361 (ert-test-failed '("failed" "FAILED")) 1371 (ert-test-failed '("failed" "FAILED"))
1362 (null '("unknown" "UNKNOWN")) 1372 (null '("unknown" "UNKNOWN"))
@@ -1378,9 +1388,9 @@ Ensures a final newline is inserted."
1378 "Insert `ert-info' infos from RESULT into current buffer. 1388 "Insert `ert-info' infos from RESULT into current buffer.
1379 1389
1380RESULT must be an `ert-test-result-with-condition'." 1390RESULT must be an `ert-test-result-with-condition'."
1381 (check-type result ert-test-result-with-condition) 1391 (cl-check-type result ert-test-result-with-condition)
1382 (dolist (info (ert-test-result-with-condition-infos result)) 1392 (dolist (info (ert-test-result-with-condition-infos result))
1383 (destructuring-bind (prefix . message) info 1393 (cl-destructuring-bind (prefix . message) info
1384 (let ((begin (point)) 1394 (let ((begin (point))
1385 (indentation (make-string (+ (length prefix) 4) ?\s)) 1395 (indentation (make-string (+ (length prefix) 4) ?\s))
1386 (end nil)) 1396 (end nil))
@@ -1416,14 +1426,14 @@ Returns the stats object."
1416 (ert-run-tests 1426 (ert-run-tests
1417 selector 1427 selector
1418 (lambda (event-type &rest event-args) 1428 (lambda (event-type &rest event-args)
1419 (ecase event-type 1429 (cl-ecase event-type
1420 (run-started 1430 (run-started
1421 (destructuring-bind (stats) event-args 1431 (cl-destructuring-bind (stats) event-args
1422 (message "Running %s tests (%s)" 1432 (message "Running %s tests (%s)"
1423 (length (ert--stats-tests stats)) 1433 (length (ert--stats-tests stats))
1424 (ert--format-time-iso8601 (ert--stats-start-time stats))))) 1434 (ert--format-time-iso8601 (ert--stats-start-time stats)))))
1425 (run-ended 1435 (run-ended
1426 (destructuring-bind (stats abortedp) event-args 1436 (cl-destructuring-bind (stats abortedp) event-args
1427 (let ((unexpected (ert-stats-completed-unexpected stats)) 1437 (let ((unexpected (ert-stats-completed-unexpected stats))
1428 (expected-failures (ert--stats-failed-expected stats))) 1438 (expected-failures (ert--stats-failed-expected stats)))
1429 (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" 1439 (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
@@ -1441,19 +1451,19 @@ Returns the stats object."
1441 (format "\n%s expected failures" expected-failures))) 1451 (format "\n%s expected failures" expected-failures)))
1442 (unless (zerop unexpected) 1452 (unless (zerop unexpected)
1443 (message "%s unexpected results:" unexpected) 1453 (message "%s unexpected results:" unexpected)
1444 (loop for test across (ert--stats-tests stats) 1454 (cl-loop for test across (ert--stats-tests stats)
1445 for result = (ert-test-most-recent-result test) do 1455 for result = (ert-test-most-recent-result test) do
1446 (when (not (ert-test-result-expected-p test result)) 1456 (when (not (ert-test-result-expected-p test result))
1447 (message "%9s %S" 1457 (message "%9s %S"
1448 (ert-string-for-test-result result nil) 1458 (ert-string-for-test-result result nil)
1449 (ert-test-name test)))) 1459 (ert-test-name test))))
1450 (message "%s" ""))))) 1460 (message "%s" "")))))
1451 (test-started 1461 (test-started
1452 ) 1462 )
1453 (test-ended 1463 (test-ended
1454 (destructuring-bind (stats test result) event-args 1464 (cl-destructuring-bind (stats test result) event-args
1455 (unless (ert-test-result-expected-p test result) 1465 (unless (ert-test-result-expected-p test result)
1456 (etypecase result 1466 (cl-etypecase result
1457 (ert-test-passed 1467 (ert-test-passed
1458 (message "Test %S passed unexpectedly" (ert-test-name test))) 1468 (message "Test %S passed unexpectedly" (ert-test-name test)))
1459 (ert-test-result-with-condition 1469 (ert-test-result-with-condition
@@ -1479,7 +1489,7 @@ Returns the stats object."
1479 (ert--pp-with-indentation-and-newline 1489 (ert--pp-with-indentation-and-newline
1480 (ert-test-result-with-condition-condition result))) 1490 (ert-test-result-with-condition-condition result)))
1481 (goto-char (1- (point-max))) 1491 (goto-char (1- (point-max)))
1482 (assert (looking-at "\n")) 1492 (cl-assert (looking-at "\n"))
1483 (delete-char 1) 1493 (delete-char 1)
1484 (message "Test %S condition:" (ert-test-name test)) 1494 (message "Test %S condition:" (ert-test-name test))
1485 (message "%s" (buffer-string)))) 1495 (message "%s" (buffer-string))))
@@ -1527,7 +1537,7 @@ the tests)."
1527 (1 font-lock-keyword-face nil t) 1537 (1 font-lock-keyword-face nil t)
1528 (2 font-lock-function-name-face nil t))))) 1538 (2 font-lock-function-name-face nil t)))))
1529 1539
1530(defun* ert--remove-from-list (list-var element &key key test) 1540(cl-defun ert--remove-from-list (list-var element &key key test)
1531 "Remove ELEMENT from the value of LIST-VAR if present. 1541 "Remove ELEMENT from the value of LIST-VAR if present.
1532 1542
1533This can be used as an inverse of `add-to-list'." 1543This can be used as an inverse of `add-to-list'."
@@ -1552,7 +1562,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
1552include the default, if any. 1562include the default, if any.
1553 1563
1554Signals an error if no test name was read." 1564Signals an error if no test name was read."
1555 (etypecase default 1565 (cl-etypecase default
1556 (string (let ((symbol (intern-soft default))) 1566 (string (let ((symbol (intern-soft default)))
1557 (unless (and symbol (ert-test-boundp symbol)) 1567 (unless (and symbol (ert-test-boundp symbol))
1558 (setq default nil)))) 1568 (setq default nil))))
@@ -1609,11 +1619,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'."
1609;;; Display of test progress and results. 1619;;; Display of test progress and results.
1610 1620
1611;; An entry in the results buffer ewoc. There is one entry per test. 1621;; An entry in the results buffer ewoc. There is one entry per test.
1612(defstruct ert--ewoc-entry 1622(cl-defstruct ert--ewoc-entry
1613 (test (assert nil)) 1623 (test (cl-assert nil))
1614 ;; If the result of this test was expected, its ewoc entry is hidden 1624 ;; If the result of this test was expected, its ewoc entry is hidden
1615 ;; initially. 1625 ;; initially.
1616 (hidden-p (assert nil)) 1626 (hidden-p (cl-assert nil))
1617 ;; An ewoc entry may be collapsed to hide details such as the error 1627 ;; An ewoc entry may be collapsed to hide details such as the error
1618 ;; condition. 1628 ;; condition.
1619 ;; 1629 ;;
@@ -1689,7 +1699,7 @@ Also sets `ert--results-progress-bar-button-begin'."
1689 ((ert--stats-current-test stats) 'running) 1699 ((ert--stats-current-test stats) 'running)
1690 ((ert--stats-end-time stats) 'finished) 1700 ((ert--stats-end-time stats) 'finished)
1691 (t 'preparing)))) 1701 (t 'preparing))))
1692 (ecase state 1702 (cl-ecase state
1693 (preparing 1703 (preparing
1694 (insert "")) 1704 (insert ""))
1695 (aborted 1705 (aborted
@@ -1700,12 +1710,12 @@ Also sets `ert--results-progress-bar-button-begin'."
1700 (t 1710 (t
1701 (insert "Aborted.")))) 1711 (insert "Aborted."))))
1702 (running 1712 (running
1703 (assert (ert--stats-current-test stats)) 1713 (cl-assert (ert--stats-current-test stats))
1704 (insert "Running test: ") 1714 (insert "Running test: ")
1705 (ert-insert-test-name-button (ert-test-name 1715 (ert-insert-test-name-button (ert-test-name
1706 (ert--stats-current-test stats)))) 1716 (ert--stats-current-test stats))))
1707 (finished 1717 (finished
1708 (assert (not (ert--stats-current-test stats))) 1718 (cl-assert (not (ert--stats-current-test stats)))
1709 (insert "Finished."))) 1719 (insert "Finished.")))
1710 (insert "\n") 1720 (insert "\n")
1711 (if (ert--stats-end-time stats) 1721 (if (ert--stats-end-time stats)
@@ -1808,7 +1818,7 @@ non-nil, returns the face for expected results.."
1808(defun ert-face-for-stats (stats) 1818(defun ert-face-for-stats (stats)
1809 "Return a face that represents STATS." 1819 "Return a face that represents STATS."
1810 (cond ((ert--stats-aborted-p stats) 'nil) 1820 (cond ((ert--stats-aborted-p stats) 'nil)
1811 ((plusp (ert-stats-completed-unexpected stats)) 1821 ((cl-plusp (ert-stats-completed-unexpected stats))
1812 (ert-face-for-test-result nil)) 1822 (ert-face-for-test-result nil))
1813 ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) 1823 ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
1814 (ert-face-for-test-result t)) 1824 (ert-face-for-test-result t))
@@ -1819,7 +1829,7 @@ non-nil, returns the face for expected results.."
1819 (let* ((test (ert--ewoc-entry-test entry)) 1829 (let* ((test (ert--ewoc-entry-test entry))
1820 (stats ert--results-stats) 1830 (stats ert--results-stats)
1821 (result (let ((pos (ert--stats-test-pos stats test))) 1831 (result (let ((pos (ert--stats-test-pos stats test)))
1822 (assert pos) 1832 (cl-assert pos)
1823 (aref (ert--stats-test-results stats) pos))) 1833 (aref (ert--stats-test-results stats) pos)))
1824 (hiddenp (ert--ewoc-entry-hidden-p entry)) 1834 (hiddenp (ert--ewoc-entry-hidden-p entry))
1825 (expandedp (ert--ewoc-entry-expanded-p entry)) 1835 (expandedp (ert--ewoc-entry-expanded-p entry))
@@ -1845,7 +1855,7 @@ non-nil, returns the face for expected results.."
1845 (ert--string-first-line (ert-test-documentation test)) 1855 (ert--string-first-line (ert-test-documentation test))
1846 'font-lock-face 'font-lock-doc-face) 1856 'font-lock-face 'font-lock-doc-face)
1847 "\n")) 1857 "\n"))
1848 (etypecase result 1858 (cl-etypecase result
1849 (ert-test-passed 1859 (ert-test-passed
1850 (if (ert-test-result-expected-p test result) 1860 (if (ert-test-result-expected-p test result)
1851 (insert " passed\n") 1861 (insert " passed\n")
@@ -1903,9 +1913,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use."
1903 (make-string (ert-stats-total stats) 1913 (make-string (ert-stats-total stats)
1904 (ert-char-for-test-result nil t))) 1914 (ert-char-for-test-result nil t)))
1905 (set (make-local-variable 'ert--results-listener) listener) 1915 (set (make-local-variable 'ert--results-listener) listener)
1906 (loop for test across (ert--stats-tests stats) do 1916 (cl-loop for test across (ert--stats-tests stats) do
1907 (ewoc-enter-last ewoc 1917 (ewoc-enter-last ewoc
1908 (make-ert--ewoc-entry :test test :hidden-p t))) 1918 (make-ert--ewoc-entry :test test
1919 :hidden-p t)))
1909 (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) 1920 (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
1910 (goto-char (1- (point-max))) 1921 (goto-char (1- (point-max)))
1911 buffer))))) 1922 buffer)))))
@@ -1940,21 +1951,21 @@ and how to display message."
1940 default nil)) 1951 default nil))
1941 nil)) 1952 nil))
1942 (unless message-fn (setq message-fn 'message)) 1953 (unless message-fn (setq message-fn 'message))
1943 (lexical-let ((output-buffer-name output-buffer-name) 1954 (let ((output-buffer-name output-buffer-name)
1944 buffer 1955 buffer
1945 listener 1956 listener
1946 (message-fn message-fn)) 1957 (message-fn message-fn))
1947 (setq listener 1958 (setq listener
1948 (lambda (event-type &rest event-args) 1959 (lambda (event-type &rest event-args)
1949 (ecase event-type 1960 (cl-ecase event-type
1950 (run-started 1961 (run-started
1951 (destructuring-bind (stats) event-args 1962 (cl-destructuring-bind (stats) event-args
1952 (setq buffer (ert--setup-results-buffer stats 1963 (setq buffer (ert--setup-results-buffer stats
1953 listener 1964 listener
1954 output-buffer-name)) 1965 output-buffer-name))
1955 (pop-to-buffer buffer))) 1966 (pop-to-buffer buffer)))
1956 (run-ended 1967 (run-ended
1957 (destructuring-bind (stats abortedp) event-args 1968 (cl-destructuring-bind (stats abortedp) event-args
1958 (funcall message-fn 1969 (funcall message-fn
1959 "%sRan %s tests, %s results were as expected%s" 1970 "%sRan %s tests, %s results were as expected%s"
1960 (if (not abortedp) 1971 (if (not abortedp)
@@ -1971,19 +1982,19 @@ and how to display message."
1971 ert--results-ewoc) 1982 ert--results-ewoc)
1972 stats))) 1983 stats)))
1973 (test-started 1984 (test-started
1974 (destructuring-bind (stats test) event-args 1985 (cl-destructuring-bind (stats test) event-args
1975 (with-current-buffer buffer 1986 (with-current-buffer buffer
1976 (let* ((ewoc ert--results-ewoc) 1987 (let* ((ewoc ert--results-ewoc)
1977 (pos (ert--stats-test-pos stats test)) 1988 (pos (ert--stats-test-pos stats test))
1978 (node (ewoc-nth ewoc pos))) 1989 (node (ewoc-nth ewoc pos)))
1979 (assert node) 1990 (cl-assert node)
1980 (setf (ert--ewoc-entry-test (ewoc-data node)) test) 1991 (setf (ert--ewoc-entry-test (ewoc-data node)) test)
1981 (aset ert--results-progress-bar-string pos 1992 (aset ert--results-progress-bar-string pos
1982 (ert-char-for-test-result nil t)) 1993 (ert-char-for-test-result nil t))
1983 (ert--results-update-stats-display-maybe ewoc stats) 1994 (ert--results-update-stats-display-maybe ewoc stats)
1984 (ewoc-invalidate ewoc node))))) 1995 (ewoc-invalidate ewoc node)))))
1985 (test-ended 1996 (test-ended
1986 (destructuring-bind (stats test result) event-args 1997 (cl-destructuring-bind (stats test result) event-args
1987 (with-current-buffer buffer 1998 (with-current-buffer buffer
1988 (let* ((ewoc ert--results-ewoc) 1999 (let* ((ewoc ert--results-ewoc)
1989 (pos (ert--stats-test-pos stats test)) 2000 (pos (ert--stats-test-pos stats test))
@@ -2015,28 +2026,28 @@ and how to display message."
2015(define-derived-mode ert-results-mode special-mode "ERT-Results" 2026(define-derived-mode ert-results-mode special-mode "ERT-Results"
2016 "Major mode for viewing results of ERT test runs.") 2027 "Major mode for viewing results of ERT test runs.")
2017 2028
2018(loop for (key binding) in 2029(cl-loop for (key binding) in
2019 '(;; Stuff that's not in the menu. 2030 '( ;; Stuff that's not in the menu.
2020 ("\t" forward-button) 2031 ("\t" forward-button)
2021 ([backtab] backward-button) 2032 ([backtab] backward-button)
2022 ("j" ert-results-jump-between-summary-and-result) 2033 ("j" ert-results-jump-between-summary-and-result)
2023 ("L" ert-results-toggle-printer-limits-for-test-at-point) 2034 ("L" ert-results-toggle-printer-limits-for-test-at-point)
2024 ("n" ert-results-next-test) 2035 ("n" ert-results-next-test)
2025 ("p" ert-results-previous-test) 2036 ("p" ert-results-previous-test)
2026 ;; Stuff that is in the menu. 2037 ;; Stuff that is in the menu.
2027 ("R" ert-results-rerun-all-tests) 2038 ("R" ert-results-rerun-all-tests)
2028 ("r" ert-results-rerun-test-at-point) 2039 ("r" ert-results-rerun-test-at-point)
2029 ("d" ert-results-rerun-test-at-point-debugging-errors) 2040 ("d" ert-results-rerun-test-at-point-debugging-errors)
2030 ("." ert-results-find-test-at-point-other-window) 2041 ("." ert-results-find-test-at-point-other-window)
2031 ("b" ert-results-pop-to-backtrace-for-test-at-point) 2042 ("b" ert-results-pop-to-backtrace-for-test-at-point)
2032 ("m" ert-results-pop-to-messages-for-test-at-point) 2043 ("m" ert-results-pop-to-messages-for-test-at-point)
2033 ("l" ert-results-pop-to-should-forms-for-test-at-point) 2044 ("l" ert-results-pop-to-should-forms-for-test-at-point)
2034 ("h" ert-results-describe-test-at-point) 2045 ("h" ert-results-describe-test-at-point)
2035 ("D" ert-delete-test) 2046 ("D" ert-delete-test)
2036 ("T" ert-results-pop-to-timings) 2047 ("T" ert-results-pop-to-timings)
2037 ) 2048 )
2038 do 2049 do
2039 (define-key ert-results-mode-map key binding)) 2050 (define-key ert-results-mode-map key binding))
2040 2051
2041(easy-menu-define ert-results-mode-menu ert-results-mode-map 2052(easy-menu-define ert-results-mode-menu ert-results-mode-map
2042 "Menu for `ert-results-mode'." 2053 "Menu for `ert-results-mode'."
@@ -2116,15 +2127,15 @@ To be used in the ERT results buffer."
2116EWOC-FN specifies the direction and should be either `ewoc-prev' 2127EWOC-FN specifies the direction and should be either `ewoc-prev'
2117or `ewoc-next'. If there are no more nodes in that direction, an 2128or `ewoc-next'. If there are no more nodes in that direction, an
2118error is signaled with the message ERROR-MESSAGE." 2129error is signaled with the message ERROR-MESSAGE."
2119 (loop 2130 (cl-loop
2120 (setq node (funcall ewoc-fn ert--results-ewoc node)) 2131 (setq node (funcall ewoc-fn ert--results-ewoc node))
2121 (when (null node) 2132 (when (null node)
2122 (error "%s" error-message)) 2133 (error "%s" error-message))
2123 (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) 2134 (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
2124 (goto-char (ewoc-location node)) 2135 (goto-char (ewoc-location node))
2125 (return)))) 2136 (cl-return))))
2126 2137
2127(defun ert--results-expand-collapse-button-action (button) 2138(defun ert--results-expand-collapse-button-action (_button)
2128 "Expand or collapse the test node BUTTON belongs to." 2139 "Expand or collapse the test node BUTTON belongs to."
2129 (let* ((ewoc ert--results-ewoc) 2140 (let* ((ewoc ert--results-ewoc)
2130 (node (save-excursion 2141 (node (save-excursion
@@ -2153,11 +2164,11 @@ To be used in the ERT results buffer."
2153(defun ert--ewoc-position (ewoc node) 2164(defun ert--ewoc-position (ewoc node)
2154 ;; checkdoc-order: nil 2165 ;; checkdoc-order: nil
2155 "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." 2166 "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
2156 (loop for i from 0 2167 (cl-loop for i from 0
2157 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) 2168 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
2158 do (when (eql node node-here) 2169 do (when (eql node node-here)
2159 (return i)) 2170 (cl-return i))
2160 finally (return nil))) 2171 finally (cl-return nil)))
2161 2172
2162(defun ert-results-jump-between-summary-and-result () 2173(defun ert-results-jump-between-summary-and-result ()
2163 "Jump back and forth between the test run summary and individual test results. 2174 "Jump back and forth between the test run summary and individual test results.
@@ -2205,7 +2216,7 @@ To be used in the ERT results buffer."
2205 "Return the test at point, or nil. 2216 "Return the test at point, or nil.
2206 2217
2207To be used in the ERT results buffer." 2218To be used in the ERT results buffer."
2208 (assert (eql major-mode 'ert-results-mode)) 2219 (cl-assert (eql major-mode 'ert-results-mode))
2209 (if (ert--results-test-node-or-null-at-point) 2220 (if (ert--results-test-node-or-null-at-point)
2210 (let* ((node (ert--results-test-node-at-point)) 2221 (let* ((node (ert--results-test-node-at-point))
2211 (test (ert--ewoc-entry-test (ewoc-data node)))) 2222 (test (ert--ewoc-entry-test (ewoc-data node))))
@@ -2277,9 +2288,9 @@ definition."
2277 (point)) 2288 (point))
2278 ((eventp last-command-event) 2289 ((eventp last-command-event)
2279 (posn-point (event-start last-command-event))) 2290 (posn-point (event-start last-command-event)))
2280 (t (assert nil)))) 2291 (t (cl-assert nil))))
2281 2292
2282(defun ert--results-progress-bar-button-action (button) 2293(defun ert--results-progress-bar-button-action (_button)
2283 "Jump to details for the test represented by the character clicked in BUTTON." 2294 "Jump to details for the test represented by the character clicked in BUTTON."
2284 (goto-char (ert--button-action-position)) 2295 (goto-char (ert--button-action-position))
2285 (ert-results-jump-between-summary-and-result)) 2296 (ert-results-jump-between-summary-and-result))
@@ -2289,7 +2300,7 @@ definition."
2289 2300
2290To be used in the ERT results buffer." 2301To be used in the ERT results buffer."
2291 (interactive) 2302 (interactive)
2292 (assert (eql major-mode 'ert-results-mode)) 2303 (cl-assert (eql major-mode 'ert-results-mode))
2293 (let ((selector (ert--stats-selector ert--results-stats))) 2304 (let ((selector (ert--stats-selector ert--results-stats)))
2294 (ert-run-tests-interactively selector (buffer-name)))) 2305 (ert-run-tests-interactively selector (buffer-name))))
2295 2306
@@ -2298,13 +2309,13 @@ To be used in the ERT results buffer."
2298 2309
2299To be used in the ERT results buffer." 2310To be used in the ERT results buffer."
2300 (interactive) 2311 (interactive)
2301 (destructuring-bind (test redefinition-state) 2312 (cl-destructuring-bind (test redefinition-state)
2302 (ert--results-test-at-point-allow-redefinition) 2313 (ert--results-test-at-point-allow-redefinition)
2303 (when (null test) 2314 (when (null test)
2304 (error "No test at point")) 2315 (error "No test at point"))
2305 (let* ((stats ert--results-stats) 2316 (let* ((stats ert--results-stats)
2306 (progress-message (format "Running %stest %S" 2317 (progress-message (format "Running %stest %S"
2307 (ecase redefinition-state 2318 (cl-ecase redefinition-state
2308 ((nil) "") 2319 ((nil) "")
2309 (redefined "new definition of ") 2320 (redefined "new definition of ")
2310 (deleted "deleted ")) 2321 (deleted "deleted "))
@@ -2345,7 +2356,7 @@ To be used in the ERT results buffer."
2345 (stats ert--results-stats) 2356 (stats ert--results-stats)
2346 (pos (ert--stats-test-pos stats test)) 2357 (pos (ert--stats-test-pos stats test))
2347 (result (aref (ert--stats-test-results stats) pos))) 2358 (result (aref (ert--stats-test-results stats) pos)))
2348 (etypecase result 2359 (cl-etypecase result
2349 (ert-test-passed (error "Test passed, no backtrace available")) 2360 (ert-test-passed (error "Test passed, no backtrace available"))
2350 (ert-test-result-with-condition 2361 (ert-test-result-with-condition
2351 (let ((backtrace (ert-test-result-with-condition-backtrace result)) 2362 (let ((backtrace (ert-test-result-with-condition-backtrace result))
@@ -2403,13 +2414,14 @@ To be used in the ERT results buffer."
2403 (ert-simple-view-mode) 2414 (ert-simple-view-mode)
2404 (if (null (ert-test-result-should-forms result)) 2415 (if (null (ert-test-result-should-forms result))
2405 (insert "\n(No should forms during this test.)\n") 2416 (insert "\n(No should forms during this test.)\n")
2406 (loop for form-description in (ert-test-result-should-forms result) 2417 (cl-loop for form-description
2407 for i from 1 do 2418 in (ert-test-result-should-forms result)
2408 (insert "\n") 2419 for i from 1 do
2409 (insert (format "%s: " i)) 2420 (insert "\n")
2410 (let ((begin (point))) 2421 (insert (format "%s: " i))
2411 (ert--pp-with-indentation-and-newline form-description) 2422 (let ((begin (point)))
2412 (ert--make-xrefs-region begin (point))))) 2423 (ert--pp-with-indentation-and-newline form-description)
2424 (ert--make-xrefs-region begin (point)))))
2413 (goto-char (point-min)) 2425 (goto-char (point-min))
2414 (insert "`should' forms executed during test `") 2426 (insert "`should' forms executed during test `")
2415 (ert-insert-test-name-button (ert-test-name test)) 2427 (ert-insert-test-name-button (ert-test-name test))
@@ -2438,17 +2450,16 @@ To be used in the ERT results buffer."
2438To be used in the ERT results buffer." 2450To be used in the ERT results buffer."
2439 (interactive) 2451 (interactive)
2440 (let* ((stats ert--results-stats) 2452 (let* ((stats ert--results-stats)
2441 (start-times (ert--stats-test-start-times stats))
2442 (end-times (ert--stats-test-end-times stats))
2443 (buffer (get-buffer-create "*ERT timings*")) 2453 (buffer (get-buffer-create "*ERT timings*"))
2444 (data (loop for test across (ert--stats-tests stats) 2454 (data (cl-loop for test across (ert--stats-tests stats)
2445 for start-time across (ert--stats-test-start-times stats) 2455 for start-time across (ert--stats-test-start-times
2446 for end-time across (ert--stats-test-end-times stats) 2456 stats)
2447 collect (list test 2457 for end-time across (ert--stats-test-end-times stats)
2448 (float-time (subtract-time end-time 2458 collect (list test
2449 start-time)))))) 2459 (float-time (subtract-time
2460 end-time start-time))))))
2450 (setq data (sort data (lambda (a b) 2461 (setq data (sort data (lambda (a b)
2451 (> (second a) (second b))))) 2462 (> (cl-second a) (cl-second b)))))
2452 (pop-to-buffer buffer) 2463 (pop-to-buffer buffer)
2453 (let ((inhibit-read-only t)) 2464 (let ((inhibit-read-only t))
2454 (buffer-disable-undo) 2465 (buffer-disable-undo)
@@ -2457,13 +2468,13 @@ To be used in the ERT results buffer."
2457 (if (null data) 2468 (if (null data)
2458 (insert "(No data)\n") 2469 (insert "(No data)\n")
2459 (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) 2470 (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
2460 (loop for (test time) in data 2471 (cl-loop for (test time) in data
2461 for cumul-time = time then (+ cumul-time time) 2472 for cumul-time = time then (+ cumul-time time)
2462 for i from 1 do 2473 for i from 1 do
2463 (let ((begin (point))) 2474 (progn
2464 (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) 2475 (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
2465 (ert-insert-test-name-button (ert-test-name test)) 2476 (ert-insert-test-name-button (ert-test-name test))
2466 (insert "\n")))) 2477 (insert "\n"))))
2467 (goto-char (point-min)) 2478 (goto-char (point-min))
2468 (insert "Tests by run time (seconds):\n\n") 2479 (insert "Tests by run time (seconds):\n\n")
2469 (forward-line 1)))) 2480 (forward-line 1))))
@@ -2476,7 +2487,7 @@ To be used in the ERT results buffer."
2476 (error "Requires Emacs 24")) 2487 (error "Requires Emacs 24"))
2477 (let (test-name 2488 (let (test-name
2478 test-definition) 2489 test-definition)
2479 (etypecase test-or-test-name 2490 (cl-etypecase test-or-test-name
2480 (symbol (setq test-name test-or-test-name 2491 (symbol (setq test-name test-or-test-name
2481 test-definition (ert-get-test test-or-test-name))) 2492 test-definition (ert-get-test test-or-test-name)))
2482 (ert-test (setq test-name (ert-test-name test-or-test-name) 2493 (ert-test (setq test-name (ert-test-name test-or-test-name)