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 Also does not descend into structures, which EQUALP does."
 118   (cond
 119    ((eq x y) t)
 120    ((consp x)
 121     (and (consp y)
 122          (equalp-with-case (car x) (car y))
 123          (equalp-with-case (cdr x) (cdr y))))
 124    ((and (typep x 'array)
 125          (= (array-rank x) 0))
 126     (equalp-with-case (aref x) (aref y)))
 127    ((typep x 'vector)
 128     (and (typep y 'vector)
 129          (let ((x-len (length x))
 130                (y-len (length y)))
 131            (and (eql x-len y-len)
 132                 (loop
 133                  for e1 across x
 134                  for e2 across y
 135                  always (equalp-with-case e1 e2))))))
 136    ((and (typep x 'array)
 137          (typep y 'array)
 138          (not (equal (array-dimensions x)
 139                      (array-dimensions y))))
 140     nil)
 141    ((typep x 'array)
 142     (and (typep y 'array)
 143          (let ((size (array-total-size x)))
 144            (loop for i from 0 below size
 145                  always (equalp-with-case (row-major-aref x i)
 146                                           (row-major-aref y i))))))
 147    (t (eql x y))))
 148
 149 (defun do-entry (entry &optional
 150                        (s *standard-output*))
 151   (catch '*in-test*
 152     (setq *test* (name entry))
 153     (setf (pend entry) t)
 154     (let* ((*in-test* t)
 155            ;; (*break-on-warnings* t)
 156            (aborted nil)
 157            r)
 158       ;; (declare (special *break-on-warnings*))
 159
 160       (block aborted
 161         (setf r
 162               (flet ((%do
 163                       ()
 164                       (if *compile-tests*
 165                           (multiple-value-list
 166                            (funcall (compile
 167                                      nil
 168                                      `(lambda ()
 169                                         (declare
 170                                          (optimize ,@*optimization-settings*))
 171                                         ,(form entry)))))
 172                         (multiple-value-list
 173                          (eval (form entry))))))
 174                 (if *catch-errors*
 175                     (handler-bind
 176                         ((style-warning #'muffle-warning)
 177                          (error #'(lambda (c)
 178                                     (setf aborted t)
 179                                     (setf r (list c))
 180                                     (return-from aborted nil))))
 181                       (%do))
 182                   (%do)))))
 183
 184       (setf (pend entry)
 185             (or aborted
 186                 (not (equalp-with-case r (vals entry)))))
 187
 188       (when (pend entry)
 189         (let ((*print-circle* *print-circle-on-failure*))
 190           (format s "~&Test ~:@(~S~) failed~
 191                    ~%Form: ~S~
 192                    ~%Expected value~P: ~
 193                       ~{~S~^~%~17t~}~%"
 194                   *test* (form entry)
 195                   (length (vals entry))
 196                   (vals entry))
 197           (format s "Actual value~P: ~
 198                       ~{~S~^~%~15t~}.~%"
 199                   (length r) r)))))
 200   (when (not (pend entry)) *test*))
 201
 202 (defun continue-testing ()
 203   (if *in-test*
 204       (throw '*in-test* nil)
 205       (do-entries *standard-output*)))
 206
 207 (defun do-tests (&optional
 208                  (out *standard-output*))
 209   (dolist (entry (cdr *entries*))
 210     (setf (pend entry) t))
 211   (if (streamp out)
 212       (do-entries out)
 213       (with-open-file
 214           (stream out :direction :output)
 215         (do-entries stream))))
 216
 217 (defun do-entries (s)
 218   (format s "~&Doing ~A pending test~:P ~
 219              of ~A tests total.~%"
 220           (count t (cdr *entries*)
 221                  :key #'pend)
 222           (length (cdr *entries*)))
 223   (dolist (entry (cdr *entries*))
 224     (when (pend entry)
 225       (format s "~@[~<~%~:; ~:@(~S~)~>~]"
 226               (do-entry entry s))))
 227   (let ((pending (pending-tests))
 228         (expected-table (make-hash-table :test #'equal)))
 229     (dolist (ex *expected-failures*)
 230       (setf (gethash ex expected-table) t))
 231     (let ((new-failures
 232            (loop for pend in pending
 233                  unless (gethash pend expected-table)
 234                  collect pend)))
 235       (if (null pending)
 236           (format s "~&No tests failed.")
 237         (progn
 238           (format s "~&~A out of ~A ~
 239                    total tests failed: ~
 240                    ~:@(~{~<~%   ~1:;~S~>~
 241                          ~^, ~}~)."
 242                   (length pending)
 243                   (length (cdr *entries*))
 244                   pending)
 245           (if (null new-failures)
 246               (format s "~&No unexpected failures.")
 247             (when *expected-failures*
 248               (format s "~&~A unexpected failures: ~
 249                    ~:@(~{~<~%   ~1:;~S~>~
 250                          ~^, ~}~)."
 251                     (length new-failures)
 252                     new-failures)))))
 253       (finish-output s)
 254       (values (null new-failures) (null pending) pending))))