rt.lisp 8.79 KB
Newer Older
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
#|----------------------------------------------------------------------------|
 | 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.                                                                 |
 |----------------------------------------------------------------------------|#

;; (defpackage :rt
;;   (:use #:cl)
;;   (:export #:*do-tests-when-defined* #:*test* #:continue-testing
;;            #:deftest #:do-test #:do-tests #:get-test #:pending-tests
;;            #:rem-all-tests #:rem-test)
;;   (:documentation "The MIT regression tester"))

;; (in-package :rt)

(in-package :named-readtables-test)

(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(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.")
(defvar *print-circle-on-failure* nil
  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil
  "When true, compile the tests before running them.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
  "A list of test names that are expected to fail.")

(defstruct (entry (:conc-name nil)
                  (:type list))
  pend name form)

(defmacro vals (entry) `(cdddr ,entry))

(defmacro defn (entry) `(cdr ,entry))

(defun pending-tests ()
  (do ((l (cdr *entries*) (cdr l))
       (r nil))
      ((null l) (nreverse r))
    (when (pend (car l))
      (push (name (car l)) r))))

(defun rem-all-tests ()
  (setq *entries* (list nil))
  nil)

(defun rem-test (&optional (name *test*))
  (do ((l *entries* (cdr l)))
      ((null (cdr l)) nil)
    (when (equal (name (cadr l)) name)
      (setf (cdr l) (cddr l))
      (return name))))

(defun get-test (&optional (name *test*))
  (defn (get-entry name)))

(defun get-entry (name)
  (let ((entry (find name (cdr *entries*)
                     :key #'name
                     :test #'equal)))
    (when (null entry)
      (report-error t
        "~%No test with name ~:@(~S~)."
        name))
    entry))

(defmacro deftest (name form &rest values)
  `(add-entry '(t ,name ,form .,values)))

(defun add-entry (entry)
  (setq entry (copy-list entry))
  (do ((l *entries* (cdr l))) (nil)
    (when (null (cdr l))
      (setf (cdr l) (list entry))
      (return nil))
    (when (equal (name (cadr l))
                 (name entry))
      (setf (cadr l) entry)
      (report-error nil
        "Redefining test ~:@(~S~)"
        (name entry))
      (return nil)))
  (when *do-tests-when-defined*
    (do-entry entry))
  (setq *test* (name entry)))

(defun report-error (error? &rest args)
  (cond (*debug*
         (apply #'format t args)
         (if error? (throw '*debug* nil)))
        (error? (apply #'error args))
        (t (apply #'warn args))))

(defun do-test (&optional (name *test*))
  (do-entry (get-entry name)))

(defun equalp-with-case (x y)
  "Like EQUALP, but doesn't do case conversion of characters."
  (cond
   ((eq x y) t)
   ((consp x)
    (and (consp y)
         (equalp-with-case (car x) (car y))
         (equalp-with-case (cdr x) (cdr y))))
   ((and (typep x 'array)
         (= (array-rank x) 0))
    (equalp-with-case (aref x) (aref y)))
   ((typep x 'vector)
    (and (typep y 'vector)
         (let ((x-len (length x))
               (y-len (length y)))
           (and (eql x-len y-len)
                (loop
                 for e1 across x
                 for e2 across y
                 always (equalp-with-case e1 e2))))))
   ((and (typep x 'array)
         (typep y 'array)
         (not (equal (array-dimensions x)
                     (array-dimensions y))))
    nil)
   ((typep x 'array)
    (and (typep y 'array)
         (let ((size (array-total-size x)))
           (loop for i from 0 below size
                 always (equalp-with-case (row-major-aref x i)
                                          (row-major-aref y i))))))
   (t (eql x y))))

(defun do-entry (entry &optional
                       (s *standard-output*))
  (catch '*in-test*
    (setq *test* (name entry))
    (setf (pend entry) t)
    (let* ((*in-test* t)
           ;; (*break-on-warnings* t)
           (aborted nil)
           r)
      ;; (declare (special *break-on-warnings*))

      (block aborted
        (setf r
              (flet ((%do
                      ()
                      (if *compile-tests*
                          (multiple-value-list
                           (funcall (compile
                                     nil
                                     `(lambda ()
                                        (declare
                                         (optimize ,@*optimization-settings*))
                                        ,(form entry)))))
                        (multiple-value-list
                         (eval (form entry))))))
                (if *catch-errors*
                    (handler-bind
                        ((style-warning #'muffle-warning)
                         (error #'(lambda (c)
                                    (setf aborted t)
                                    (setf r (list c))
                                    (return-from aborted nil))))
                      (%do))
                  (%do)))))

      (setf (pend entry)
            (or aborted
                (not (equalp-with-case r (vals entry)))))

      (when (pend entry)
        (let ((*print-circle* *print-circle-on-failure*))
          (format s "~&Test ~:@(~S~) failed~
                   ~%Form: ~S~
                   ~%Expected value~P: ~
                      ~{~S~^~%~17t~}~%"
                  *test* (form entry)
                  (length (vals entry))
                  (vals entry))
          (format s "Actual value~P: ~
                      ~{~S~^~%~15t~}.~%"
                  (length r) r)))))
  (when (not (pend entry)) *test*))

(defun continue-testing ()
  (if *in-test*
      (throw '*in-test* nil)
      (do-entries *standard-output*)))

(defun do-tests (&optional
                 (out *standard-output*))
  (dolist (entry (cdr *entries*))
    (setf (pend entry) t))
  (if (streamp out)
      (do-entries out)
      (with-open-file
          (stream out :direction :output)
        (do-entries stream))))

(defun do-entries (s)
  (format s "~&Doing ~A pending test~:P ~
             of ~A tests total.~%"
          (count t (cdr *entries*)
                 :key #'pend)
          (length (cdr *entries*)))
  (dolist (entry (cdr *entries*))
    (when (pend entry)
      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
              (do-entry entry s))))
  (let ((pending (pending-tests))
        (expected-table (make-hash-table :test #'equal)))
    (dolist (ex *expected-failures*)
      (setf (gethash ex expected-table) t))
    (let ((new-failures
           (loop for pend in pending
                 unless (gethash pend expected-table)
                 collect pend)))
      (if (null pending)
          (format s "~&No tests failed.")
        (progn
          (format s "~&~A out of ~A ~
                   total tests failed: ~
                   ~:@(~{~<~%   ~1:;~S~>~
                         ~^, ~}~)."
                  (length pending)
                  (length (cdr *entries*))
                  pending)
          (if (null new-failures)
              (format s "~&No unexpected failures.")
            (when *expected-failures*
              (format s "~&~A unexpected failures: ~
                   ~:@(~{~<~%   ~1:;~S~>~
                         ~^, ~}~)."
                    (length new-failures)
                    new-failures)))
          ))
      (finish-output s)
      (null pending))))