diff options
| author | Stefan Monnier | 2012-11-22 22:26:09 -0500 |
|---|---|---|
| committer | Stefan Monnier | 2012-11-22 22:26:09 -0500 |
| commit | 15c9d04ea4b75254aef346161998e08509736fc0 (patch) | |
| tree | 98600640d98fffd8a91734bba4943134067aca02 | |
| parent | aa8715fbdb6c619666f7213a9ec8615b31b01517 (diff) | |
| download | emacs-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/ChangeLog | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert-x.el | 47 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 789 |
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 @@ | |||
| 1 | 2012-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 | |||
| 1 | 2012-11-22 Paul Eggert <eggert@cs.ucla.edu> | 5 | 2012-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 | ||
| 97 | To be used in ERT tests. If BODY finishes successfully, the test | 96 | To 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 | ||
| 150 | NOTE: Since the command is not called by `call-interactively' | 149 | NOTE: Since the command is not called by `call-interactively' |
| 151 | test for `called-interactively' in the command will fail." | 150 | test 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 | |||
| 224 | None of the ARGS are modified, but the return value may share | 223 | None of the ARGS are modified, but the return value may share |
| 225 | structure with the plists in ARGS." | 224 | structure 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 | ||
| 246 | This is useful if THUNK has undesirable side-effects on an Emacs | 245 | This is useful if THUNK has undesirable side-effects on an Emacs |
| 247 | buffer with a fixed name such as *Messages*." | 246 | buffer 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 | ||
| 264 | See `ert-call-with-buffer-renamed' for details." | 263 | See `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 | ||
| 107 | ERT-PRED is a predicate, ERT-LIST is the input list." | 106 | ERT-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 | ||
| 115 | Elements are compared using `eql'." | 114 | Elements 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 | ||
| 123 | Elements are compared using `eql'." | 122 | Elements 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 | ||
| 131 | Elements are compared using `eq'." | 130 | Elements 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 | |||
| 273 | and the body." | 273 | and 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 | ||
| 295 | BODY is evaluated as a `progn' when the test is run. It should | 295 | BODY 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 | |||
| 446 | and error signaling specific to the particular variant of | 447 | and 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 |
| 448 | FORM-DESCRIPTION-FORM before it has called INNER-FORM." | 449 | FORM-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 | ||
| 466 | Returns the value of FORM." | 466 | Returns 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 | ||
| 475 | Returns nil." | 475 | Returns 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." | |||
| 485 | Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, | 485 | Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, |
| 486 | and aborts the current test as failed if it doesn't." | 486 | and 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 | ||
| 513 | The error signaled needs to match TYPE. TYPE should be a list | 513 | The 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." | |||
| 576 | Returns nil if they are." | 576 | Returns 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." | |||
| 643 | Returns nil if they are equivalent, i.e., have the same value for | 643 | Returns nil if they are equivalent, i.e., have the same value for |
| 644 | each key, where absent values are treated as nil. The order of | 644 | each key, where absent values are treated as nil. The order of |
| 645 | key/value pairs in each list does not matter." | 645 | key/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 | ||
| 730 | Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") | 731 | Bound 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 | ||
| 736 | To be used within ERT tests. MESSAGE-FORM should evaluate to a | 737 | To 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 | ||
| 832 | This function records failures and errors and either terminates | 834 | This function records failures and errors and either terminates |
| @@ -834,21 +836,21 @@ the test silently or calls the interactive debugger, as | |||
| 834 | appropriate. | 836 | appropriate. |
| 835 | 837 | ||
| 836 | INFO is the ert--test-execution-info corresponding to this test | 838 | INFO is the ert--test-execution-info corresponding to this test |
| 837 | run. DEBUGGER-ARGS are the arguments to `debugger'." | 839 | run. 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 | ||
| 874 | This mainly sets up debugger-related bindings." | 876 | This 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 | ||
| 930 | Returns the result and stores it in ERT-TEST's `most-recent-result' slot." | 935 | Returns 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 | |||
| 1048 | contained in UNIVERSE." | 1053 | contained 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." | |||
| 1273 | SELECTOR is the selector that was used to select TESTS." | 1283 | SELECTOR 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 | ||
| 1346 | EXPECTEDP specifies whether the result was expected." | 1356 | EXPECTEDP 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 | ||
| 1358 | EXPECTEDP specifies whether the result was expected." | 1368 | EXPECTEDP 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 | ||
| 1380 | RESULT must be an `ert-test-result-with-condition'." | 1390 | RESULT 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 | ||
| 1533 | This can be used as an inverse of `add-to-list'." | 1543 | This 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 | |||
| 1552 | include the default, if any. | 1562 | include the default, if any. |
| 1553 | 1563 | ||
| 1554 | Signals an error if no test name was read." | 1564 | Signals 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." | |||
| 2116 | EWOC-FN specifies the direction and should be either `ewoc-prev' | 2127 | EWOC-FN specifies the direction and should be either `ewoc-prev' |
| 2117 | or `ewoc-next'. If there are no more nodes in that direction, an | 2128 | or `ewoc-next'. If there are no more nodes in that direction, an |
| 2118 | error is signaled with the message ERROR-MESSAGE." | 2129 | error 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 | ||
| 2207 | To be used in the ERT results buffer." | 2218 | To 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 | ||
| 2290 | To be used in the ERT results buffer." | 2301 | To 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 | ||
| 2299 | To be used in the ERT results buffer." | 2310 | To 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." | |||
| 2438 | To be used in the ERT results buffer." | 2450 | To 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) |