contrib/sb-aclrepl/rt.lisp

   1 ;-*- Mode:     Lisp -*-
   2 ;;;; Paul Dietz's version of rt from ansi-tests
   3
   4 (defpackage :regression-test
   5   (:use #:cl)
   6   (:nicknames :rtest #-lispworks :rt)
   7   (:export
   8    #:*do-tests-when-defined*
   9    #:*test*
  10    #:continue-testing
  11    #:deftest
  12    #:do-test
  13    #:do-tests
  14    #:get-test
  15    #:pending-tests
  16    #:rem-all-tests
  17    #:rem-test
  18    ))
  19
  20 (in-package :regression-test)
  21 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
  22
  23 #|----------------------------------------------------------------------------|
  24  | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
  25  |                                                                            |
  26  | Permission  to  use,  copy, modify, and distribute this software  and  its |
  27  | documentation for any purpose  and without fee is hereby granted, provided |
  28  | that this copyright  and  permission  notice  appear  in  all  copies  and |
  29  | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
  30  | advertising or  publicity  pertaining  to  distribution  of  the  software |
  31  | without   specific,   written   prior   permission.      M.I.T.  makes  no |
  32  | representations  about  the  suitability of this software for any purpose. |
  33  | It is provided "as is" without express or implied warranty.                |
  34  |                                                                            |
  35  |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
  36  |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
  37  |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
  38  |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
  39  |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
  40  |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
  41  |  SOFTWARE.                                                                 |
  42  |----------------------------------------------------------------------------|#
  43
  44 ;This is the December 19, 1990 version of the regression tester.
  45
  46 (in-package :regression-test)
  47
  48 (defvar *test* nil "Current test name")
  49 (defvar *do-tests-when-defined* nil)
  50 (defvar *entries* '(nil) "Test database")
  51 (defvar *in-test* nil "Used by TEST")
  52 (defvar *debug* nil "For debugging")
  53 (defvar *catch-errors* t "When true, causes errors in a test to be caught.")
  54 (defvar *print-circle-on-failure* nil
  55   "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
  56
  57 (defvar *compile-tests* nil "When true, compile the tests before running
  58 them.")
  59 (defvar *optimization-settings* '((safety 3)))
  60
  61 (defvar *expected-failures* nil
  62   "A list of test names that are expected to fail.")
  63
  64 (defstruct (entry (:conc-name nil)
  65                   (:type list))
  66   pend name form)
  67
  68 (defmacro vals (entry) `(cdddr ,entry))
  69
  70 (defmacro defn (entry) `(cdr ,entry))
  71
  72 (defun pending-tests ()
  73   (do ((l (cdr *entries*) (cdr l))
  74        (r nil))
  75       ((null l) (nreverse r))
  76     (when (pend (car l))
  77       (push (name (car l)) r))))
  78
  79 (defun rem-all-tests ()
  80   (setq *entries* (list nil))
  81   nil)
  82
  83 (defun rem-test (&optional (name *test*))
  84   (do ((l *entries* (cdr l)))
  85       ((null (cdr l)) nil)
  86     (when (equal (name (cadr l)) name)
  87       (setf (cdr l) (cddr l))
  88       (return name))))
  89
  90 (defun get-test (&optional (name *test*))
  91   (defn (get-entry name)))
  92
  93 (defun get-entry (name)
  94   (let ((entry (find name (cdr *entries*)
  95                      :key #'name
  96                      :test #'equal)))
  97     (when (null entry)
  98       (report-error t
  99         "~%No test with name ~:@(~S~)."
 100         name))
 101     entry))
 102
 103 (defmacro deftest (name form &rest values)
 104   `(add-entry '(t ,name ,form .,values)))
 105
 106 (defun add-entry (entry)
 107   (setq entry (copy-list entry))
 108   (do ((l *entries* (cdr l))) (nil)
 109     (when (null (cdr l))
 110       (setf (cdr l) (list entry))
 111       (return nil))
 112     (when (equal (name (cadr l))
 113                  (name entry))
 114       (setf (cadr l) entry)
 115       (report-error nil
 116         "Redefining test ~:@(~S~)"
 117         (name entry))
 118       (return nil)))
 119   (when *do-tests-when-defined*
 120     (do-entry entry))
 121   (setq *test* (name entry)))
 122
 123 (defun report-error (error? &rest args)
 124   (cond (*debug*
 125          (apply #'format t args)
 126          (if error? (throw '*debug* nil)))
 127         (error? (apply #'error args))
 128         (t (apply #'warn args))))
 129
 130 (defun do-test (&optional (name *test*))
 131   (do-entry (get-entry name)))
 132
 133 (defun equalp-with-case (x y)
 134   "Like EQUALP, but doesn't do case conversion of characters.
 135    Currently doesn't work on arrays of dimension > 2."
 136   (cond
 137    ((eq x y) t)
 138    ((consp x)
 139     (and (consp y)
 140          (equalp-with-case (car x) (car y))
 141          (equalp-with-case (cdr x) (cdr y))))
 142    ((and (typep x 'array)
 143          (= (array-rank x) 0))
 144     (equalp-with-case (aref x) (aref y)))
 145    ((typep x 'vector)
 146     (and (typep y 'vector)
 147          (let ((x-len (length x))
 148                (y-len (length y)))
 149            (and (eql x-len y-len)
 150                 (loop
 151                  for e1 across x
 152                  for e2 across y
 153                  always (equalp-with-case e1 e2))))))
 154    ((and (typep x 'array)
 155          (typep y 'array)
 156          (not (equal (array-dimensions x)
 157                      (array-dimensions y))))
 158     nil)
 159    #|
 160    ((and (typep x 'array)
 161          (= (array-rank x) 2))
 162     (let ((dim (array-dimensions x)))
 163       (loop for i from 0 below (first dim)
 164             always (loop for j from 0 below (second dim)
 165                          always (equalp-with-case (aref x i j)
 166                                                   (aref y i j))))))
 167    |#
 168
 169    ((typep x 'array)
 170     (and (typep y 'array)
 171          (let ((size (array-total-size x)))
 172            (loop for i from 0 below size
 173                  always (equalp-with-case (row-major-aref x i)
 174                                           (row-major-aref y i))))))
 175
 176    (t (eql x y))))
 177
 178 (defun do-entry (entry &optional
 179                        (s *standard-output*))
 180   (catch '*in-test*
 181     (setq *test* (name entry))
 182     (setf (pend entry) t)
 183     (let* ((*in-test* t)
 184            ;; (*break-on-warnings* t)
 185            (aborted nil)
 186            r)
 187       ;; (declare (special *break-on-warnings*))
 188
 189       (block aborted
 190         (setf r
 191               (flet ((%do
 192                       ()
 193                       (if *compile-tests*
 194                           (multiple-value-list
 195                            (funcall (compile
 196                                      nil
 197                                      `(lambda ()
 198                                         (declare
 199                                          (optimize ,@*optimization-settings*))
 200                                         ,(form entry)))))
 201                         (multiple-value-list
 202                          (eval (form entry))))))
 203                 (if *catch-errors*
 204                     (handler-bind
 205                      (#-ecl (style-warning #'muffle-warning)
 206                             (error #'(lambda (c)
 207                                        (setf aborted t)
 208                                        (setf r (list c))
 209                                        (return-from aborted nil))))
 210                      (%do))
 211                   (%do)))))
 212
 213       (setf (pend entry)
 214             (or aborted
 215                 (not (equalp-with-case r (vals entry)))))
 216
 217       (when (pend entry)
 218         (let ((*print-circle* *print-circle-on-failure*))
 219           (format s "~&Test ~:@(~S~) failed~
 220                    ~%Form: ~S~
 221                    ~%Expected value~P: ~
 222                       ~{~S~^~%~17t~}~%"
 223                   *test* (form entry)
 224                   (length (vals entry))
 225                   (vals entry))
 226           (format s "Actual value~P: ~
 227                       ~{~S~^~%~15t~}.~%"
 228                   (length r) r)))))
 229   (when (not (pend entry)) *test*))
 230
 231 (defun continue-testing ()
 232   (if *in-test*
 233       (throw '*in-test* nil)
 234       (do-entries *standard-output*)))
 235
 236 (defun do-tests (&optional
 237                  (out *standard-output*))
 238   (dolist (entry (cdr *entries*))
 239     (setf (pend entry) t))
 240   (if (streamp out)
 241       (do-entries out)
 242       (with-open-file
 243           (stream out :direction :output)
 244         (do-entries stream))))
 245
 246 (defun do-entries (s)
 247   (format s "~&Doing ~A pending test~:P ~
 248              of ~A tests total.~%"
 249           (count t (cdr *entries*)
 250                  :key #'pend)
 251           (length (cdr *entries*)))
 252   (dolist (entry (cdr *entries*))
 253     (when (pend entry)
 254       (format s "~@[~<~%~:; ~:@(~S~)~>~]"
 255               (do-entry entry s))))
 256   (let ((pending (pending-tests))
 257         (expected-table (make-hash-table :test #'equal)))
 258     (dolist (ex *expected-failures*)
 259       (setf (gethash ex expected-table) t))
 260     (let ((new-failures
 261            (loop for pend in pending
 262                  unless (gethash pend expected-table)
 263                  collect pend)))
 264       (if (null pending)
 265           (format s "~&No tests failed.")
 266         (progn
 267           (format s "~&~A out of ~A ~
 268                    total tests failed: ~
 269                    ~:@(~{~<~%   ~1:;~S~>~
 270                          ~^, ~}~)."
 271                   (length pending)
 272                   (length (cdr *entries*))
 273                   pending)
 274           (if (null new-failures)
 275               (format s "~&No unexpected failures.")
 276             (when *expected-failures*
 277               (format s "~&~A unexpected failures: ~
 278                    ~:@(~{~<~%   ~1:;~S~>~
 279                          ~^, ~}~)."
 280                     (length new-failures)
 281                     new-failures)))
 282           ))
 283       (null pending))))