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))))))