rt-test.lisp

   1 ;-*-syntax:COMMON-LISP-*-
   2
   3 #|----------------------------------------------------------------------------|
   4  | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
   5  |                                                                            |
   6  | Permission  to  use,  copy, modify, and distribute this software  and  its |
   7  | documentation for any purpose  and without fee is hereby granted, provided |
   8  | that this copyright  and  permission  notice  appear  in  all  copies  and |
   9  | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
  10  | advertising or  publicity  pertaining  to  distribution  of  the  software |
  11  | without   specific,   written   prior   permission.    M.I.T.   makes   no |
  12  | representations  about  the  suitability of this software for any purpose. |
  13  | It is provided "as is" without express or implied warranty.                |
  14  |                                                                            |
  15  |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
  16  |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
  17  |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
  18  |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
  19  |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
  20  |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
  21  |  SOFTWARE.                                                                 |
  22  |----------------------------------------------------------------------------|#
  23
  24 ;This is the December 19, 1990 version of a set of tests that use the
  25 ;RT regression tester to test itself.  See the documentation of RT for
  26 ;a discusion of how to use this file.
  27
  28 (in-package :cl-user)
  29 (require :rt)
  30 (use-package :rt)
  31
  32 (defmacro setup (&rest body)
  33   `(do-setup '(progn ., body)))
  34
  35 (defun do-setup (form)
  36   (let ((*test* nil)
  37         (*do-tests-when-defined* nil)
  38         (rt::*entries* (list nil))
  39         (rt::*in-test* nil)
  40         (rt::*debug* t)
  41         result)
  42     (deftest t1 4 4)
  43     (deftest (t 2) 4 3)
  44     (values-list
  45       (cons (normalize
  46               (with-output-to-string (*standard-output*)
  47                 (setq result
  48                       (multiple-value-list
  49                         (catch 'rt::*debug* (eval form))))))
  50             result))))
  51
  52 (defun normalize (string)
  53   (with-input-from-string (s string)
  54     (normalize-stream s)))
  55 \f
  56 (defvar *file-name* nil)
  57
  58 (defun get-file-name ()
  59   (loop (if *file-name* (return *file-name*))
  60         (format *error-output*
  61                 "~%Type a string representing naming of a scratch disk file: ")
  62         (setq *file-name* (read))
  63         (if (not (stringp *file-name*)) (setq *file-name* nil))))
  64
  65 (get-file-name)
  66
  67 (defmacro with-temporary-file (f &body forms)
  68   `(let ((,f *file-name*))
  69      ,@ forms
  70      (get-file-output ,f)))
  71
  72 (defun get-file-output (f)
  73   (prog1 (with-open-file (in f)
  74            (normalize-stream in))
  75          (delete-file f)))
  76
  77 (defun normalize-stream (s)
  78   (let ((l nil))
  79     (loop (push (read-line s nil s) l)
  80           (when (eq (car l) s)
  81             (setq l (nreverse (cdr l)))
  82             (return nil)))
  83     (delete "" l :test #'equal)))
  84
  85 (rem-all-tests)
  86
  87 (deftest deftest-1
  88   (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests)))
  89   ("Redefining test T1") (t1 3 3) t1 (t1 (t 2)))
  90 (deftest deftest-2
  91   (setup (deftest (t 2) 3 3) (get-test '(t 2)))
  92   ("Redefining test (T 2)") ((t 2) 3 3))
  93 (deftest deftest-3
  94   (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests)))
  95   () (2 3 3) 2 (t1 (t 2) 2))
  96 (deftest deftest-4
  97   (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3)))
  98   ("Test (TEMP) failed"
  99    "Form: 4"
 100    "Expected value: 3"
 101    "Actual value: 4.")
 102   (temp))
 103
 104 (deftest do-test-1
 105   (setup (values (do-test 't1) *test* (pending-tests)))
 106   () t1 t1 ((t 2)))
 107 (deftest do-test-2
 108   (setup (values (do-test '(t 2)) (pending-tests)))
 109   ("Test (T 2) failed"
 110    "Form: 4"
 111    "Expected value: 3"
 112    "Actual value: 4.") nil (t1 (t 2)))
 113 (deftest do-test-3
 114   (setup (let ((*test* 't1)) (do-test)))
 115   () t1)
 116
 117 (deftest get-test-1
 118   (setup (values (get-test 't1) *test*))
 119   () (t1 4 4) (t 2))
 120 (deftest get-test-2
 121   (setup (get-test '(t 2)))
 122   () ((t 2) 4 3))
 123 (deftest get-test-3
 124   (setup (let ((*test* 't1)) (get-test)))
 125   () (t1 4 4))
 126 (deftest get-test-4
 127   (setup (deftest t3 1 1) (get-test))
 128   () (t3 1 1))
 129 (deftest get-test-5
 130   (setup (get-test 't0))
 131   ("No test with name T0.") nil)
 132
 133 (deftest rem-test-1
 134   (setup (values (rem-test 't1) (pending-tests)))
 135   () t1 ((t 2)))
 136 (deftest rem-test-2
 137   (setup (values (rem-test '(t 2)) (pending-tests)))
 138   () (t 2) (t1))
 139 (deftest rem-test-3
 140   (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests))
 141   () (t1))
 142 (deftest rem-test-4
 143   (setup (values (rem-test 't0) (pending-tests)))
 144   () nil (t1 (t 2)))
 145 (deftest rem-test-5
 146   (setup (rem-all-tests) (rem-test 't0) (pending-tests))
 147   () ())
 148
 149 (deftest rem-all-tests-1
 150   (setup (values (rem-all-tests) (pending-tests)))
 151   () nil nil)
 152 (deftest rem-all-tests-2
 153   (setup (rem-all-tests) (rem-all-tests) (pending-tests))
 154   () nil)
 155
 156 (deftest do-tests-1
 157   (setup (let ((*print-case* :downcase))
 158            (values (do-tests) (continue-testing) (do-tests))))
 159   ("Doing 2 pending tests of 2 tests total."
 160    " T1"
 161    "Test (T 2) failed"
 162    "Form: 4"
 163    "Expected value: 3"
 164    "Actual value: 4."
 165    "1 out of 2 total tests failed: (T 2)."
 166    "Doing 1 pending test of 2 tests total."
 167    "Test (T 2) failed"
 168    "Form: 4"
 169    "Expected value: 3"
 170    "Actual value: 4."
 171    "1 out of 2 total tests failed: (T 2)."
 172    "Doing 2 pending tests of 2 tests total."
 173    " T1"
 174    "Test (T 2) failed"
 175    "Form: 4"
 176    "Expected value: 3"
 177    "Actual value: 4."
 178    "1 out of 2 total tests failed: (T 2).")
 179   nil
 180   nil
 181   nil)
 182
 183 (deftest do-tests-2
 184   (setup (rem-test '(t 2))
 185          (deftest (t 2) 3 3)
 186          (values (do-tests) (continue-testing) (do-tests)))
 187   ("Doing 2 pending tests of 2 tests total."
 188    " T1 (T 2)"
 189    "No tests failed."
 190    "Doing 0 pending tests of 2 tests total."
 191    "No tests failed."
 192    "Doing 2 pending tests of 2 tests total."
 193    " T1 (T 2)"
 194    "No tests failed.")
 195   t
 196   t
 197   t)
 198 (deftest do-tests-3
 199   (setup (rem-all-tests) (values (do-tests) (continue-testing)))
 200   ("Doing 0 pending tests of 0 tests total."
 201    "No tests failed."
 202    "Doing 0 pending tests of 0 tests total."
 203    "No tests failed.")
 204   t
 205   t)
 206 (deftest do-tests-4
 207   (setup (normalize (with-output-to-string (s) (do-tests s))))
 208   ()
 209   ("Doing 2 pending tests of 2 tests total."
 210    " T1"
 211    "Test (T 2) failed"
 212    "Form: 4"
 213    "Expected value: 3"
 214    "Actual value: 4."
 215    "1 out of 2 total tests failed: (T 2)."))
 216 (deftest do-tests-5
 217   (setup (with-temporary-file s (do-tests s)))
 218   ()
 219   ("Doing 2 pending tests of 2 tests total."
 220    " T1"
 221    "Test (T 2) failed"
 222    "Form: 4"
 223    "Expected value: 3"
 224    "Actual value: 4."
 225    "1 out of 2 total tests failed: (T 2)."))
 226
 227 (deftest continue-testing-1
 228   (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests))
 229   () (t1 (t 2) temp))