source: trunk/source/tests/ansi-tests/rt-test.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 7.2 KB
Line 
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(cl:defpackage :rt-tests
29  (:use :cl :regression-test))
30
31(in-package :rt-tests)
32;; (require "RT")
33;;(use-package :regression-test)
34
35(defmacro setup (&rest body)
36  `(do-setup '(progn ., body)))
37
38(defmacro with-blank-tests (&body body)
39  `(let ((regression-test::*entries* (list nil))
40         (regression-test::*entries-table* (make-hash-table :test #'equal))
41         (*test* nil)
42         (regression-test::*in-test* nil))
43    (let ((regression-test::*entries-tail* regression-test::*entries*))
44      ,@body)))
45
46(defun do-setup (form)
47  (with-blank-tests
48      (let ((*do-tests-when-defined* nil)
49            (regression-test::*debug* t)
50            result)
51        (deftest t1 4 4)
52        (deftest (t 2) 4 3)
53        (values-list
54         (cons (normalize
55              (with-output-to-string (*standard-output*)
56                (setq result
57                      (multiple-value-list
58                        (catch 'regression-test::*debug* (eval form))))))
59            result)))))
60
61(defun normalize (string)
62  (with-input-from-string (s string)
63    (normalize-stream s)))
64
65(defvar *file-name* nil)
66
67(defun get-file-name ()
68  (loop (if *file-name* (return *file-name*))
69        (format *error-output*
70                "~%Type a string representing naming of a scratch disk file: ")
71        (setq *file-name* (read))
72        (if (not (stringp *file-name*)) (setq *file-name* nil))))
73
74(get-file-name)
75
76(defmacro with-temporary-file (f &body forms)
77  `(let ((,f *file-name*))
78     ,@ forms
79     (get-file-output ,f)))
80
81(defun get-file-output (f)
82  (prog1 (with-open-file (in f)
83           (normalize-stream in))
84         (delete-file f)))
85
86(defun normalize-stream (s)
87  (let ((l nil))
88    (loop (push (read-line s nil s) l)
89          (when (eq (car l) s)
90            (setq l (nreverse (cdr l)))
91            (return nil)))
92    (delete "" l :test #'equal)))
93
94(rem-all-tests)
95
96(deftest deftest-1
97  (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests)))
98  ("Redefining test RT-TESTS::T1") (t1 3 3) t1 (t1 (t 2)))
99(deftest deftest-2
100  (setup (deftest (t 2) 3 3) (get-test '(t 2)))
101  ("Redefining test (T 2)") ((t 2) 3 3))
102(deftest deftest-3
103  (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests)))
104  () (2 3 3) 2 (t1 (t 2) 2))
105(deftest deftest-4
106  (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3)))
107  ("Test (RT-TESTS::TEMP) failed"
108   "Form: 4"
109   "Expected value: 3"
110   "Actual value: 4.")
111  (temp))
112
113(deftest do-test-1
114  (setup (values (do-test 't1) *test* (pending-tests)))
115  () t1 t1 ((t 2)))
116(deftest do-test-2
117  (setup (values (do-test '(t 2)) (pending-tests)))
118  ("Test (T 2) failed"
119   "Form: 4"
120   "Expected value: 3"
121   "Actual value: 4.") nil (t1 (t 2)))
122(deftest do-test-3
123  (setup (let ((*test* 't1)) (do-test)))
124  () t1)
125
126(deftest get-test-1
127  (setup (values (get-test 't1) *test*))
128  () (t1 4 4) (t 2))
129(deftest get-test-2
130  (setup (get-test '(t 2)))
131  () ((t 2) 4 3))
132(deftest get-test-3
133  (setup (let ((*test* 't1)) (get-test)))
134  () (t1 4 4))
135(deftest get-test-4
136  (setup (deftest t3 1 1) (get-test))
137  () (t3 1 1))
138(deftest get-test-5
139  (setup (get-test 't0))
140  ("No test with name RT-TESTS::T0.") nil)
141
142(deftest rem-test-1
143  (setup (values (rem-test 't1) (pending-tests)))
144  () t1 ((t 2)))
145(deftest rem-test-2
146  (setup (values (rem-test '(t 2)) (pending-tests)))
147  () (t 2) (t1))
148(deftest rem-test-3
149  (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests))
150  () (t1))
151(deftest rem-test-4
152  (setup (values (rem-test 't0) (pending-tests)))
153  () nil (t1 (t 2)))
154(deftest rem-test-5
155  (setup (rem-all-tests) (rem-test 't0) (pending-tests))
156  () ())
157
158(deftest rem-all-tests-1
159  (setup (values (rem-all-tests) (pending-tests)))
160  () nil nil)
161(deftest rem-all-tests-2
162  (setup (rem-all-tests) (rem-all-tests) (pending-tests))
163  () nil)
164
165(deftest do-tests-1
166  (setup (let ((*print-case* :downcase))
167           (values (do-tests) (continue-testing) (do-tests))))
168  ("Doing 2 pending tests of 2 tests total."
169   " RT-TESTS::T1"
170   "Test (T 2) failed"
171   "Form: 4"
172   "Expected value: 3"
173   "Actual value: 4."
174   "1 out of 2 total tests failed: (T 2)."
175   "Doing 1 pending test of 2 tests total."
176   "Test (T 2) failed"
177   "Form: 4"
178   "Expected value: 3"
179   "Actual value: 4."
180   "1 out of 2 total tests failed: (T 2)."
181   "Doing 2 pending tests of 2 tests total."
182   " RT-TESTS::T1"
183   "Test (T 2) failed"
184   "Form: 4"
185   "Expected value: 3"
186   "Actual value: 4."
187   "1 out of 2 total tests failed: (T 2).")
188  nil
189  nil
190  nil)
191
192(deftest do-tests-2
193  (setup (rem-test '(t 2))
194         (deftest (t 2) 3 3)
195         (values (do-tests) (continue-testing) (do-tests)))
196  ("Doing 2 pending tests of 2 tests total."
197   " RT-TESTS::T1 (T 2)"
198   "No tests failed."
199   "Doing 0 pending tests of 2 tests total."
200   "No tests failed."
201   "Doing 2 pending tests of 2 tests total."
202   " RT-TESTS::T1 (T 2)"
203   "No tests failed.")
204  t
205  t
206  t)
207(deftest do-tests-3
208  (setup (rem-all-tests) (values (do-tests) (continue-testing)))
209  ("Doing 0 pending tests of 0 tests total."
210   "No tests failed."
211   "Doing 0 pending tests of 0 tests total."
212   "No tests failed.")
213  t
214  t)
215(deftest do-tests-4
216  (setup (normalize (with-output-to-string (s) (do-tests :out s))))
217  ()
218  ("Doing 2 pending tests of 2 tests total."
219   " RT-TESTS::T1"
220   "Test (T 2) failed"
221   "Form: 4"
222   "Expected value: 3"
223   "Actual value: 4."
224   "1 out of 2 total tests failed: (T 2)."))
225(deftest do-tests-5
226  (setup (with-temporary-file s (do-tests :out s)))
227  ()
228  ("Doing 2 pending tests of 2 tests total."
229   " RT-TESTS::T1"
230   "Test (T 2) failed"
231   "Form: 4"
232   "Expected value: 3"
233   "Actual value: 4."
234   "1 out of 2 total tests failed: (T 2)."))
235
236(deftest continue-testing-1
237  (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests))
238  () (t1 (t 2) temp))
Note: See TracBrowser for help on using the repository browser.