stricter handling of declarations in DEFGENERIC
[sbcl.git] / contrib / sb-rt / rt.lisp
1 #|----------------------------------------------------------------------------|
2  | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
3  |                                                                            |
4  | Permission  to  use,  copy, modify, and distribute this software  and  its |
5  | documentation for any purpose  and without fee is hereby granted, provided |
6  | that this copyright  and  permission  notice  appear  in  all  copies  and |
7  | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
8  | advertising or  publicity  pertaining  to  distribution  of  the  software |
9  | without   specific,   written   prior   permission.      M.I.T.  makes  no |
10  | representations  about  the  suitability of this software for any purpose. |
11  | It is provided "as is" without express or implied warranty.                |
12  |                                                                            |
13  |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
14  |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
15  |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
16  |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
17  |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
18  |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
19  |  SOFTWARE.                                                                 |
20  |----------------------------------------------------------------------------|#
21
22 (defpackage :sb-rt
23   (:use #:cl)
24   (:export #:*do-tests-when-defined* #:*test* #:continue-testing
25            #:deftest #:do-test #:do-tests #:get-test #:pending-tests
26            #:rem-all-tests #:rem-test)
27   (:documentation "The MIT regression tester"))
28
29 (in-package :sb-rt)
30
31 (defvar *test* nil "Current test name")
32 (defvar *do-tests-when-defined* nil)
33 (defvar *entries* '(nil) "Test database")
34 (defvar *in-test* nil "Used by TEST")
35 (defvar *debug* nil "For debugging")
36 (defvar *catch-errors* t
37   "When true, causes errors in a test to be caught.")
38 (defvar *print-circle-on-failure* nil
39   "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
40 (defvar *compile-tests* nil
41   "When true, compile the tests before running them.")
42 (defvar *optimization-settings* '((safety 3)))
43 (defvar *expected-failures* nil
44   "A list of test names that are expected to fail.")
45
46 (defstruct (entry (:conc-name nil)
47                   (:type list))
48   pend name form)
49
50 (defmacro vals (entry) `(cdddr ,entry))
51
52 (defmacro defn (entry) `(cdr ,entry))
53
54 (defun pending-tests ()
55   (do ((l (cdr *entries*) (cdr l))
56        (r nil))
57       ((null l) (nreverse r))
58     (when (pend (car l))
59       (push (name (car l)) r))))
60
61 (defun rem-all-tests ()
62   (setq *entries* (list nil))
63   nil)
64
65 (defun rem-test (&optional (name *test*))
66   (do ((l *entries* (cdr l)))
67       ((null (cdr l)) nil)
68     (when (equal (name (cadr l)) name)
69       (setf (cdr l) (cddr l))
70       (return name))))
71
72 (defun get-test (&optional (name *test*))
73   (defn (get-entry name)))
74
75 (defun get-entry (name)
76   (let ((entry (find name (cdr *entries*)
77                      :key #'name
78                      :test #'equal)))
79     (when (null entry)
80       (report-error t
81         "~%No test with name ~:@(~S~)."
82         name))
83     entry))
84
85 (defmacro deftest (name form &rest values)
86   `(add-entry '(t ,name ,form .,values)))
87
88 (defun add-entry (entry)
89   (setq entry (copy-list entry))
90   (do ((l *entries* (cdr l))) (nil)
91     (when (null (cdr l))
92       (setf (cdr l) (list entry))
93       (return nil))
94     (when (equal (name (cadr l))
95                  (name entry))
96       (setf (cadr l) entry)
97       (report-error nil
98         "Redefining test ~:@(~S~)"
99         (name entry))
100       (return nil)))
101   (when *do-tests-when-defined*
102     (do-entry entry))
103   (setq *test* (name entry)))
104
105 (defun report-error (error? &rest args)
106   (cond (*debug*
107          (apply #'format t args)
108          (if error? (throw '*debug* nil)))
109         (error? (apply #'error args))
110         (t (apply #'warn args))))
111
112 (defun do-test (&optional (name *test*))
113   (do-entry (get-entry name)))
114
115 (defun equalp-with-case (x y)
116   "Like EQUALP, but doesn't do case conversion of characters."
117   (cond
118    ((eq x y) t)
119    ((consp x)
120     (and (consp y)
121          (equalp-with-case (car x) (car y))
122          (equalp-with-case (cdr x) (cdr y))))
123    ((and (typep x 'array)
124          (= (array-rank x) 0))
125     (equalp-with-case (aref x) (aref y)))
126    ((typep x 'vector)
127     (and (typep y 'vector)
128          (let ((x-len (length x))
129                (y-len (length y)))
130            (and (eql x-len y-len)
131                 (loop
132                  for e1 across x
133                  for e2 across y
134                  always (equalp-with-case e1 e2))))))
135    ((and (typep x 'array)
136          (typep y 'array)
137          (not (equal (array-dimensions x)
138                      (array-dimensions y))))
139     nil)
140    ((typep x 'array)
141     (and (typep y 'array)
142          (let ((size (array-total-size x)))
143            (loop for i from 0 below size
144                  always (equalp-with-case (row-major-aref x i)
145                                           (row-major-aref y i))))))
146    (t (eql x y))))
147
148 (defun do-entry (entry &optional
149                        (s *standard-output*))
150   (catch '*in-test*
151     (setq *test* (name entry))
152     (setf (pend entry) t)
153     (let* ((*in-test* t)
154            ;; (*break-on-warnings* t)
155            (aborted nil)
156            r)
157       ;; (declare (special *break-on-warnings*))
158
159       (block aborted
160         (setf r
161               (flet ((%do
162                       ()
163                       (if *compile-tests*
164                           (multiple-value-list
165                            (funcall (compile
166                                      nil
167                                      `(lambda ()
168                                         (declare
169                                          (optimize ,@*optimization-settings*))
170                                         ,(form entry)))))
171                         (multiple-value-list
172                          (eval (form entry))))))
173                 (if *catch-errors*
174                     (handler-bind
175                         ((style-warning #'muffle-warning)
176                          (error #'(lambda (c)
177                                     (setf aborted t)
178                                     (setf r (list c))
179                                     (return-from aborted nil))))
180                       (%do))
181                   (%do)))))
182
183       (setf (pend entry)
184             (or aborted
185                 (not (equalp-with-case r (vals entry)))))
186
187       (when (pend entry)
188         (let ((*print-circle* *print-circle-on-failure*))
189           (format s "~&Test ~:@(~S~) failed~
190                    ~%Form: ~S~
191                    ~%Expected value~P: ~
192                       ~{~S~^~%~17t~}~%"
193                   *test* (form entry)
194                   (length (vals entry))
195                   (vals entry))
196           (format s "Actual value~P: ~
197                       ~{~S~^~%~15t~}.~%"
198                   (length r) r)))))
199   (when (not (pend entry)) *test*))
200
201 (defun continue-testing ()
202   (if *in-test*
203       (throw '*in-test* nil)
204       (do-entries *standard-output*)))
205
206 (defun do-tests (&optional
207                  (out *standard-output*))
208   (dolist (entry (cdr *entries*))
209     (setf (pend entry) t))
210   (if (streamp out)
211       (do-entries out)
212       (with-open-file
213           (stream out :direction :output)
214         (do-entries stream))))
215
216 (defun do-entries (s)
217   (format s "~&Doing ~A pending test~:P ~
218              of ~A tests total.~%"
219           (count t (cdr *entries*)
220                  :key #'pend)
221           (length (cdr *entries*)))
222   (dolist (entry (cdr *entries*))
223     (when (pend entry)
224       (format s "~@[~<~%~:; ~:@(~S~)~>~]"
225               (do-entry entry s))))
226   (let ((pending (pending-tests))
227         (expected-table (make-hash-table :test #'equal)))
228     (dolist (ex *expected-failures*)
229       (setf (gethash ex expected-table) t))
230     (let ((new-failures
231            (loop for pend in pending
232                  unless (gethash pend expected-table)
233                  collect pend)))
234       (if (null pending)
235           (format s "~&No tests failed.")
236         (progn
237           (format s "~&~A out of ~A ~
238                    total tests failed: ~
239                    ~:@(~{~<~%   ~1:;~S~>~
240                          ~^, ~}~)."
241                   (length pending)
242                   (length (cdr *entries*))
243                   pending)
244           (if (null new-failures)
245               (format s "~&No unexpected failures.")
246             (when *expected-failures*
247               (format s "~&~A unexpected failures: ~
248                    ~:@(~{~<~%   ~1:;~S~>~
249                          ~^, ~}~)."
250                     (length new-failures)
251                     new-failures)))
252           ))
253       (finish-output s)
254       (null pending))))