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