1 | #|----------------------------------------------------------------------------| |
---|
2 | | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | |
---|
3 | | | |
---|
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. | |
---|
12 | | | |
---|
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 | |
---|
19 | | SOFTWARE. | |
---|
20 | |----------------------------------------------------------------------------|# |
---|
21 | |
---|
22 | ;; (defpackage :rt |
---|
23 | ;; (:use #:cl) |
---|
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")) |
---|
28 | |
---|
29 | ;; (in-package :rt) |
---|
30 | |
---|
31 | (in-package :named-readtables-test) |
---|
32 | |
---|
33 | (defvar *test* nil "Current test name") |
---|
34 | (defvar *do-tests-when-defined* nil) |
---|
35 | (defvar *entries* '(nil) "Test database") |
---|
36 | (defvar *in-test* nil "Used by TEST") |
---|
37 | (defvar *debug* nil "For debugging") |
---|
38 | (defvar *catch-errors* t |
---|
39 | "When true, causes errors in a test to be caught.") |
---|
40 | (defvar *print-circle-on-failure* nil |
---|
41 | "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") |
---|
42 | (defvar *compile-tests* nil |
---|
43 | "When true, compile the tests before running them.") |
---|
44 | (defvar *optimization-settings* '((safety 3))) |
---|
45 | (defvar *expected-failures* nil |
---|
46 | "A list of test names that are expected to fail.") |
---|
47 | |
---|
48 | (defstruct (entry (:conc-name nil) |
---|
49 | (:type list)) |
---|
50 | pend name form) |
---|
51 | |
---|
52 | (defmacro vals (entry) `(cdddr ,entry)) |
---|
53 | |
---|
54 | (defmacro defn (entry) `(cdr ,entry)) |
---|
55 | |
---|
56 | (defun pending-tests () |
---|
57 | (do ((l (cdr *entries*) (cdr l)) |
---|
58 | (r nil)) |
---|
59 | ((null l) (nreverse r)) |
---|
60 | (when (pend (car l)) |
---|
61 | (push (name (car l)) r)))) |
---|
62 | |
---|
63 | (defun rem-all-tests () |
---|
64 | (setq *entries* (list nil)) |
---|
65 | nil) |
---|
66 | |
---|
67 | (defun rem-test (&optional (name *test*)) |
---|
68 | (do ((l *entries* (cdr l))) |
---|
69 | ((null (cdr l)) nil) |
---|
70 | (when (equal (name (cadr l)) name) |
---|
71 | (setf (cdr l) (cddr l)) |
---|
72 | (return name)))) |
---|
73 | |
---|
74 | (defun get-test (&optional (name *test*)) |
---|
75 | (defn (get-entry name))) |
---|
76 | |
---|
77 | (defun get-entry (name) |
---|
78 | (let ((entry (find name (cdr *entries*) |
---|
79 | :key #'name |
---|
80 | :test #'equal))) |
---|
81 | (when (null entry) |
---|
82 | (report-error t |
---|
83 | "~%No test with name ~:@(~S~)." |
---|
84 | name)) |
---|
85 | entry)) |
---|
86 | |
---|
87 | (defmacro deftest (name form &rest values) |
---|
88 | `(add-entry '(t ,name ,form .,values))) |
---|
89 | |
---|
90 | (defun add-entry (entry) |
---|
91 | (setq entry (copy-list entry)) |
---|
92 | (do ((l *entries* (cdr l))) (nil) |
---|
93 | (when (null (cdr l)) |
---|
94 | (setf (cdr l) (list entry)) |
---|
95 | (return nil)) |
---|
96 | (when (equal (name (cadr l)) |
---|
97 | (name entry)) |
---|
98 | (setf (cadr l) entry) |
---|
99 | (report-error nil |
---|
100 | "Redefining test ~:@(~S~)" |
---|
101 | (name entry)) |
---|
102 | (return nil))) |
---|
103 | (when *do-tests-when-defined* |
---|
104 | (do-entry entry)) |
---|
105 | (setq *test* (name entry))) |
---|
106 | |
---|
107 | (defun report-error (error? &rest args) |
---|
108 | (cond (*debug* |
---|
109 | (apply #'format t args) |
---|
110 | (if error? (throw '*debug* nil))) |
---|
111 | (error? (apply #'error args)) |
---|
112 | (t (apply #'warn args)))) |
---|
113 | |
---|
114 | (defun do-test (&optional (name *test*)) |
---|
115 | (do-entry (get-entry name))) |
---|
116 | |
---|
117 | (defun equalp-with-case (x y) |
---|
118 | "Like EQUALP, but doesn't do case conversion of characters." |
---|
119 | (cond |
---|
120 | ((eq x y) t) |
---|
121 | ((consp x) |
---|
122 | (and (consp y) |
---|
123 | (equalp-with-case (car x) (car y)) |
---|
124 | (equalp-with-case (cdr x) (cdr y)))) |
---|
125 | ((and (typep x 'array) |
---|
126 | (= (array-rank x) 0)) |
---|
127 | (equalp-with-case (aref x) (aref y))) |
---|
128 | ((typep x 'vector) |
---|
129 | (and (typep y 'vector) |
---|
130 | (let ((x-len (length x)) |
---|
131 | (y-len (length y))) |
---|
132 | (and (eql x-len y-len) |
---|
133 | (loop |
---|
134 | for e1 across x |
---|
135 | for e2 across y |
---|
136 | always (equalp-with-case e1 e2)))))) |
---|
137 | ((and (typep x 'array) |
---|
138 | (typep y 'array) |
---|
139 | (not (equal (array-dimensions x) |
---|
140 | (array-dimensions y)))) |
---|
141 | nil) |
---|
142 | ((typep x 'array) |
---|
143 | (and (typep y 'array) |
---|
144 | (let ((size (array-total-size x))) |
---|
145 | (loop for i from 0 below size |
---|
146 | always (equalp-with-case (row-major-aref x i) |
---|
147 | (row-major-aref y i)))))) |
---|
148 | (t (eql x y)))) |
---|
149 | |
---|
150 | (defun do-entry (entry &optional |
---|
151 | (s *standard-output*)) |
---|
152 | (catch '*in-test* |
---|
153 | (setq *test* (name entry)) |
---|
154 | (setf (pend entry) t) |
---|
155 | (let* ((*in-test* t) |
---|
156 | ;; (*break-on-warnings* t) |
---|
157 | (aborted nil) |
---|
158 | r) |
---|
159 | ;; (declare (special *break-on-warnings*)) |
---|
160 | |
---|
161 | (block aborted |
---|
162 | (setf r |
---|
163 | (flet ((%do |
---|
164 | () |
---|
165 | (if *compile-tests* |
---|
166 | (multiple-value-list |
---|
167 | (funcall (compile |
---|
168 | nil |
---|
169 | `(lambda () |
---|
170 | (declare |
---|
171 | (optimize ,@*optimization-settings*)) |
---|
172 | ,(form entry))))) |
---|
173 | (multiple-value-list |
---|
174 | (eval (form entry)))))) |
---|
175 | (if *catch-errors* |
---|
176 | (handler-bind |
---|
177 | ((style-warning #'muffle-warning) |
---|
178 | (error #'(lambda (c) |
---|
179 | (setf aborted t) |
---|
180 | (setf r (list c)) |
---|
181 | (return-from aborted nil)))) |
---|
182 | (%do)) |
---|
183 | (%do))))) |
---|
184 | |
---|
185 | (setf (pend entry) |
---|
186 | (or aborted |
---|
187 | (not (equalp-with-case r (vals entry))))) |
---|
188 | |
---|
189 | (when (pend entry) |
---|
190 | (let ((*print-circle* *print-circle-on-failure*)) |
---|
191 | (format s "~&Test ~:@(~S~) failed~ |
---|
192 | ~%Form: ~S~ |
---|
193 | ~%Expected value~P: ~ |
---|
194 | ~{~S~^~%~17t~}~%" |
---|
195 | *test* (form entry) |
---|
196 | (length (vals entry)) |
---|
197 | (vals entry)) |
---|
198 | (format s "Actual value~P: ~ |
---|
199 | ~{~S~^~%~15t~}.~%" |
---|
200 | (length r) r))))) |
---|
201 | (when (not (pend entry)) *test*)) |
---|
202 | |
---|
203 | (defun continue-testing () |
---|
204 | (if *in-test* |
---|
205 | (throw '*in-test* nil) |
---|
206 | (do-entries *standard-output*))) |
---|
207 | |
---|
208 | (defun do-tests (&optional |
---|
209 | (out *standard-output*)) |
---|
210 | (dolist (entry (cdr *entries*)) |
---|
211 | (setf (pend entry) t)) |
---|
212 | (if (streamp out) |
---|
213 | (do-entries out) |
---|
214 | (with-open-file |
---|
215 | (stream out :direction :output) |
---|
216 | (do-entries stream)))) |
---|
217 | |
---|
218 | (defun do-entries (s) |
---|
219 | (format s "~&Doing ~A pending test~:P ~ |
---|
220 | of ~A tests total.~%" |
---|
221 | (count t (cdr *entries*) |
---|
222 | :key #'pend) |
---|
223 | (length (cdr *entries*))) |
---|
224 | (dolist (entry (cdr *entries*)) |
---|
225 | (when (pend entry) |
---|
226 | (format s "~@[~<~%~:; ~:@(~S~)~>~]" |
---|
227 | (do-entry entry s)))) |
---|
228 | (let ((pending (pending-tests)) |
---|
229 | (expected-table (make-hash-table :test #'equal))) |
---|
230 | (dolist (ex *expected-failures*) |
---|
231 | (setf (gethash ex expected-table) t)) |
---|
232 | (let ((new-failures |
---|
233 | (loop for pend in pending |
---|
234 | unless (gethash pend expected-table) |
---|
235 | collect pend))) |
---|
236 | (if (null pending) |
---|
237 | (format s "~&No tests failed.") |
---|
238 | (progn |
---|
239 | (format s "~&~A out of ~A ~ |
---|
240 | total tests failed: ~ |
---|
241 | ~:@(~{~<~% ~1:;~S~>~ |
---|
242 | ~^, ~}~)." |
---|
243 | (length pending) |
---|
244 | (length (cdr *entries*)) |
---|
245 | pending) |
---|
246 | (if (null new-failures) |
---|
247 | (format s "~&No unexpected failures.") |
---|
248 | (when *expected-failures* |
---|
249 | (format s "~&~A unexpected failures: ~ |
---|
250 | ~:@(~{~<~% ~1:;~S~>~ |
---|
251 | ~^, ~}~)." |
---|
252 | (length new-failures) |
---|
253 | new-failures))) |
---|
254 | )) |
---|
255 | (finish-output s) |
---|
256 | (null pending)))) |
---|