1 #|----------------------------------------------------------------------------|
2 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
4 | Permission to use, copy, modify, and distribute this software and its |
5 | documentation for any purpose and without fee is hereby granted, provided |
6 | that this copyright and permission notice appear in all copies and |
7 | supporting documentation, and that the name of M.I.T. not be used in |
8 | advertising or publicity pertaining to distribution of the software |
9 | without specific, written prior permission. M.I.T. makes no |
10 | representations about the suitability of this software for any purpose. |
11 | It is provided "as is" without express or implied warranty. |
13 | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
14 | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
15 | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
16 | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
17 | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
18 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
20 |----------------------------------------------------------------------------|#
22 (defpackage #:regression-test
23 (:nicknames #:rtest #-lispworks #:rt)
25 (:export #:*do-tests-when-defined* #:*test* #:continue-testing
26 #:deftest #:do-test #:do-tests #:get-test #:pending-tests
27 #:rem-all-tests #:rem-test)
28 (:documentation "The MIT regression tester with pfdietz's modifications"))
30 (in-package :regression-test)
32 (defvar *test* nil "Current test name")
33 (defvar *do-tests-when-defined* nil)
34 (defvar *entries* '(nil) "Test database")
35 (defvar *in-test* nil "Used by TEST")
36 (defvar *debug* nil "For debugging")
37 (defvar *catch-errors* t
38 "When true, causes errors in a test to be caught.")
39 (defvar *print-circle-on-failure* nil
40 "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
41 (defvar *compile-tests* nil
42 "When true, compile the tests before running them.")
43 (defvar *optimization-settings* '((safety 3)))
44 (defvar *expected-failures* nil
45 "A list of test names that are expected to fail.")
47 (defstruct (entry (:conc-name nil)
51 (defmacro vals (entry) `(cdddr ,entry))
53 (defmacro defn (entry) `(cdr ,entry))
55 (defun pending-tests ()
56 (do ((l (cdr *entries*) (cdr l))
58 ((null l) (nreverse r))
60 (push (name (car l)) r))))
62 (defun rem-all-tests ()
63 (setq *entries* (list nil))
66 (defun rem-test (&optional (name *test*))
67 (do ((l *entries* (cdr l)))
69 (when (equal (name (cadr l)) name)
70 (setf (cdr l) (cddr l))
73 (defun get-test (&optional (name *test*))
74 (defn (get-entry name)))
76 (defun get-entry (name)
77 (let ((entry (find name (cdr *entries*)
82 "~%No test with name ~:@(~S~)."
86 (defmacro deftest (name form &rest values)
87 `(add-entry '(t ,name ,form .,values)))
89 (defun add-entry (entry)
90 (setq entry (copy-list entry))
91 (do ((l *entries* (cdr l))) (nil)
93 (setf (cdr l) (list entry))
95 (when (equal (name (cadr l))
99 "Redefining test ~:@(~S~)"
102 (when *do-tests-when-defined*
104 (setq *test* (name entry)))
106 (defun report-error (error? &rest args)
108 (apply #'format t args)
109 (if error? (throw '*debug* nil)))
110 (error? (apply #'error args))
111 (t (apply #'warn args))))
113 (defun do-test (&optional (name *test*))
114 (do-entry (get-entry name)))
116 (defun equalp-with-case (x y)
117 "Like EQUALP, but doesn't do case conversion of characters."
122 (equalp-with-case (car x) (car y))
123 (equalp-with-case (cdr x) (cdr y))))
124 ((and (typep x 'array)
125 (= (array-rank x) 0))
126 (equalp-with-case (aref x) (aref y)))
128 (and (typep y 'vector)
129 (let ((x-len (length x))
131 (and (eql x-len y-len)
135 always (equalp-with-case e1 e2))))))
136 ((and (typep x 'array)
138 (not (equal (array-dimensions x)
139 (array-dimensions y))))
142 (and (typep y 'array)
143 (let ((size (array-total-size x)))
144 (loop for i from 0 below size
145 always (equalp-with-case (row-major-aref x i)
146 (row-major-aref y i))))))
149 (defun do-entry (entry &optional
150 (s *standard-output*))
152 (setq *test* (name entry))
153 (setf (pend entry) t)
155 ;; (*break-on-warnings* t)
158 ;; (declare (special *break-on-warnings*))
170 (optimize ,@*optimization-settings*))
173 (eval (form entry))))))
176 ((style-warning #'muffle-warning)
180 (return-from aborted nil))))
186 (not (equalp-with-case r (vals entry)))))
189 (let ((*print-circle* *print-circle-on-failure*))
190 (format s "~&Test ~:@(~S~) failed~
192 ~%Expected value~P: ~
195 (length (vals entry))
197 (format s "Actual value~P: ~
200 (when (not (pend entry)) *test*))
202 (defun continue-testing ()
204 (throw '*in-test* nil)
205 (do-entries *standard-output*)))
207 (defun do-tests (&optional
208 (out *standard-output*))
209 (dolist (entry (cdr *entries*))
210 (setf (pend entry) t))
214 (stream out :direction :output)
215 (do-entries stream))))
217 (defun do-entries (s)
218 (format s "~&Doing ~A pending test~:P ~
219 of ~A tests total.~%"
220 (count t (cdr *entries*)
222 (length (cdr *entries*)))
223 (dolist (entry (cdr *entries*))
225 (format s "~@[~<~%~:; ~:@(~S~)~>~]"
226 (do-entry entry s))))
227 (let ((pending (pending-tests))
228 (expected-table (make-hash-table :test #'equal)))
229 (dolist (ex *expected-failures*)
230 (setf (gethash ex expected-table) t))
232 (loop for pend in pending
233 unless (gethash pend expected-table)
236 (format s "~&No tests failed.")
238 (format s "~&~A out of ~A ~
239 total tests failed: ~
243 (length (cdr *entries*))
245 (if (null new-failures)
246 (format s "~&No unexpected failures.")
247 (when *expected-failures*
248 (format s "~&~A unexpected failures: ~
251 (length new-failures)