1 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
3 #|----------------------------------------------------------------------------|
4 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
6 | Permission to use, copy, modify, and distribute this software and its |
7 | documentation for any purpose and without fee is hereby granted, provided |
8 | that this copyright and permission notice appear in all copies and |
9 | supporting documentation, and that the name of M.I.T. not be used in |
10 | advertising or publicity pertaining to distribution of the software |
11 | without specific, written prior permission. M.I.T. makes no |
12 | representations about the suitability of this software for any purpose. |
13 | It is provided "as is" without express or implied warranty. |
15 | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
16 | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
17 | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
18 | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
19 | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
20 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
22 |----------------------------------------------------------------------------|#
24 (defpackage #:regression-test
25 (:nicknames #:rtest #-lispworks #:rt)
27 (:export #:*do-tests-when-defined* #:*test* #:continue-testing
28 #:deftest #:do-test #:do-tests #:get-test #:pending-tests
29 #:rem-all-tests #:rem-test)
30 (:documentation "The MIT regression tester with pfdietz's modifications"))
32 ;;This was the December 19, 1990 version of the regression tester, but
33 ;;has since been modified.
35 (in-package :regression-test)
37 (declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
38 (declaim (type list *entries*))
39 (declaim (ftype (function (t &rest t) t) report-error))
40 (declaim (ftype (function (t &optional t) t) do-entry))
42 (defvar *test* nil "Current test name")
43 (defvar *do-tests-when-defined* nil)
44 (defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.")
45 (defvar *entries-tail* *entries* "Tail of the *entries* list")
46 (defvar *entries-table* (make-hash-table :test #'equal)
47 "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
48 (defvar *in-test* nil "Used by TEST")
49 (defvar *debug* nil "For debugging")
50 (defvar *catch-errors* t "When true, causes errors in a test to be caught.")
51 (defvar *print-circle-on-failure* nil
52 "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
54 (defvar *compile-tests* nil "When true, compile the tests before running them.")
55 (defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
56 (defvar *optimization-settings* '((safety 3)))
58 (defvar *expected-failures* nil
59 "A list of test names that are expected to fail.")
61 (defvar *notes* (make-hash-table :test 'equal)
62 "A mapping from names of notes to note objects.")
64 (defstruct (entry (:conc-name nil))
65 pend name props form vals)
67 ;;; Note objects are used to attach information to tests.
68 ;;; A typical use is to mark tests that depend on a particular
69 ;;; part of a set of requirements, or a particular interpretation
70 ;;; of the requirements.
75 disabled ;; When true, tests with this note are considered inactive
78 ;; (defmacro vals (entry) `(cdddr ,entry))
80 (defmacro defn (entry)
83 (list* (name ,var) (form ,var) (vals ,var)))))
85 (defun entry-notes (entry)
86 (let* ((props (props entry))
87 (notes (getf props :notes)))
92 (defun has-disabled-note (entry)
93 (let ((notes (entry-notes entry)))
95 for note = (if (note-p n) n
97 thereis (and note (note-disabled note)))))
99 (defun pending-tests ()
100 (loop for entry in (cdr *entries*)
101 when (and (pend entry) (not (has-disabled-note entry)))
102 collect (name entry)))
104 (defun rem-all-tests ()
105 (setq *entries* (list nil))
106 (setq *entries-tail* *entries*)
107 (clrhash *entries-table*)
110 (defun rem-test (&optional (name *test*))
111 (let ((pred (gethash name *entries-table*)))
113 (if (null (cddr pred))
114 (setq *entries-tail* pred)
115 (setf (gethash (name (caddr pred)) *entries-table*) pred))
116 (setf (cdr pred) (cddr pred))
117 (remhash name *entries-table*)
120 (defun get-test (&optional (name *test*))
121 (defn (get-entry name)))
123 (defun get-entry (name)
124 (let ((entry ;; (find name (the list (cdr *entries*))
125 ;; :key #'name :test #'equal)
126 (cadr (gethash name *entries-table*))
130 "~%No test with name ~:@(~S~)."
134 (defmacro deftest (name &rest body)
137 (loop while (keywordp (first p))
139 do (error "Poorly formed deftest: ~A~%"
140 (list* 'deftest name body))
141 append (list (pop p) (pop p))))
144 `(add-entry (make-entry :pend t
150 (defun add-entry (entry)
151 (setq entry (copy-entry entry))
152 (let* ((pred (gethash (name entry) *entries-table*)))
155 (setf (cadr pred) entry)
157 "Redefining test ~:@(~S~)"
160 (setf (gethash (name entry) *entries-table*) *entries-tail*)
161 (setf (cdr *entries-tail*) (cons entry nil))
162 (setf *entries-tail* (cdr *entries-tail*))
164 (when *do-tests-when-defined*
166 (setq *test* (name entry)))
168 (defun report-error (error? &rest args)
170 (apply #'format t args)
171 (if error? (throw '*debug* nil)))
172 (error? (apply #'error args))
173 (t (apply #'warn args)))
176 (defun do-test (&optional (name *test*))
177 #-sbcl (do-entry (get-entry name))
178 #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
179 (do-entry (get-entry name))))
181 (defun my-aref (a &rest args)
182 (apply #'aref a args))
184 (defun my-row-major-aref (a index)
185 (row-major-aref a index))
187 (defun equalp-with-case (x y)
188 "Like EQUALP, but doesn't do case conversion of characters.
189 Currently doesn't work on arrays of dimension > 2."
194 (equalp-with-case (car x) (car y))
195 (equalp-with-case (cdr x) (cdr y))))
196 ((and (typep x 'array)
197 (= (array-rank x) 0))
198 (equalp-with-case (my-aref x) (my-aref y)))
200 (and (typep y 'vector)
201 (let ((x-len (length x))
203 (and (eql x-len y-len)
205 for i from 0 below x-len
206 for e1 = (my-aref x i)
207 for e2 = (my-aref y i)
208 always (equalp-with-case e1 e2))))))
209 ((and (typep x 'array)
211 (not (equal (array-dimensions x)
212 (array-dimensions y))))
216 (and (typep y 'array)
217 (let ((size (array-total-size x)))
218 (loop for i from 0 below size
219 always (equalp-with-case (my-row-major-aref x i)
220 (my-row-major-aref y i))))))
224 (defun do-entry (entry &optional
225 (s *standard-output*))
227 (setq *test* (name entry))
228 (setf (pend entry) t)
230 ;; (*break-on-warnings* t)
233 ;; (declare (special *break-on-warnings*))
246 (optimize ,@*optimization-settings*))
250 (expanded-eval (form entry))))
253 (eval (form entry)))))))
256 (#-ecl (style-warning #'muffle-warning)
260 (return-from aborted nil))))
266 (not (equalp-with-case r (vals entry)))))
269 (let ((*print-circle* *print-circle-on-failure*))
270 (format s "~&Test ~:@(~S~) failed~
272 ~%Expected value~P: ~
275 (length (vals entry))
278 (let ((st (format nil "Actual value~P: ~
282 (error () (format s "Actual value: #<error during printing>~%")
286 (when (not (pend entry)) *test*))
288 (defun expanded-eval (form)
289 "Split off top level of a form and eval separately. This reduces the chance that
290 compiler optimizations will fold away runtime computation."
291 (if (not (consp form))
293 (let ((op (car form)))
296 (let* ((bindings (loop for b in (cadr form)
297 collect (if (consp b) b (list b nil))))
298 (vars (mapcar #'car bindings))
299 (binding-forms (mapcar #'cadr bindings)))
302 (eval `(lambda ,vars ,@(cddr form))))
303 (mapcar #'eval binding-forms))))
304 ((and (eq op 'let*) (cadr form))
305 (let* ((bindings (loop for b in (cadr form)
306 collect (if (consp b) b (list b nil))))
307 (vars (mapcar #'car bindings))
308 (binding-forms (mapcar #'cadr bindings)))
311 (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
312 (eval (car binding-forms)))))
314 (loop for e on (cdr form)
315 do (if (null (cdr e)) (return (eval (car e)))
317 ((and (symbolp op) (fboundp op)
318 (not (macro-function op))
319 (not (special-operator-p op)))
320 (apply (symbol-function op)
321 (mapcar #'eval (cdr form))))
324 (defun continue-testing ()
326 (throw '*in-test* nil)
327 (do-entries *standard-output*)))
329 (defun do-tests (&optional
330 (out *standard-output*))
331 (dolist (entry (cdr *entries*))
332 (setf (pend entry) t))
336 (stream out :direction :output)
337 (do-entries stream))))
339 (defun do-entries* (s)
340 (format s "~&Doing ~A pending test~:P ~
341 of ~A tests total.~%"
342 (count t (the list (cdr *entries*)) :key #'pend)
343 (length (cdr *entries*)))
345 (dolist (entry (cdr *entries*))
346 (when (and (pend entry)
347 (not (has-disabled-note entry)))
348 (format s "~@[~<~%~:; ~:@(~S~)~>~]"
352 (let ((pending (pending-tests))
353 (expected-table (make-hash-table :test #'equal)))
354 (dolist (ex *expected-failures*)
355 (setf (gethash ex expected-table) t))
357 (loop for pend in pending
358 unless (gethash pend expected-table)
361 (format s "~&No tests failed.")
363 (format s "~&~A out of ~A ~
364 total tests failed: ~
368 (length (cdr *entries*))
370 (if (null new-failures)
371 (format s "~&No unexpected failures.")
372 (when *expected-failures*
373 (format s "~&~A unexpected failures: ~
376 (length new-failures)
382 (defun do-entries (s)
383 #-sbcl (do-entries* s)
384 #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
387 ;;; Note handling functions and macros
389 (defmacro defnote (name contents &optional disabled)
390 `(eval-when (:load-toplevel :execute)
391 (let ((note (make-note :name ',name
393 :disabled ',disabled)))
394 (setf (gethash (note-name note) *notes*) note)
397 (defun disable-note (n)
398 (let ((note (if (note-p n) n
399 (setf n (gethash n *notes*)))))
400 (unless note (error "~A is not a note or note name." n))
401 (setf (note-disabled note) t)
404 (defun enable-note (n)
405 (let ((note (if (note-p n) n
406 (setf n (gethash n *notes*)))))
407 (unless note (error "~A is not a note or note name." n))
408 (setf (note-disabled note) nil)