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

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

suppress compiler warnings around compilation of test forms

File size: 14.7 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 (let (#+openmcl (ccl::*suppress-compiler-warnings* t))
257                                          (compile
258                                           nil
259                                           `(lambda ()
260                                              (declare
261                                               (optimize ,@*optimization-settings*))
262                                              ,(form entry))))))
263                               #+openmcl (ccl::lfun-name fn (name entry))
264                               (multiple-value-list (funcall fn))))
265                            (*expanded-eval*
266                             (multiple-value-list
267                              (expanded-eval (form entry))))
268                            (t
269                             (multiple-value-list
270                              (eval (form entry))))))))
271                (if *catch-errors*
272                    (handler-bind
273                     (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings)
274                                                             c
275                                                           (muffle-warning c))))
276                            (error #'(lambda (c)
277                                       (setf aborted t)
278                                       (setf r (list c))
279                                       (when (eq *catch-errors* :break)
280                                         (break "Error ~s: ~a" (type-of c) c))
281                                       (return-from aborted nil))))
282                     (%do))
283                  (%do)))))
284
285      (setf (pend entry)
286            (or aborted
287                (not (equalp-with-case r (vals entry)))))
288     
289      (when (pend entry)
290        (let ((*print-circle* *print-circle-on-failure*))
291          (format s "~2&Test ~:@(~S~) failed~
292                   ~%Form: ~S~
293                   ~%Expected value~P: ~
294                      ~{~S~^~%~17t~}~%"
295                  *test* (form entry)
296                  (length (vals entry))
297                  (vals entry))
298          (handler-case
299           (let ((st (format nil "Actual value~P: ~
300                      ~{~S~^~%~15t~}.~%"
301                             (length r) r)))
302             (format s "~A" st))
303           (error () (format s "Actual value: #<error during printing>~%")))
304          (finish-output s)))))
305  (when (not (pend entry)) *test*))
306
307(defun expanded-eval (form)
308  "Split off top level of a form and eval separately.  This reduces the chance that
309   compiler optimizations will fold away runtime computation."
310  (if (not (consp form))
311      (eval form)
312   (let ((op (car form)))
313     (cond
314      ((eq op 'let)
315       (let* ((bindings (loop for b in (cadr form)
316                              collect (if (consp b) b (list b nil))))
317              (vars (mapcar #'car bindings))
318              (binding-forms (mapcar #'cadr bindings)))
319         (apply
320          (the function
321            (eval `(lambda ,vars ,@(cddr form))))
322          (mapcar #'eval binding-forms))))
323      ((and (eq op 'let*) (cadr form))
324       (let* ((bindings (loop for b in (cadr form)
325                              collect (if (consp b) b (list b nil))))
326              (vars (mapcar #'car bindings))
327              (binding-forms (mapcar #'cadr bindings)))
328         (funcall
329          (the function
330            (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
331          (eval (car binding-forms)))))
332      ((eq op 'progn)
333       (loop for e on (cdr form)
334             do (if (null (cdr e)) (return (eval (car e)))
335                  (eval (car e)))))
336      ((and (symbolp op) (fboundp op)
337            (not (macro-function op))
338            (not (special-operator-p op)))
339       (apply (symbol-function op)
340              (mapcar #'eval (cdr form))))
341      (t (eval form))))))
342
343(defun continue-testing ()
344  (if *in-test*
345      (throw '*in-test* nil)
346      (do-entries *standard-output*)))
347
348(defun do-tests (&key (out *standard-output*)
349                      ((:verbose *test-verbose*) *test-verbose*)
350                      ((:catch-errors *catch-errors*) *catch-errors*)
351                      ((:compile *compile-tests*) *compile-tests*))
352  (setq *failed-tests* nil
353        *passed-tests* nil)
354  (dolist (entry (cdr *entries*))
355    (setf (pend entry) t))
356  (if (streamp out)
357      (do-entries out)
358      (with-open-file
359          (stream out :direction :output)
360        (do-entries stream))))
361
362(defun do-entries (s)
363  (format s "~&Doing ~A pending test~:P ~
364             of ~A tests total.~%"
365          (count t (the list (cdr *entries*)) :key #'pend)
366          (length (cdr *entries*)))
367  (finish-output s)
368  (dolist (entry (cdr *entries*))
369    (when (and (pend entry)
370               (not (has-disabled-note entry)))
371      (let ((success? (do-entry entry s)))
372        (if success?
373          (push (name entry) *passed-tests*)
374          (push (name entry) *failed-tests*))
375       (when *test-verbose*
376        (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?)))
377      (finish-output s)
378      ))
379  (let ((pending (pending-tests))
380        (expected-table (make-hash-table :test #'equal)))
381    (dolist (ex *expected-failures*)
382      (setf (gethash ex expected-table) t))
383    (let ((new-failures
384           (loop for pend in pending
385                 unless (gethash pend expected-table)
386                 collect pend)))
387      (if (null pending)
388          (format s "~&No tests failed.")
389        (progn
390          (format s "~&~A out of ~A ~
391                   total tests failed: ~
392                   ~:@(~{~<~%   ~1:;~S~>~
393                         ~^, ~}~)."
394                  (length pending)
395                  (length (cdr *entries*))
396                  pending)
397          (if (null new-failures)
398              (format s "~&No unexpected failures.")
399            (when *expected-failures*
400              (format s "~&~A unexpected failures: ~
401                   ~:@(~{~<~%   ~1:;~S~>~
402                         ~^, ~}~)."
403                    (length new-failures)
404                    new-failures)))
405          ))
406      (finish-output s)
407      (null pending))))
408
409;;; Note handling functions and macros
410
411(defmacro defnote (name contents &optional disabled)
412  `(eval-when (:load-toplevel :execute)
413     (let ((note (make-note :name ',name
414                            :contents ',contents
415                            :disabled ',disabled)))
416       (setf (gethash (note-name note) *notes*) note)
417       note)))
418
419(defun disable-note (n)
420  (let ((note (if (note-p n) n
421                (setf n (gethash n *notes*)))))
422    (unless note (error "~A is not a note or note name." n))
423    (setf (note-disabled note) t)
424    note))
425
426(defun enable-note (n)
427  (let ((note (if (note-p n) n
428                (setf n (gethash n *notes*)))))
429    (unless note (error "~A is not a note or note name." n))
430    (setf (note-disabled note) nil)
431    note))
432
433;;; Extended random regression
434
435(defun do-extended-tests (&key (tests *passed-tests*) (count nil)
436                               ((:catch-errors *catch-errors*) *catch-errors*)
437                               ((:compile *compile-tests*) *compile-tests*))
438  "Execute randomly chosen tests from TESTS until one fails or until
439   COUNT is an integer and that many tests have been executed."
440  (let ((test-vector (coerce tests 'simple-vector)))
441    (let ((n (length test-vector)))
442      (when (= n 0) (error "Must provide at least one test."))
443      (loop for i from 0
444            for name = (svref test-vector (random n))
445            until (eql i count)
446            do (print name)
447            unless (do-test name) return (values name (1+ i))))))
Note: See TracBrowser for help on using the repository browser.