source: trunk/tests/ansi-tests/rt.lsp @ 9840

Last change on this file since 9840 was 9840, checked in by gz, 12 years ago

Add *warn-if-redefine-test* (default t) to control the test redefinition warnings

File size: 14.4 KB
Line 
1;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
2
3#|----------------------------------------------------------------------------|
4 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
5 |                                                                            |
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.                |
14 |                                                                            |
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  |
21 |  SOFTWARE.                                                                 |
22 |----------------------------------------------------------------------------|#
23
24;This was the December 19, 1990 version of the regression tester, but
25;has since been modified.
26
27(in-package :regression-test)
28
29(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
30(declaim (type list *entries*))
31(declaim (ftype (function (t &rest t) t) report-error))
32(declaim (ftype (function (t &optional t) t) do-entry))
33
34(defvar *test* nil "Current test name")
35(defvar *do-tests-when-defined* nil)
36(defvar *entries* (list nil) "Test database.  Has a leading dummy cell that does not contain an entry.")
37(defvar *entries-tail* *entries* "Tail of the *entries* list")
38(defvar *entries-table* (make-hash-table :test #'equal)
39    "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
40(defvar *in-test* nil "Used by TEST")
41(defvar *debug* nil "For debugging")
42(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
43(defvar *print-circle-on-failure* nil
44  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
45(defvar *test-verbose* t "When true, print each test name as executed")
46
47(defvar *compile-tests* nil "When true, compile the tests before running them.")
48(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
49(defvar *optimization-settings* '((safety 3)))
50
51(defvar *warn-if-redefine-test* t)
52
53(defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed")
54(defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed")
55
56(defvar *expected-failures* nil
57  "A list of test names that are expected to fail.")
58
59(defvar *notes* (make-hash-table :test 'equal)
60  "A mapping from names of notes to note objects.")
61 
62(defstruct (entry (:conc-name nil))
63  pend name props form vals)
64
65;;; Note objects are used to attach information to tests.
66;;; A typical use is to mark tests that depend on a particular
67;;; part of a set of requirements, or a particular interpretation
68;;; of the requirements.
69
70(defstruct note
71  name 
72  contents
73  disabled ;; When true, tests with this note are considered inactive
74  )
75
76;; (defmacro vals (entry) `(cdddr ,entry))
77
78(defmacro defn (entry)
79  (let ((var (gensym)))
80    `(let ((,var ,entry))
81       (list* (name ,var) (form ,var) (vals ,var)))))
82
83(defun entry-notes (entry)
84  (let* ((props (props entry))
85         (notes (getf props :notes)))
86    (if (listp notes)
87        notes
88      (list notes))))
89
90(defun has-disabled-note (entry)
91  (let ((notes (entry-notes entry)))
92    (loop for n in notes
93          for note = (if (note-p n) n
94                       (gethash n *notes*))
95          thereis (and note (note-disabled note)))))
96
97(defun has-note (entry note)
98  (unless (note-p note)
99    (let ((new-note (gethash note *notes*)))
100      (setf note new-note)))
101  (and note (not (not (member note (entry-notes entry))))))
102
103(defun pending-tests ()
104  (loop for entry in (cdr *entries*)
105        when (and (pend entry) (not (has-disabled-note entry)))
106        collect (name entry)))
107
108(defun rem-all-tests ()
109  (setq *entries* (list nil))
110  (setq *entries-tail* *entries*)
111  (clrhash *entries-table*)
112  nil)
113
114(defun rem-test (&optional (name *test*))
115  (let ((pred (gethash name *entries-table*)))
116    (when pred
117      (if (null (cddr pred))
118          (setq *entries-tail* pred)
119        (setf (gethash (name (caddr pred)) *entries-table*) pred))
120      (setf (cdr pred) (cddr pred))
121      (remhash name *entries-table*)
122      name)))
123
124(defun get-test (&optional (name *test*))
125  (defn (get-entry name)))
126
127(defun get-entry (name)
128  (let ((entry ;; (find name (the list (cdr *entries*))
129               ;;     :key #'name :test #'equal)
130         (cadr (gethash name *entries-table*))
131         ))
132    (when (null entry)
133      (report-error t
134        "~%No test with name ~:@(~S~)."
135        name))
136    entry))
137
138(defmacro deftest (name &rest body)
139  (let* ((p body)
140         (properties
141          (loop while (keywordp (first p))
142                unless (cadr p)
143                do (error "Poorly formed deftest: ~A~%"
144                          (list* 'deftest name body))
145                append (list (pop p) (pop p))))
146         (form (pop p))
147         (vals p))
148    `(add-entry (make-entry :pend t
149                            :name ',name
150                            :props ',properties
151                            :form ',form
152                            :vals ',vals))))
153
154(defun add-entry (entry)
155  #+openmcl (ccl:record-source-file (name entry) 'deftest)
156  (setq entry (copy-entry entry))
157  (let* ((pred (gethash (name entry) *entries-table*)))
158    (cond
159     (pred
160      (setf (cadr pred) entry)
161      (when *warn-if-redefine-test*
162        (report-error nil
163                      "Redefining test ~:@(~S~)"
164                      (name entry))))
165     (t
166      (setf (gethash (name entry) *entries-table*) *entries-tail*)
167      (setf (cdr *entries-tail*) (cons entry nil))
168      (setf *entries-tail* (cdr *entries-tail*))
169      )))
170  (when *do-tests-when-defined*
171    (do-entry entry))
172  (setq *test* (name entry)))
173
174(defun report-error (error? &rest args)
175  (cond (*debug*
176         (apply #'format t args)
177         (if error? (throw '*debug* nil)))
178        (error? (apply #'error args))
179        (t (apply #'warn args)))
180  nil)
181
182(defun do-test (&optional (name *test*) &rest key-args)
183  (flet ((%parse-key-args
184          (&key
185           ((:catch-errors *catch-errors*) *catch-errors*)
186           ((:compile *compile-tests*) *compile-tests*))
187          (do-entry (get-entry name))))
188    (apply #'%parse-key-args key-args)))
189
190(defun my-aref (a &rest args)
191  (apply #'aref a args))
192
193(defun my-row-major-aref (a index)
194  (row-major-aref a index))
195
196(defun equalp-with-case (x y)
197  "Like EQUALP, but doesn't do case conversion of characters.
198   Currently doesn't work on arrays of dimension > 2."
199  (cond
200   ((eq x y) t)
201   ((consp x)
202    (and (consp y)
203         (equalp-with-case (car x) (car y))
204         (equalp-with-case (cdr x) (cdr y))))
205   ((and (typep x 'array)
206         (= (array-rank x) 0))
207    (equalp-with-case (my-aref x) (my-aref y)))
208   ((typep x 'vector)
209    (and (typep y 'vector)
210         (let ((x-len (length x))
211               (y-len (length y)))
212           (and (eql x-len y-len)
213                (loop
214                 for i from 0 below x-len
215                 for e1 = (my-aref x i)
216                 for e2 = (my-aref y i)
217                 always (equalp-with-case e1 e2))))))
218   ((and (typep x 'array)
219         (typep y 'array)
220         (not (equal (array-dimensions x)
221                     (array-dimensions y))))
222    nil)
223
224   ((typep x 'array)
225    (and (typep y 'array)
226         (let ((size (array-total-size x)))
227           (loop for i from 0 below size
228                 always (equalp-with-case (my-row-major-aref x i)
229                                          (my-row-major-aref y i))))))
230   ((typep x 'pathname)
231    (equal x y))
232   (t (eql x y))))
233
234(defun do-entry (entry &optional
235                       (s *standard-output*))
236  (catch '*in-test*
237    (setq *test* (name entry))
238    (setf (pend entry) t)
239    (let* ((*in-test* t)
240           ;; (*break-on-warnings* t)
241           (aborted nil)
242           r)
243      ;; (declare (special *break-on-warnings*))
244
245      (block aborted
246        (setf r
247              (flet ((%do ()
248                          (handler-bind
249                           #-sbcl nil
250                           #+sbcl ((sb-ext:code-deletion-note #'(lambda (c)
251                                                                  (if (has-note entry :do-not-muffle)
252                                                                      nil
253                                                                    (muffle-warning c)))))
254                           (cond
255                            (*compile-tests*
256                             (let ((fn (compile
257                                        nil
258                                        `(lambda ()
259                                           (declare
260                                            (optimize ,@*optimization-settings*))
261                                           ,(form entry)))))
262                               #+openmcl (ccl::lfun-name fn (name entry))
263                               (multiple-value-list (funcall fn))))
264                            (*expanded-eval*
265                             (multiple-value-list
266                              (expanded-eval (form entry))))
267                            (t
268                             (multiple-value-list
269                              (eval (form entry))))))))
270                (if *catch-errors*
271                    (handler-bind
272                     (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings)
273                                                             c
274                                                           (muffle-warning c))))
275                            (error #'(lambda (c)
276                                       (setf aborted t)
277                                       (setf r (list c))
278                                       (when (eq *catch-errors* :break)
279                                         (break "Error ~s: ~a" (type-of c) c))
280                                       (return-from aborted nil))))
281                     (%do))
282                  (%do)))))
283
284      (setf (pend entry)
285            (or aborted
286                (not (equalp-with-case r (vals entry)))))
287     
288      (when (pend entry)
289        (let ((*print-circle* *print-circle-on-failure*))
290          (format s "~2&Test ~:@(~S~) failed~
291                   ~%Form: ~S~
292                   ~%Expected value~P: ~
293                      ~{~S~^~%~17t~}~%"
294                  *test* (form entry)
295                  (length (vals entry))
296                  (vals entry))
297          (handler-case
298           (let ((st (format nil "Actual value~P: ~
299                      ~{~S~^~%~15t~}.~%"
300                             (length r) r)))
301             (format s "~A" st))
302           (error () (format s "Actual value: #<error during printing>~%")))
303          (finish-output s)))))
304  (when (not (pend entry)) *test*))
305
306(defun expanded-eval (form)
307  "Split off top level of a form and eval separately.  This reduces the chance that
308   compiler optimizations will fold away runtime computation."
309  (if (not (consp form))
310      (eval form)
311   (let ((op (car form)))
312     (cond
313      ((eq op 'let)
314       (let* ((bindings (loop for b in (cadr form)
315                              collect (if (consp b) b (list b nil))))
316              (vars (mapcar #'car bindings))
317              (binding-forms (mapcar #'cadr bindings)))
318         (apply
319          (the function
320            (eval `(lambda ,vars ,@(cddr form))))
321          (mapcar #'eval binding-forms))))
322      ((and (eq op 'let*) (cadr form))
323       (let* ((bindings (loop for b in (cadr form)
324                              collect (if (consp b) b (list b nil))))
325              (vars (mapcar #'car bindings))
326              (binding-forms (mapcar #'cadr bindings)))
327         (funcall
328          (the function
329            (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
330          (eval (car binding-forms)))))
331      ((eq op 'progn)
332       (loop for e on (cdr form)
333             do (if (null (cdr e)) (return (eval (car e)))
334                  (eval (car e)))))
335      ((and (symbolp op) (fboundp op)
336            (not (macro-function op))
337            (not (special-operator-p op)))
338       (apply (symbol-function op)
339              (mapcar #'eval (cdr form))))
340      (t (eval form))))))
341
342(defun continue-testing ()
343  (if *in-test*
344      (throw '*in-test* nil)
345      (do-entries *standard-output*)))
346
347(defun do-tests (&key (out *standard-output*)
348                      ((:verbose *test-verbose*) *test-verbose*)
349                      ((:catch-errors *catch-errors*) *catch-errors*)
350                      ((:compile *compile-tests*) *compile-tests*))
351  (setq *failed-tests* nil
352        *passed-tests* nil)
353  (dolist (entry (cdr *entries*))
354    (setf (pend entry) t))
355  (if (streamp out)
356      (do-entries out)
357      (with-open-file
358          (stream out :direction :output)
359        (do-entries stream))))
360
361(defun do-entries (s)
362  (format s "~&Doing ~A pending test~:P ~
363             of ~A tests total.~%"
364          (count t (the list (cdr *entries*)) :key #'pend)
365          (length (cdr *entries*)))
366  (finish-output s)
367  (dolist (entry (cdr *entries*))
368    (when (and (pend entry)
369               (not (has-disabled-note entry)))
370      (let ((success? (do-entry entry s)))
371        (if success?
372          (push (name entry) *passed-tests*)
373          (push (name entry) *failed-tests*))
374       (when *test-verbose*
375        (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?)))
376      (finish-output s)
377      ))
378  (let ((pending (pending-tests))
379        (expected-table (make-hash-table :test #'equal)))
380    (dolist (ex *expected-failures*)
381      (setf (gethash ex expected-table) t))
382    (let ((new-failures
383           (loop for pend in pending
384                 unless (gethash pend expected-table)
385                 collect pend)))
386      (if (null pending)
387          (format s "~&No tests failed.")
388        (progn
389          (format s "~&~A out of ~A ~
390                   total tests failed: ~
391                   ~:@(~{~<~%   ~1:;~S~>~
392                         ~^, ~}~)."
393                  (length pending)
394                  (length (cdr *entries*))
395                  pending)
396          (if (null new-failures)
397              (format s "~&No unexpected failures.")
398            (when *expected-failures*
399              (format s "~&~A unexpected failures: ~
400                   ~:@(~{~<~%   ~1:;~S~>~
401                         ~^, ~}~)."
402                    (length new-failures)
403                    new-failures)))
404          ))
405      (finish-output s)
406      (null pending))))
407
408;;; Note handling functions and macros
409
410(defmacro defnote (name contents &optional disabled)
411  `(eval-when (:load-toplevel :execute)
412     (let ((note (make-note :name ',name
413                            :contents ',contents
414                            :disabled ',disabled)))
415       (setf (gethash (note-name note) *notes*) note)
416       note)))
417
418(defun disable-note (n)
419  (let ((note (if (note-p n) n
420                (setf n (gethash n *notes*)))))
421    (unless note (error "~A is not a note or note name." n))
422    (setf (note-disabled note) t)
423    note))
424
425(defun enable-note (n)
426  (let ((note (if (note-p n) n
427                (setf n (gethash n *notes*)))))
428    (unless note (error "~A is not a note or note name." n))
429    (setf (note-disabled note) nil)
430    note))
431
432;;; Extended random regression
433
434(defun do-extended-tests (&key (tests *passed-tests*) (count nil)
435                               ((:catch-errors *catch-errors*) *catch-errors*)
436                               ((:compile *compile-tests*) *compile-tests*))
437  "Execute randomly chosen tests from TESTS until one fails or until
438   COUNT is an integer and that many tests have been executed."
439  (let ((test-vector (coerce tests 'simple-vector)))
440    (let ((n (length test-vector)))
441      (when (= n 0) (error "Must provide at least one test."))
442      (loop for i from 0
443            for name = (svref test-vector (random n))
444            until (eql i count)
445            do (print name)
446            unless (do-test name) return (values name (1+ i))))))
Note: See TracBrowser for help on using the repository browser.