1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (load "assertoid.lisp")
13 (use-package "ASSERTOID")
15 (defmacro assert-nil-nil (expr)
16 `(assert (equal '(nil nil) (multiple-value-list ,expr))))
17 (defmacro assert-nil-t (expr)
18 `(assert (equal '(nil t) (multiple-value-list ,expr))))
19 (defmacro assert-t-t (expr)
20 `(assert (equal '(t t) (multiple-value-list ,expr))))
22 (defmacro assert-t-t-or-uncertain (expr)
23 `(assert (let ((list (multiple-value-list ,expr)))
24 (or (equal '(nil nil) list)
25 (equal '(t t) list)))))
27 (let ((types '(character
28 integer fixnum (integer 0 10)
29 single-float (single-float -1.0 1.0) (single-float 0.1)
30 (real 4 8) (real -1 7) (real 2 11)
32 (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
35 (rational -1 7) (rational -2 4)
39 (format t "type I=~S~%" i)
41 (format t " type J=~S~%" j)
42 (assert (subtypep i `(or ,i ,j)))
43 (assert (subtypep i `(or ,j ,i)))
44 (assert (subtypep i `(or ,i ,i ,j)))
45 (assert (subtypep i `(or ,j ,i)))
47 (format t " type K=~S~%" k)
48 (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
49 (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
51 ;;; gotchas that can come up in handling subtypeness as "X is a
52 ;;; subtype of Y if each of the elements of X is a subtype of Y"
53 (let ((subtypep-values (multiple-value-list
54 (subtypep '(single-float -1.0 1.0)
55 '(or (real -100.0 0.0)
56 (single-float 0.0 100.0))))))
57 (assert (member subtypep-values
58 '(;; The system isn't expected to
59 ;; understand the subtype relationship.
61 ;; But if it does, that'd be neat.
63 ;; (And any other return would be wrong.)
67 (defun type-evidently-= (x y)
71 (assert (subtypep 'single-float 'float))
73 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
75 ;;; Bug 50(c,d): numeric types with empty ranges should be NIL
76 (assert (type-evidently-= 'nil '(integer (0) (0))))
77 (assert (type-evidently-= 'nil '(rational (0) (0))))
78 (assert (type-evidently-= 'nil '(float (0.0) (0.0))))
80 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
81 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
82 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
83 (assert (eql (upgraded-array-element-type t) t))
84 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
85 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
87 ;;; Do reasonable things with undefined types, and with compound types
88 ;;; built from undefined types.
91 (assert (typep #(11) '(simple-array t 1)))
92 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
93 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
94 (assert (not (typep 11 '(simple-array undef-type 1))))
97 (assert (subtypep '(vector some-undef-type) 'vector))
98 (assert (not (subtypep '(vector some-undef-type) 'integer)))
99 (assert-nil-nil (subtypep 'utype-1 'utype-2))
100 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
101 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
102 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
104 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
105 (assert (raises-error? (typep 11 'and)))
106 (assert (raises-error? (typep 11 'or)))
107 (assert (raises-error? (typep 11 'member)))
108 (assert (raises-error? (typep 11 'values)))
109 (assert (raises-error? (typep 11 'eql)))
110 (assert (raises-error? (typep 11 'satisfies)))
111 (assert (raises-error? (typep 11 'not)))
113 ;;; Of course empty lists of subtypes are still OK.
114 (assert (typep 11 '(and)))
115 (assert (not (typep 11 '(or))))
117 ;;; bug 12: type system didn't grok nontrivial intersections
118 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
119 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
120 (assert (subtypep 'keyword 'symbol))
121 (assert (not (subtypep 'symbol 'keyword)))
122 (assert (subtypep 'ratio 'real))
123 (assert (subtypep 'ratio 'number))
125 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
126 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
127 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
129 (assert-nil-t (subtypep 'atom 'cons))
130 (assert-nil-t (subtypep 'cons 'atom))
131 ;;; These two are desireable but not necessary for ANSI conformance;
132 ;;; maintenance work on other parts of the system broke them in
133 ;;; sbcl-0.7.13.11 -- CSR
135 (assert-nil-t (subtypep '(not list) 'cons))
137 (assert-nil-t (subtypep '(not float) 'single-float))
138 (assert-t-t (subtypep '(not atom) 'cons))
139 (assert-t-t (subtypep 'cons '(not atom)))
140 ;;; ANSI requires that SUBTYPEP relationships among built-in primitive
141 ;;; types never be uncertain, i.e. never return NIL as second value.
142 ;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
143 ;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
144 ;;; CMU CL's HAIRY-TYPE logic punted a lot).
145 (assert-t-t (subtypep 'integer 'atom))
146 (assert-t-t (subtypep 'function 'atom))
147 (assert-nil-t (subtypep 'list 'atom))
148 (assert-nil-t (subtypep 'atom 'integer))
149 (assert-nil-t (subtypep 'atom 'function))
150 (assert-nil-t (subtypep 'atom 'list))
151 ;;; ATOM is equivalent to (NOT CONS):
152 (assert-t-t (subtypep 'integer '(not cons)))
153 (assert-nil-t (subtypep 'list '(not cons)))
154 (assert-nil-t (subtypep '(not cons) 'integer))
155 (assert-nil-t (subtypep '(not cons) 'list))
156 ;;; And we'd better check that all the named types are right. (We also
157 ;;; do some more tests on ATOM here, since once CSR experimented with
158 ;;; making it a named type.)
159 (assert-t-t (subtypep 'nil 'nil))
160 (assert-t-t (subtypep 'nil 'atom))
161 (assert-t-t (subtypep 'nil 't))
162 (assert-nil-t (subtypep 'atom 'nil))
163 (assert-t-t (subtypep 'atom 'atom))
164 (assert-t-t (subtypep 'atom 't))
165 (assert-nil-t (subtypep 't 'nil))
166 (assert-nil-t (subtypep 't 'atom))
167 (assert-t-t (subtypep 't 't))
168 ;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
169 ;;; recognized as a subtype of ATOM:
170 (assert-t-t (subtypep '(not list) 'atom))
171 (assert-nil-t (subtypep 'atom '(not list)))
172 ;;; These used to fail, because when the two arguments to subtypep are
173 ;;; of different specifier-type types (e.g. HAIRY and UNION), there
174 ;;; are two applicable type methods -- in this case
175 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
176 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
177 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
178 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
179 ;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
180 ;;; logic in those type methods fixed it.
181 (assert-nil-t (subtypep '(not cons) 'list))
182 (assert-nil-t (subtypep '(not single-float) 'float))
183 ;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
184 ;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
185 (assert-t-t (subtypep '(and zilch integer) 'zilch))
186 (assert-t-t (subtypep '(and integer zilch) 'zilch))
188 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
189 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
190 ;;; corresponding to the NIL type-specifier; we were bogusly returning
191 ;;; NIL, T (indicating surety) for the following:
192 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
194 ;;; It turns out that, as of sbcl-0.7.2, we require to be able to
195 ;;; detect this to compile src/compiler/node.lisp (and in particular,
196 ;;; the definition of the component structure). Since it's a sensible
197 ;;; thing to want anyway, let's test for it here:
198 (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
199 '(or some-undefined-type (member :no-ir2-yet :dead))))
200 ;;; BUG 158 (failure to compile loops with vector references and
201 ;;; increments of greater than 1) was a symptom of type system
202 ;;; uncertainty, to wit:
203 (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
204 '(mod 536870911))) ; aka SB-INT:INDEX.
205 ;;; floating point types can be tricky.
206 (assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
207 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
208 (assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
209 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
210 (assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
211 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
212 (assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
213 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
215 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
216 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
217 (assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
218 (assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
219 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
220 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
221 (assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
222 (assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
224 (assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
225 (assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
226 (assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
227 (assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
229 (assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
230 (assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
232 (assert-t-t (subtypep '(float -0.0) '(float 0.0)))
233 (assert-t-t (subtypep '(float 0.0) '(float -0.0)))
234 (assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
235 (assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))
237 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
238 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
239 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
240 ;;;; They look nice but they're nontrivial enough that it's not
241 ;;;; obvious from inspection that everything is OK. Let's make sure
242 ;;;; that things still basically work.
244 ;; structure type tests setup
245 (defstruct structure-foo1)
246 (defstruct (structure-foo2 (:include structure-foo1))
248 (defstruct (structure-foo3 (:include structure-foo2)))
249 (defstruct (structure-foo4 (:include structure-foo3))
252 ;; structure-class tests setup
253 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
254 (defclass structure-class-foo2 (structure-class-foo1)
255 () (:metaclass cl:structure-class))
256 (defclass structure-class-foo3 (structure-class-foo2)
257 () (:metaclass cl:structure-class))
258 (defclass structure-class-foo4 (structure-class-foo3)
259 () (:metaclass cl:structure-class))
261 ;; standard-class tests setup
262 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
263 (defclass standard-class-foo2 (standard-class-foo1)
264 () (:metaclass cl:standard-class))
265 (defclass standard-class-foo3 (standard-class-foo2)
266 () (:metaclass cl:standard-class))
267 (defclass standard-class-foo4 (standard-class-foo3)
268 () (:metaclass cl:standard-class))
270 ;; condition tests setup
271 (define-condition condition-foo1 (condition) ())
272 (define-condition condition-foo2 (condition-foo1) ())
273 (define-condition condition-foo3 (condition-foo2) ())
274 (define-condition condition-foo4 (condition-foo3) ())
276 ;;; inline type tests
277 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
278 (defparameter *tests-of-inline-type-tests*
281 ;; structure type tests
282 (assert (typep (make-structure-foo3) 'structure-foo2))
283 (assert (not (typep (make-structure-foo1) 'structure-foo4)))
284 (assert (typep (nth-value 1
285 (ignore-errors (structure-foo2-x
286 (make-structure-foo1))))
288 (assert (null (ignore-errors
289 (setf (structure-foo2-x (make-structure-foo1)) 11))))
291 ;; structure-class tests
292 (assert (typep (make-instance 'structure-class-foo3)
293 'structure-class-foo2))
294 (assert (not (typep (make-instance 'structure-class-foo1)
295 'structure-class-foo4)))
296 (assert (null (ignore-errors
297 (setf (slot-value (make-instance 'structure-class-foo1)
301 ;; standard-class tests
302 (assert (typep (make-instance 'standard-class-foo3)
303 'standard-class-foo2))
304 (assert (not (typep (make-instance 'standard-class-foo1)
305 'standard-class-foo4)))
306 (assert (null (ignore-errors
307 (setf (slot-value (make-instance 'standard-class-foo1) 'x)
311 (assert (typep (make-condition 'condition-foo3)
313 (assert (not (typep (make-condition 'condition-foo1)
315 (assert (null (ignore-errors
316 (setf (slot-value (make-condition 'condition-foo1) 'x)
318 (assert (subtypep 'error 't))
319 (assert (subtypep 'simple-condition 'condition))
320 (assert (subtypep 'simple-error 'simple-condition))
321 (assert (subtypep 'simple-error 'error))
322 (assert (not (subtypep 'condition 'simple-condition)))
323 (assert (not (subtypep 'error 'simple-error)))
324 (assert (eq (car (sb-pcl:class-direct-superclasses
325 (find-class 'simple-condition)))
326 (find-class 'condition)))
328 (let ((subclasses (mapcar #'find-class
332 sb-int:simple-file-error
333 sb-int:simple-style-warning))))
334 (assert (null (set-difference
335 (sb-pcl:class-direct-subclasses (find-class
340 (assert (equal (sb-pcl:class-precedence-list
341 (find-class 'simple-condition))
342 (mapcar #'find-class '(simple-condition
349 (assert (equal (sb-pcl:class-direct-superclasses (find-class
350 'fundamental-stream))
351 (mapcar #'find-class '(standard-object stream))))
352 (assert (null (set-difference
353 (sb-pcl:class-direct-subclasses (find-class
354 'fundamental-stream))
355 (mapcar #'find-class '(fundamental-binary-stream
356 fundamental-character-stream
357 fundamental-output-stream
358 fundamental-input-stream)))))
359 (assert (equal (sb-pcl:class-precedence-list (find-class
360 'fundamental-stream))
361 (mapcar #'find-class '(fundamental-stream
368 (assert (equal (sb-pcl:class-precedence-list (find-class
369 'fundamental-stream))
370 (mapcar #'find-class '(fundamental-stream
373 sb-pcl::slot-object stream
374 sb-kernel:instance t))))
375 (assert (subtypep (find-class 'stream) (find-class t)))
376 (assert (subtypep (find-class 'fundamental-stream) 'stream))
377 (assert (not (subtypep 'stream 'fundamental-stream)))))
378 ;;; Test under the interpreter.
379 (eval *tests-of-inline-type-tests*)
380 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
381 ;;; Test under the compiler.
382 (defun tests-of-inline-type-tests ()
383 #.*tests-of-inline-type-tests*)
384 (tests-of-inline-type-tests)
385 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
387 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
388 (defclass superclass () ())
389 (defclass maybe-subclass () ())
390 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
391 (defclass maybe-subclass (superclass) ())
392 (assert-t-t (subtypep 'maybe-subclass 'superclass))
393 (defclass maybe-subclass () ())
394 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
396 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
397 ;;; specialized on some as-yet-undefined type which would cause this
398 ;;; program to fail (bugs #123 and #165). Verify that it doesn't.
400 (declare (type (vector bar) x))
402 (deftype bar () 'single-float)
403 (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
409 (t1 (sb-kernel:specifier-type s)))
410 (eval `(defstruct ,s))
411 (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
414 (quit :unix-status 104)