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 |----------------------------------------------------------------------------|
#
24 (:export
#:*do-tests-when-defined
* #:*test
* #:continue-testing
25 #:deftest
#:do-test
#:do-tests
#:get-test
#:pending-tests
26 #:rem-all-tests
#:rem-test
)
27 (:documentation
"The MIT regression tester"))
31 (defvar *test
* nil
"Current test name")
32 (defvar *do-tests-when-defined
* nil
)
33 (defvar *entries
* '(nil) "Test database")
34 (defvar *in-test
* nil
"Used by TEST")
35 (defvar *debug
* nil
"For debugging")
36 (defvar *catch-errors
* t
37 "When true, causes errors in a test to be caught.")
38 (defvar *print-circle-on-failure
* nil
39 "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
40 (defvar *compile-tests
* nil
41 "When true, compile the tests before running them.")
42 (defvar *optimization-settings
* '((safety 3)))
43 (defvar *expected-failures
* nil
44 "A list of test names that are expected to fail.")
46 (defstruct (entry (:conc-name nil
)
50 (defmacro vals
(entry) `(cdddr ,entry
))
52 (defmacro defn
(entry) `(cdr ,entry
))
54 (defun pending-tests ()
55 (do ((l (cdr *entries
*) (cdr l
))
57 ((null l
) (nreverse r
))
59 (push (name (car l
)) r
))))
61 (defun rem-all-tests ()
62 (setq *entries
* (list nil
))
65 (defun rem-test (&optional
(name *test
*))
66 (do ((l *entries
* (cdr l
)))
68 (when (equal (name (cadr l
)) name
)
69 (setf (cdr l
) (cddr l
))
72 (defun get-test (&optional
(name *test
*))
73 (defn (get-entry name
)))
75 (defun get-entry (name)
76 (let ((entry (find name
(cdr *entries
*)
81 "~%No test with name ~:@(~S~)."
85 (defmacro deftest
(name form
&rest values
)
86 `(add-entry '(t ,name
,form .
,values
)))
88 (defun add-entry (entry)
89 (setq entry
(copy-list entry
))
90 (do ((l *entries
* (cdr l
))) (nil)
92 (setf (cdr l
) (list entry
))
94 (when (equal (name (cadr l
))
98 "Redefining test ~:@(~S~)"
101 (when *do-tests-when-defined
*
103 (setq *test
* (name entry
)))
105 (defun report-error (error?
&rest args
)
107 (apply #'format t args
)
108 (if error?
(throw '*debug
* nil
)))
109 (error?
(apply #'error args
))
110 (t (apply #'warn args
))))
112 (defun do-test (&optional
(name *test
*))
113 (do-entry (get-entry name
)))
115 (defun equalp-with-case (x y
)
116 "Like EQUALP, but doesn't do case conversion of characters."
121 (equalp-with-case (car x
) (car y
))
122 (equalp-with-case (cdr x
) (cdr y
))))
123 ((and (typep x
'array
)
124 (= (array-rank x
) 0))
125 (equalp-with-case (aref x
) (aref y
)))
127 (and (typep y
'vector
)
128 (let ((x-len (length x
))
130 (and (eql x-len y-len
)
134 always
(equalp-with-case e1 e2
))))))
135 ((and (typep x
'array
)
137 (not (equal (array-dimensions x
)
138 (array-dimensions y
))))
141 (and (typep y
'array
)
142 (let ((size (array-total-size x
)))
143 (loop for i from
0 below size
144 always
(equalp-with-case (row-major-aref x i
)
145 (row-major-aref y i
))))))
148 (defun do-entry (entry &optional
149 (s *standard-output
*))
151 (setq *test
* (name entry
))
152 (setf (pend entry
) t
)
154 ;; (*break-on-warnings* t)
157 ;; (declare (special *break-on-warnings*))
169 (optimize ,@*optimization-settings
*))
172 (eval (form entry
))))))
175 ((style-warning #'muffle-warning
)
179 (return-from aborted nil
))))
185 (not (equalp-with-case r
(vals entry
)))))
188 (let ((*print-circle
* *print-circle-on-failure
*))
189 (format s
"~&Test ~:@(~S~) failed~
191 ~%Expected value~P: ~
194 (length (vals entry
))
196 (format s
"Actual value~P: ~
199 (when (not (pend entry
)) *test
*))
201 (defun continue-testing ()
203 (throw '*in-test
* nil
)
204 (do-entries *standard-output
*)))
206 (defun do-tests (&optional
207 (out *standard-output
*))
208 (dolist (entry (cdr *entries
*))
209 (setf (pend entry
) t
))
213 (stream out
:direction
:output
)
214 (do-entries stream
))))
216 (defun do-entries (s)
217 (format s
"~&Doing ~A pending test~:P ~
218 of ~A tests total.~%"
219 (count t
(cdr *entries
*)
221 (length (cdr *entries
*)))
222 (dolist (entry (cdr *entries
*))
224 (format s
"~@[~<~%~:; ~:@(~S~)~>~]"
225 (do-entry entry s
))))
226 (let ((pending (pending-tests))
227 (expected-table (make-hash-table :test
#'equal
)))
228 (dolist (ex *expected-failures
*)
229 (setf (gethash ex expected-table
) t
))
231 (loop for pend in pending
232 unless
(gethash pend expected-table
)
235 (format s
"~&No tests failed.")
237 (format s
"~&~A out of ~A ~
238 total tests failed: ~
242 (length (cdr *entries
*))
244 (if (null new-failures
)
245 (format s
"~&No unexpected failures.")
246 (when *expected-failures
*
247 (format s
"~&~A unexpected failures: ~
250 (length new-failures
)