rt.lsp 16.7 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-

#|----------------------------------------------------------------------------|
 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
 |                                                                            |
 | Permission  to  use,  copy, modify, and distribute this software  and  its |
 | documentation for any purpose  and without fee is hereby granted, provided |
 | that this copyright  and  permission  notice  appear  in  all  copies  and |
 | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
 | advertising or  publicity  pertaining  to  distribution  of  the  software |
 | without   specific,   written   prior   permission.      M.I.T.  makes  no |
 | representations  about  the  suitability of this software for any purpose. |
 | It is provided "as is" without express or implied warranty.                |
 |                                                                            |
 |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
 |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
 |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
 |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
 |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
 |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
 |  SOFTWARE.                                                                 |
 |----------------------------------------------------------------------------|#

24
25
;This was the December 19, 1990 version of the regression tester, but
;has since been modified.
26

27
(in-package :regression-test)
28

29
30
31
32
33
(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
(declaim (type list *entries*))
(declaim (ftype (function (t &rest t) t) report-error))
(declaim (ftype (function (t &optional t) t) do-entry))

34
35
(defvar *test* nil "Current test name")
(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
38
39
(defvar *entries-tail* *entries* "Tail of the *entries* list")
(defvar *entries-table* (make-hash-table :test #'equal)
    "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
40
41
42
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
43
44
(defvar *print-circle-on-failure* nil
  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
45

46
47
(defvar *compile-tests* nil "When true, compile the tests before running them.")
(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
48
49
(defvar *optimization-settings* '((safety 3)))

50
51
52
(defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed")
(defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed")

53
54
55
(defvar *expected-failures* nil
  "A list of test names that are expected to fail.")

56
57
(defvar *notes* (make-hash-table :test 'equal)
  "A mapping from names of notes to note objects.")
sds's avatar
sds committed
58

59
60
(defstruct (entry (:conc-name nil))
  pend name props form vals)
61

62
63
64
65
66
67
;;; Note objects are used to attach information to tests.
;;; A typical use is to mark tests that depend on a particular
;;; part of a set of requirements, or a particular interpretation
;;; of the requirements.

(defstruct note
sds's avatar
sds committed
68
  name
69
70
71
72
  contents
  disabled ;; When true, tests with this note are considered inactive
  )

73
;; (defmacro vals (entry) `(cdddr ,entry))
74

75
76
77
78
(defmacro defn (entry)
  (let ((var (gensym)))
    `(let ((,var ,entry))
       (list* (name ,var) (form ,var) (vals ,var)))))
79

80
81
(defun entry-notes (entry)
  (let* ((props (props entry))
sds's avatar
sds committed
82
         (notes (getf props :notes)))
83
    (if (listp notes)
sds's avatar
sds committed
84
        notes
85
86
87
88
89
      (list notes))))

(defun has-disabled-note (entry)
  (let ((notes (entry-notes entry)))
    (loop for n in notes
sds's avatar
sds committed
90
91
92
          for note = (if (note-p n) n
                       (gethash n *notes*))
          thereis (and note (note-disabled note)))))
93

94
95
96
97
98
99
(defun has-note (entry note)
  (unless (note-p note)
    (let ((new-note (gethash note *notes*)))
      (setf note new-note)))
  (and note (not (not (member note (entry-notes entry))))))

100
(defun pending-tests ()
101
  (loop for entry in (cdr *entries*)
sds's avatar
sds committed
102
103
        when (and (pend entry) (not (has-disabled-note entry)))
        collect (name entry)))
104
105
106

(defun rem-all-tests ()
  (setq *entries* (list nil))
107
108
  (setq *entries-tail* *entries*)
  (clrhash *entries-table*)
109
110
111
  nil)

(defun rem-test (&optional (name *test*))
112
113
  (let ((pred (gethash name *entries-table*)))
    (when pred
pfdietz's avatar
pfdietz committed
114
      (if (null (cddr pred))
sds's avatar
sds committed
115
116
          (setq *entries-tail* pred)
        (setf (gethash (name (caddr pred)) *entries-table*) pred))
117
118
119
      (setf (cdr pred) (cddr pred))
      (remhash name *entries-table*)
      name)))
120

121
122
123
124
(defun get-test (&optional (name *test*))
  (defn (get-entry name)))

(defun get-entry (name)
125
  (let ((entry ;; (find name (the list (cdr *entries*))
sds's avatar
sds committed
126
127
128
               ;;     :key #'name :test #'equal)
         (cadr (gethash name *entries-table*))
         ))
129
130
131
    (when (null entry)
      (report-error t
        "~%No test with name ~:@(~S~)."
sds's avatar
sds committed
132
        name))
133
134
    entry))

135
136
(defmacro deftest (name &rest body)
  (let* ((p body)
sds's avatar
sds committed
137
138
139
140
141
142
143
144
         (properties
          (loop while (keywordp (first p))
                unless (cadr p)
                do (error "Poorly formed deftest: ~A~%"
                          (list* 'deftest name body))
                append (list (pop p) (pop p))))
         (form (pop p))
         (vals p))
145
    `(add-entry (make-entry :pend t
sds's avatar
sds committed
146
147
148
149
                            :name ',name
                            :props ',properties
                            :form ',form
                            :vals ',vals))))
150
151

(defun add-entry (entry)
152
  (setq entry (copy-entry entry))
153
154
155
156
  (let* ((pred (gethash (name entry) *entries-table*)))
    (cond
     (pred
      (setf (cadr pred) entry)
157
158
      (report-error nil
        "Redefining test ~:@(~S~)"
159
160
161
162
163
164
        (name entry)))
     (t
      (setf (gethash (name entry) *entries-table*) *entries-tail*)
      (setf (cdr *entries-tail*) (cons entry nil))
      (setf *entries-tail* (cdr *entries-tail*))
      )))
165
166
167
168
169
  (when *do-tests-when-defined*
    (do-entry entry))
  (setq *test* (name entry)))

(defun report-error (error? &rest args)
sds's avatar
sds committed
170
171
172
173
174
  (cond (*debug*
         (apply #'format t args)
         (if error? (throw '*debug* nil)))
        (error? (apply #'error args))
        (t (apply #'warn args)))
175
  nil)
176

177
178
(defun do-test (&optional (name *test*) &rest key-args)
  (flet ((%parse-key-args
sds's avatar
sds committed
179
180
181
182
          (&key
           ((:catch-errors *catch-errors*) *catch-errors*)
           ((:compile *compile-tests*) *compile-tests*))
          (do-entry (get-entry name))))
183
    (apply #'%parse-key-args key-args)))
184

185
186
187
188
189
190
(defun my-aref (a &rest args)
  (apply #'aref a args))

(defun my-row-major-aref (a index)
  (row-major-aref a index))

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
197
   ((consp x)
    (and (consp y)
sds's avatar
sds committed
198
199
         (equalp-with-case (car x) (car y))
         (equalp-with-case (cdr x) (cdr y))))
200
   ((and (typep x 'array)
sds's avatar
sds committed
201
         (= (array-rank x) 0))
202
    (equalp-with-case (my-aref x) (my-aref y)))
203
204
   ((typep x 'vector)
    (and (typep y 'vector)
sds's avatar
sds committed
205
206
207
208
209
210
211
212
         (let ((x-len (length x))
               (y-len (length y)))
           (and (eql x-len y-len)
                (loop
                 for i from 0 below x-len
                 for e1 = (my-aref x i)
                 for e2 = (my-aref y i)
                 always (equalp-with-case e1 e2))))))
213
   ((and (typep x 'array)
sds's avatar
sds committed
214
215
216
         (typep y 'array)
         (not (equal (array-dimensions x)
                     (array-dimensions y))))
217
    nil)
218
219

   ((typep x 'array)
220
    (and (typep y 'array)
sds's avatar
sds committed
221
222
223
224
         (let ((size (array-total-size x)))
           (loop for i from 0 below size
                 always (equalp-with-case (my-row-major-aref x i)
                                          (my-row-major-aref y i))))))
pfdietz's avatar
pfdietz committed
225
226
   ((typep x 'pathname)
    (equal x y))
227
228
   (t (eql x y))))

229
(defun do-entry (entry &optional
sds's avatar
sds committed
230
                       (s *standard-output*))
231
232
233
234
  (catch '*in-test*
    (setq *test* (name entry))
    (setf (pend entry) t)
    (let* ((*in-test* t)
sds's avatar
sds committed
235
236
237
           ;; (*break-on-warnings* t)
           (aborted nil)
           r)
238
239
      ;; (declare (special *break-on-warnings*))

240
      (block aborted
sds's avatar
sds committed
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
        (setf r
              (flet ((%do ()
                          (handler-bind
                           #-sbcl nil
                           #+sbcl ((sb-ext:code-deletion-note #'(lambda (c)
                                                                  (if (has-note entry :do-not-muffle)
                                                                      nil
                                                                    (muffle-warning c)))))
                           (cond
                            (*compile-tests*
                             (multiple-value-list
                              (funcall (compile
                                        nil
                                        `(lambda ()
                                           (declare
                                            (optimize ,@*optimization-settings*))
                                           ,(form entry))))))
                            (*expanded-eval*
                             (multiple-value-list
                              (expanded-eval (form entry))))
                            (t
                             (multiple-value-list
                              (eval (form entry))))))))
                (if *catch-errors*
                    (handler-bind
                     (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings)
                                                             c
                                                           (muffle-warning c))))
                            (error #'(lambda (c)
                                       (setf aborted t)
                                       (setf r (list c))
                                       (return-from aborted nil))))
                     (%do))
                  (%do)))))
275

276
      (setf (pend entry)
sds's avatar
sds committed
277
278
279
            (or aborted
                (not (equalp-with-case r (vals entry)))))

280
      (when (pend entry)
sds's avatar
sds committed
281
        (let ((*print-circle* *print-circle-on-failure*))
sds's avatar
sds committed
282
283
284
          (format s "~&Test ~:@(~S~) failed~%Form: ~S~%Expected value~P:~%"
                  *test* (form entry) (length (vals entry)))
          (dolist (v (vals entry)) (format s "~10t~S~%" v))
sds's avatar
sds committed
285
          (handler-case
sds's avatar
sds committed
286
287
288
289
290
291
              (progn
                (format s "Actual value~P:~%" (length r))
                (dolist (v r)
                  (format s "~10t~S~:[~; [~2:*~A]~]~%"
                          v (typep v 'condition))))
            (error () (format s "Actual value: #<error during printing>~%")))
sds's avatar
sds committed
292
          (finish-output s)))))
293
  (when (not (pend entry)) *test*))
294

295
296
297
298
299
300
301
302
303
(defun expanded-eval (form)
  "Split off top level of a form and eval separately.  This reduces the chance that
   compiler optimizations will fold away runtime computation."
  (if (not (consp form))
      (eval form)
   (let ((op (car form)))
     (cond
      ((eq op 'let)
       (let* ((bindings (loop for b in (cadr form)
sds's avatar
sds committed
304
305
306
307
308
309
310
                              collect (if (consp b) b (list b nil))))
              (vars (mapcar #'car bindings))
              (binding-forms (mapcar #'cadr bindings)))
         (apply
          (the function
            (eval `(lambda ,vars ,@(cddr form))))
          (mapcar #'eval binding-forms))))
311
312
      ((and (eq op 'let*) (cadr form))
       (let* ((bindings (loop for b in (cadr form)
sds's avatar
sds committed
313
314
315
316
317
318
319
                              collect (if (consp b) b (list b nil))))
              (vars (mapcar #'car bindings))
              (binding-forms (mapcar #'cadr bindings)))
         (funcall
          (the function
            (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
          (eval (car binding-forms)))))
320
321
      ((eq op 'progn)
       (loop for e on (cdr form)
sds's avatar
sds committed
322
323
             do (if (null (cdr e)) (return (eval (car e)))
                  (eval (car e)))))
324
      ((and (symbolp op) (fboundp op)
sds's avatar
sds committed
325
326
            (not (macro-function op))
            (not (special-operator-p op)))
327
       (apply (symbol-function op)
sds's avatar
sds committed
328
              (mapcar #'eval (cdr form))))
329
330
      (t (eval form))))))

331
332
333
334
(defun continue-testing ()
  (if *in-test*
      (throw '*in-test* nil)
      (do-entries *standard-output*)))
335

336
(defun do-tests (&key (out *standard-output*)
sds's avatar
sds committed
337
338
                      ((:catch-errors *catch-errors*) *catch-errors*)
                      ((:compile *compile-tests*) *compile-tests*))
339
  (setq *failed-tests* nil
sds's avatar
sds committed
340
        *passed-tests* nil)
341
342
343
344
  (dolist (entry (cdr *entries*))
    (setf (pend entry) t))
  (if (streamp out)
      (do-entries out)
sds's avatar
sds committed
345
346
347
      (with-open-file
          (stream out :direction :output)
        (do-entries stream))))
348

349
(defun do-entries (s)
350
351
  (format s "~&Doing ~A pending test~:P ~
             of ~A tests total.~%"
352
          (count t (the list (cdr *entries*)) :key #'pend)
sds's avatar
sds committed
353
          (length (cdr *entries*)))
354
  (finish-output s)
355
  (dolist (entry (cdr *entries*))
356
    (when (and (pend entry)
sds's avatar
sds committed
357
               (not (has-disabled-note entry)))
358
      (let ((success? (do-entry entry s)))
sds's avatar
sds committed
359
360
361
362
        (if success?
          (push (name entry) *passed-tests*)
          (push (name entry) *failed-tests*))
        (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?))
363
364
      (finish-output s)
      ))
365
  (let ((pending (pending-tests))
sds's avatar
sds committed
366
        (expected-table (make-hash-table :test #'equal)))
367
368
369
    (dolist (ex *expected-failures*)
      (setf (gethash ex expected-table) t))
    (let ((new-failures
sds's avatar
sds committed
370
371
372
           (loop for pend in pending
                 unless (gethash pend expected-table)
                 collect pend)))
373
      (if (null pending)
sds's avatar
sds committed
374
375
376
377
378
379
380
381
382
383
          (format s "~&No tests failed.")
        (progn
          (format t "~&~A out of ~A total tests failed: ~%(~{~a~^~%~})"
                  (length pending)
                  (length (cdr *entries*))
                  pending)
          (if (null new-failures)
              (format s "~&No unexpected failures.")
            (when *expected-failures*
              (format s "~&~A unexpected failures: ~
384
385
                   ~:@(~{~<~%   ~1:;~S~>~
                         ~^, ~}~)."
sds's avatar
sds committed
386
387
                    (length new-failures)
                    new-failures)))
388
389
390
391
392
393
394
395
396
397
398
399
400
401
          (when *expected-failures*
            (let ((pending-table (make-hash-table :test #'equal)))
              (dolist (ex pending)
                (setf (gethash ex pending-table) t))
              (let ((unexpected-successes
                     (loop :for ex :in *expected-failures*
                       :unless (gethash ex pending-table) :collect ex)))
                (if unexpected-successes
                    (format t "~&~:D unexpected successes: ~
                   ~:@(~{~<~%   ~1:;~S~>~
                         ~^, ~}~)."
                            (length unexpected-successes)
                            unexpected-successes)
                    (format t "~&No unexpected successes.")))))
sds's avatar
sds committed
402
          ))
403
      (finish-output s)
404
      (null pending))))
405
406
407

;;; Note handling functions and macros

408
(defmacro defnote (name contents &optional disabled)
409
  `(eval-when (:load-toplevel :execute)
410
     (let ((note (make-note :name ',name
sds's avatar
sds committed
411
412
                            :contents ',contents
                            :disabled ',disabled)))
413
       (setf (gethash (note-name note) *notes*) note)
414
415
       note)))

416
417
(defun disable-note (n)
  (let ((note (if (note-p n) n
sds's avatar
sds committed
418
                (setf n (gethash n *notes*)))))
419
420
421
422
423
424
    (unless note (error "~A is not a note or note name." n))
    (setf (note-disabled note) t)
    note))

(defun enable-note (n)
  (let ((note (if (note-p n) n
sds's avatar
sds committed
425
                (setf n (gethash n *notes*)))))
426
427
428
    (unless note (error "~A is not a note or note name." n))
    (setf (note-disabled note) nil)
    note))
429
430
431
432

;;; Extended random regression

(defun do-extended-tests (&key (tests *passed-tests*) (count nil)
sds's avatar
sds committed
433
434
                               ((:catch-errors *catch-errors*) *catch-errors*)
                               ((:compile *compile-tests*) *compile-tests*))
435
436
437
438
439
440
  "Execute randomly chosen tests from TESTS until one fails or until
   COUNT is an integer and that many tests have been executed."
  (let ((test-vector (coerce tests 'simple-vector)))
    (let ((n (length test-vector)))
      (when (= n 0) (error "Must provide at least one test."))
      (loop for i from 0
sds's avatar
sds committed
441
442
443
444
            for name = (svref test-vector (random n))
            until (eql i count)
            do (print name)
            unless (do-test name) return (values name (1+ i))))))