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

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

Check in the gcl ansi test suite (original, in preparation for making local changes)

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