Codebase list cl-rt / 2a5eb83
r9661: update from Paul Dietz's latest ansi-test version Kevin M. Rosenberg 19 years ago
3 changed file(s) with 228 addition(s) and 234 deletion(s). Raw diff Collapse all Expand all
+6
-0
debian/changelog less more
0 cl-rt (20040621-1) unstable; urgency=low
1
2 * New upstream from Paul Dietz's ansi-tests
3
4 -- Kevin M. Rosenberg <kmr@debian.org> Mon, 21 Jun 2004 15:27:33 -0600
5
06 cl-rt (20030428b-1) unstable; urgency=low
17
28 * Fix dos line endings
+0
-167
rt-original.lisp less more
0 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
1
2 #|----------------------------------------------------------------------------|
3 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
4 | |
5 | Permission to use, copy, modify, and distribute this software and its |
6 | documentation for any purpose and without fee is hereby granted, provided |
7 | that this copyright and permission notice appear in all copies and |
8 | supporting documentation, and that the name of M.I.T. not be used in |
9 | advertising or publicity pertaining to distribution of the software |
10 | without specific, written prior permission. M.I.T. makes no |
11 | representations about the suitability of this software for any purpose. |
12 | It is provided "as is" without express or implied warranty. |
13 | |
14 | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
15 | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
16 | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
17 | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
18 | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
19 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
20 | SOFTWARE. |
21 |----------------------------------------------------------------------------|#
22
23 ;This is the December 19, 1990 version of the regression tester.
24
25 (defpackage #:rt
26 (:use #:common-lisp)
27 (:export deftest get-test do-test rem-test
28 rem-all-tests do-tests pending-tests
29 continue-testing *test*
30 *do-tests-when-defined*))
31 (in-package :rt)
32 (defvar *test* nil "Current test name")
33 (defvar *do-tests-when-defined* nil)
34 (defvar *entries* '(nil) "Test database")
35 (defvar *in-test* nil "Used by TEST")
36 (defvar *debug* nil "For debugging")
37
38 (defstruct (entry (:conc-name nil)
39 (:type list))
40 pend name form)
41
42 (defmacro vals (entry) `(cdddr ,entry))
43
44 (defmacro defn (entry) `(cdr ,entry))
45
46 (defun pending-tests ()
47 (do ((l (cdr *entries*) (cdr l))
48 (r nil))
49 ((null l) (nreverse r))
50 (when (pend (car l))
51 (push (name (car l)) r))))
52
53 (defun rem-all-tests ()
54 (setq *entries* (list nil))
55 nil)
56
57 (defun rem-test (&optional (name *test*))
58 (do ((l *entries* (cdr l)))
59 ((null (cdr l)) nil)
60 (when (equal (name (cadr l)) name)
61 (setf (cdr l) (cddr l))
62 (return name))))
63
64 (defun get-test (&optional (name *test*))
65 (defn (get-entry name)))
66
67 (defun get-entry (name)
68 (let ((entry (find name (cdr *entries*)
69 :key #'name
70 :test #'equal)))
71 (when (null entry)
72 (report-error t
73 "~%No test with name ~:@(~S~)."
74 name))
75 entry))
76
77 (defmacro deftest (name form &rest values)
78 `(add-entry '(t ,name ,form .,values)))
79
80 (defun add-entry (entry)
81 (setq entry (copy-list entry))
82 (do ((l *entries* (cdr l))) (nil)
83 (when (null (cdr l))
84 (setf (cdr l) (list entry))
85 (return nil))
86 (when (equal (name (cadr l))
87 (name entry))
88 (setf (cadr l) entry)
89 (report-error nil
90 "Redefining test ~@:(~S~)"
91 (name entry))
92 (return nil)))
93 (when *do-tests-when-defined*
94 (do-entry entry))
95 (setq *test* (name entry)))
96
97 (defun report-error (error? &rest args)
98 (cond (*debug*
99 (apply #'format t args)
100 (if error? (throw '*debug* nil)))
101 (error? (apply #'error args))
102 (t (apply #'warn args))))
103
104 (defun do-test (&optional (name *test*))
105 (do-entry (get-entry name)))
106
107 (defun do-entry (entry &optional
108 (s *standard-output*))
109 (catch '*in-test*
110 (setq *test* (name entry))
111 (setf (pend entry) t)
112 (let* ((*in-test* t)
113 (*break-on-warnings* t)
114 (r (multiple-value-list
115 (eval (form entry)))))
116 (setf (pend entry)
117 (not (equal r (vals entry))))
118 (when (pend entry)
119 (format s "~&Test ~:@(~S~) failed~
120 ~%Form: ~S~
121 ~%Expected value~P: ~
122 ~{~S~^~%~17t~}~
123 ~%Actual value~P: ~
124 ~{~S~^~%~15t~}.~%"
125 *test* (form entry)
126 (length (vals entry))
127 (vals entry)
128 (length r) r))))
129 (when (not (pend entry)) *test*))
130
131 (defun continue-testing ()
132 (if *in-test*
133 (throw '*in-test* nil)
134 (do-entries *standard-output*)))
135
136 (defun do-tests (&optional
137 (out *standard-output*))
138 (dolist (entry (cdr *entries*))
139 (setf (pend entry) t))
140 (if (streamp out)
141 (do-entries out)
142 (with-open-file
143 (stream out :direction :output)
144 (do-entries stream))))
145
146 (defun do-entries (s)
147 (format s "~&Doing ~A pending test~:P ~
148 of ~A tests total.~%"
149 (count t (cdr *entries*)
150 :key #'pend)
151 (length (cdr *entries*)))
152 (dolist (entry (cdr *entries*))
153 (when (pend entry)
154 (format s "~@[~<~%~:; ~:@(~S~)~>~]"
155 (do-entry entry s))))
156 (let ((pending (pending-tests)))
157 (if (null pending)
158 (format s "~&No tests failed.")
159 (format s "~&~A out of ~A ~
160 total tests failed: ~
161 ~:@(~{~<~% ~1:;~S~>~
162 ~^, ~}~)."
163 (length pending)
164 (length (cdr *entries*))
165 pending))
166 (null pending)))
+222
-67
rt.lisp less more
0 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
1
02 #|----------------------------------------------------------------------------|
13 | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
24 | |
2628 #:rem-all-tests #:rem-test)
2729 (:documentation "The MIT regression tester with pfdietz's modifications"))
2830
31 ;;This was the December 19, 1990 version of the regression tester, but
32 ;;has since been modified.
33
2934 (in-package :regression-test)
35
36 (declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
37 (declaim (type list *entries*))
38 (declaim (ftype (function (t &rest t) t) report-error))
39 (declaim (ftype (function (t &optional t) t) do-entry))
3040
3141 (defvar *test* nil "Current test name")
3242 (defvar *do-tests-when-defined* nil)
33 (defvar *entries* '(nil) "Test database")
43 (defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.")
44 (defvar *entries-tail* *entries* "Tail of the *entries* list")
45 (defvar *entries-table* (make-hash-table :test #'equal)
46 "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
3447 (defvar *in-test* nil "Used by TEST")
3548 (defvar *debug* nil "For debugging")
36 (defvar *catch-errors* t
37 "When true, causes errors in a test to be caught.")
49 (defvar *catch-errors* t "When true, causes errors in a test to be caught.")
3850 (defvar *print-circle-on-failure* nil
3951 "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.")
52
53 (defvar *compile-tests* nil "When true, compile the tests before running them.")
54 (defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
4255 (defvar *optimization-settings* '((safety 3)))
56
4357 (defvar *expected-failures* nil
4458 "A list of test names that are expected to fail.")
4559
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))
60 (defvar *notes* (make-hash-table :test 'equal)
61 "A mapping from names of notes to note objects.")
62
63 (defstruct (entry (:conc-name nil))
64 pend name props form vals)
65
66 ;;; Note objects are used to attach information to tests.
67 ;;; A typical use is to mark tests that depend on a particular
68 ;;; part of a set of requirements, or a particular interpretation
69 ;;; of the requirements.
70
71 (defstruct note
72 name
73 contents
74 disabled ;; When true, tests with this note are considered inactive
75 )
76
77 ;; (defmacro vals (entry) `(cdddr ,entry))
78
79 (defmacro defn (entry)
80 (let ((var (gensym)))
81 `(let ((,var ,entry))
82 (list* (name ,var) (form ,var) (vals ,var)))))
83
84 (defun entry-notes (entry)
85 (let* ((props (props entry))
86 (notes (getf props :notes)))
87 (if (listp notes)
88 notes
89 (list notes))))
90
91 (defun has-disabled-note (entry)
92 (let ((notes (entry-notes entry)))
93 (loop for n in notes
94 for note = (if (note-p n) n
95 (gethash n *notes*))
96 thereis (and note (note-disabled note)))))
5397
5498 (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))))
99 (loop for entry in (cdr *entries*)
100 when (and (pend entry) (not (has-disabled-note entry)))
101 collect (name entry)))
60102
61103 (defun rem-all-tests ()
62104 (setq *entries* (list nil))
105 (setq *entries-tail* *entries*)
106 (clrhash *entries-table*)
63107 nil)
64108
65109 (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))))
110 (let ((pred (gethash name *entries-table*)))
111 (when pred
112 (if (null (cddr pred))
113 (setq *entries-tail* pred)
114 (setf (gethash (name (caddr pred)) *entries-table*) pred))
115 (setf (cdr pred) (cddr pred))
116 (remhash name *entries-table*)
117 name)))
71118
72119 (defun get-test (&optional (name *test*))
73120 (defn (get-entry name)))
74121
75122 (defun get-entry (name)
76 (let ((entry (find name (cdr *entries*)
77 :key #'name
78 :test #'equal)))
123 (let ((entry ;; (find name (the list (cdr *entries*))
124 ;; :key #'name :test #'equal)
125 (cadr (gethash name *entries-table*))
126 ))
79127 (when (null entry)
80128 (report-error t
81129 "~%No test with name ~:@(~S~)."
82130 name))
83131 entry))
84132
85 (defmacro deftest (name form &rest values)
86 `(add-entry '(t ,name ,form .,values)))
133 (defmacro deftest (name &rest body)
134 (let* ((p body)
135 (properties
136 (loop while (keywordp (first p))
137 unless (cadr p)
138 do (error "Poorly formed deftest: ~A~%"
139 (list* 'deftest name body))
140 append (list (pop p) (pop p))))
141 (form (pop p))
142 (vals p))
143 `(add-entry (make-entry :pend t
144 :name ',name
145 :props ',properties
146 :form ',form
147 :vals ',vals))))
87148
88149 (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)
150 (setq entry (copy-entry entry))
151 (let* ((pred (gethash (name entry) *entries-table*)))
152 (cond
153 (pred
154 (setf (cadr pred) entry)
97155 (report-error nil
98156 "Redefining test ~:@(~S~)"
99 (name entry))
100 (return nil)))
157 (name entry)))
158 (t
159 (setf (gethash (name entry) *entries-table*) *entries-tail*)
160 (setf (cdr *entries-tail*) (cons entry nil))
161 (setf *entries-tail* (cdr *entries-tail*))
162 )))
101163 (when *do-tests-when-defined*
102164 (do-entry entry))
103165 (setq *test* (name entry)))
107169 (apply #'format t args)
108170 (if error? (throw '*debug* nil)))
109171 (error? (apply #'error args))
110 (t (apply #'warn args))))
172 (t (apply #'warn args)))
173 nil)
111174
112175 (defun do-test (&optional (name *test*))
113 (do-entry (get-entry name)))
176 #-sbcl (do-entry (get-entry name))
177 #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
178 (do-entry (get-entry name))))
179
180 (defun my-aref (a &rest args)
181 (apply #'aref a args))
182
183 (defun my-row-major-aref (a index)
184 (row-major-aref a index))
114185
115186 (defun equalp-with-case (x y)
116 "Like EQUALP, but doesn't do case conversion of characters."
187 "Like EQUALP, but doesn't do case conversion of characters.
188 Currently doesn't work on arrays of dimension > 2."
117189 (cond
118190 ((eq x y) t)
119191 ((consp x)
122194 (equalp-with-case (cdr x) (cdr y))))
123195 ((and (typep x 'array)
124196 (= (array-rank x) 0))
125 (equalp-with-case (aref x) (aref y)))
197 (equalp-with-case (my-aref x) (my-aref y)))
126198 ((typep x 'vector)
127199 (and (typep y 'vector)
128200 (let ((x-len (length x))
129201 (y-len (length y)))
130202 (and (eql x-len y-len)
131203 (loop
132 for e1 across x
133 for e2 across y
204 for i from 0 below x-len
205 for e1 = (my-aref x i)
206 for e2 = (my-aref y i)
134207 always (equalp-with-case e1 e2))))))
135208 ((and (typep x 'array)
136209 (typep y 'array)
137210 (not (equal (array-dimensions x)
138211 (array-dimensions y))))
139212 nil)
213
140214 ((typep x 'array)
141215 (and (typep y 'array)
142216 (let ((size (array-total-size x)))
143217 (loop for i from 0 below size
144 always (equalp-with-case (row-major-aref x i)
145 (row-major-aref y i))))))
218 always (equalp-with-case (my-row-major-aref x i)
219 (my-row-major-aref y i))))))
220
146221 (t (eql x y))))
147222
148223 (defun do-entry (entry &optional
160235 (setf r
161236 (flet ((%do
162237 ()
163 (if *compile-tests*
164 (multiple-value-list
165 (funcall (compile
166 nil
167 `(lambda ()
168 (declare
169 (optimize ,@*optimization-settings*))
170 ,(form entry)))))
238 (cond
239 (*compile-tests*
171240 (multiple-value-list
172 (eval (form entry))))))
241 (funcall (compile
242 nil
243 `(lambda ()
244 (declare
245 (optimize ,@*optimization-settings*))
246 ,(form entry))))))
247 (*expanded-eval*
248 (multiple-value-list
249 (expanded-eval (form entry))))
250 (t
251 (multiple-value-list
252 (eval (form entry)))))))
173253 (if *catch-errors*
174254 (handler-bind
175 ((style-warning #'muffle-warning)
176 (error #'(lambda (c)
177 (setf aborted t)
178 (setf r (list c))
179 (return-from aborted nil))))
180 (%do))
255 (#-ecl (style-warning #'muffle-warning)
256 (error #'(lambda (c)
257 (setf aborted t)
258 (setf r (list c))
259 (return-from aborted nil))))
260 (%do))
181261 (%do)))))
182262
183263 (setf (pend entry)
193273 *test* (form entry)
194274 (length (vals entry))
195275 (vals entry))
196 (format s "Actual value~P: ~
276 (handler-case
277 (let ((st (format nil "Actual value~P: ~
197278 ~{~S~^~%~15t~}.~%"
198 (length r) r)))))
279 (length r) r)))
280 (format s "~A" st))
281 (error () (format s "Actual value: #<error during printing>~%")
282 ))
283 (finish-output s)
284 ))))
199285 (when (not (pend entry)) *test*))
286
287 (defun expanded-eval (form)
288 "Split off top level of a form and eval separately. This reduces the chance that
289 compiler optimizations will fold away runtime computation."
290 (if (not (consp form))
291 (eval form)
292 (let ((op (car form)))
293 (cond
294 ((eq op 'let)
295 (let* ((bindings (loop for b in (cadr form)
296 collect (if (consp b) b (list b nil))))
297 (vars (mapcar #'car bindings))
298 (binding-forms (mapcar #'cadr bindings)))
299 (apply
300 (the function
301 (eval `(lambda ,vars ,@(cddr form))))
302 (mapcar #'eval binding-forms))))
303 ((and (eq op 'let*) (cadr form))
304 (let* ((bindings (loop for b in (cadr form)
305 collect (if (consp b) b (list b nil))))
306 (vars (mapcar #'car bindings))
307 (binding-forms (mapcar #'cadr bindings)))
308 (funcall
309 (the function
310 (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
311 (eval (car binding-forms)))))
312 ((eq op 'progn)
313 (loop for e on (cdr form)
314 do (if (null (cdr e)) (return (eval (car e)))
315 (eval (car e)))))
316 ((and (symbolp op) (fboundp op)
317 (not (macro-function op))
318 (not (special-operator-p op)))
319 (apply (symbol-function op)
320 (mapcar #'eval (cdr form))))
321 (t (eval form))))))
200322
201323 (defun continue-testing ()
202324 (if *in-test*
213335 (stream out :direction :output)
214336 (do-entries stream))))
215337
216 (defun do-entries (s)
338 (defun do-entries* (s)
217339 (format s "~&Doing ~A pending test~:P ~
218340 of ~A tests total.~%"
219 (count t (cdr *entries*)
220 :key #'pend)
341 (count t (the list (cdr *entries*)) :key #'pend)
221342 (length (cdr *entries*)))
343 (finish-output s)
222344 (dolist (entry (cdr *entries*))
223 (when (pend entry)
345 (when (and (pend entry)
346 (not (has-disabled-note entry)))
224347 (format s "~@[~<~%~:; ~:@(~S~)~>~]"
225 (do-entry entry s))))
348 (do-entry entry s))
349 (finish-output s)
350 ))
226351 (let ((pending (pending-tests))
227352 (expected-table (make-hash-table :test #'equal)))
228353 (dolist (ex *expected-failures*)
250375 (length new-failures)
251376 new-failures)))
252377 ))
378 (finish-output s)
253379 (null pending))))
380
381 (defun do-entries (s)
382 #-sbcl (do-entries* s)
383 #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
384 (do-entries* s)))
385
386 ;;; Note handling functions and macros
387
388 (defmacro defnote (name contents &optional disabled)
389 `(eval-when (:load-toplevel :execute)
390 (let ((note (make-note :name ',name
391 :contents ',contents
392 :disabled ',disabled)))
393 (setf (gethash (note-name note) *notes*) note)
394 note)))
395
396 (defun disable-note (n)
397 (let ((note (if (note-p n) n
398 (setf n (gethash n *notes*)))))
399 (unless note (error "~A is not a note or note name." n))
400 (setf (note-disabled note) t)
401 note))
402
403 (defun enable-note (n)
404 (let ((note (if (note-p n) n
405 (setf n (gethash n *notes*)))))
406 (unless note (error "~A is not a note or note name." n))
407 (setf (note-disabled note) nil)
408 note))