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

Last change on this file since 12046 was 12046, checked in by gz, 10 years ago

Don't let tests change the global optimize settings.

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