1 ;;;; tests of the type system, intended to be executed as soon as
2 ;;;; the cross-compiler is built
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (in-package "SB!KERNEL")
17 (/show "beginning tests/type.before-xc.lisp")
19 (assert (type= (specifier-type '(and fixnum (satisfies foo)))
20 (specifier-type '(and (satisfies foo) fixnum))))
21 (assert (type= (specifier-type '(member 1 2 3))
22 (specifier-type '(member 2 3 1))))
23 (assert (type= (specifier-type '(and (member 1.0 2 3) single-float))
24 (specifier-type '(member 1.0))))
26 (assert (sb-xc:typep #(1 2 3) 'simple-vector))
27 (assert (sb-xc:typep #(1 2 3) 'vector))
28 (assert (not (sb-xc:typep '(1 2 3) 'vector)))
29 (assert (not (sb-xc:typep 1 'vector)))
31 (assert (sb-xc:typep '(1 2 3) 'list))
32 (assert (sb-xc:typep '(1 2 3) 'cons))
33 (assert (not (sb-xc:typep '(1 2 3) 'null)))
34 (assert (not (sb-xc:typep "1 2 3" 'list)))
35 (assert (not (sb-xc:typep 1 'list)))
37 (assert (sb-xc:typep nil 'null))
38 (assert (sb-xc:typep nil '(member nil)))
39 (assert (sb-xc:typep nil '(member 1 2 nil 3)))
40 (assert (not (sb-xc:typep nil '(member 1 2 3))))
42 (assert (type= *empty-type*
43 (type-intersection (specifier-type 'list)
44 (specifier-type 'vector))))
45 (assert (eql *empty-type*
46 (type-intersection (specifier-type 'list)
47 (specifier-type 'vector))))
48 (assert (type= (specifier-type 'null)
49 (type-intersection (specifier-type 'list)
50 (specifier-type '(or vector null)))))
51 (assert (type= (specifier-type 'null)
52 (type-intersection (specifier-type 'sequence)
53 (specifier-type 'symbol))))
54 (assert (type= (specifier-type 'cons)
55 (type-intersection (specifier-type 'sequence)
56 (specifier-type '(or cons number)))))
57 (assert (type= (specifier-type '(simple-array character (*)))
58 (type-intersection (specifier-type 'sequence)
59 (specifier-type '(simple-array character)))))
60 (assert (type= (specifier-type 'list)
61 (type-intersection (specifier-type 'sequence)
62 (specifier-type 'list))))
63 (assert (eql *empty-type*
64 (type-intersection (specifier-type '(satisfies keywordp))
67 (assert (type= (specifier-type 'list)
68 (type-union (specifier-type 'cons) (specifier-type 'null))))
69 (assert (type= (specifier-type 'list)
70 (type-union (specifier-type 'null) (specifier-type 'cons))))
72 (assert (type= (specifier-type 'sequence)
73 (type-union (specifier-type 'list) (specifier-type 'vector))))
75 (assert (type= (specifier-type 'sequence)
76 (type-union (specifier-type 'vector) (specifier-type 'list))))
77 (assert (type= (specifier-type 'list)
78 (type-union (specifier-type 'cons) (specifier-type 'list))))
79 (assert (not (csubtypep (type-union (specifier-type 'list)
80 (specifier-type '(satisfies foo)))
81 (specifier-type 'list))))
82 (assert (csubtypep (specifier-type 'list)
83 (type-union (specifier-type 'list)
84 (specifier-type '(satisfies foo)))))
86 ;;; Identities should be identities.
87 (dolist (type-specifier '(nil
94 (and symbol (satisfies foo))
95 (and (satisfies foo) string)
97 (or single-float character)
98 (or float (satisfies bar))
100 character standard-char
102 (/show type-specifier)
103 (let ((ctype (specifier-type type-specifier)))
105 (assert (eql *empty-type* (type-intersection ctype *empty-type*)))
106 (assert (eql *empty-type* (type-intersection *empty-type* ctype)))
107 (assert (eql *empty-type* (type-intersection2 ctype *empty-type*)))
108 (assert (eql *empty-type* (type-intersection2 *empty-type* ctype)))
110 (assert (type= ctype (type-intersection ctype *universal-type*)))
111 (assert (type= ctype (type-intersection *universal-type* ctype)))
112 (assert (type= ctype (type-intersection2 ctype *universal-type*)))
113 (assert (type= ctype (type-intersection2 *universal-type* ctype)))
115 (assert (eql *universal-type* (type-union ctype *universal-type*)))
116 (assert (eql *universal-type* (type-union *universal-type* ctype)))
117 (assert (eql *universal-type* (type-union2 ctype *universal-type*)))
118 (assert (eql *universal-type* (type-union2 *universal-type* ctype)))
120 (assert (type= ctype (type-union ctype *empty-type*)))
121 (assert (type= ctype (type-union *empty-type* ctype)))
122 (assert (type= ctype (type-union2 ctype *empty-type*)))
123 (assert (type= ctype (type-union2 *empty-type* ctype)))
125 (assert (csubtypep *empty-type* ctype))
126 (assert (csubtypep ctype *universal-type*))))
127 (/show "finished with identities-should-be-identities block")
129 (assert (sb-xc:subtypep 'simple-vector 'vector))
130 (assert (sb-xc:subtypep 'simple-vector 'simple-array))
131 (assert (sb-xc:subtypep 'vector 'array))
132 (assert (not (sb-xc:subtypep 'vector 'simple-vector)))
133 (assert (not (sb-xc:subtypep 'vector 'simple-array)))
135 (macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr)))))
136 (assert-secondnil (sb-xc:subtypep t '(satisfies foo)))
137 (assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar))))
138 (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar))))
139 (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil))
140 (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar))
142 (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
145 ;;; tests of 2-value quantifieroids FOO/TYPE
146 (macrolet ((2= (v1 v2 expr2)
149 `(multiple-value-bind (,x1 ,x2) ,expr2
150 (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2))
151 (error "mismatch for EXPR2=~S" ',expr2))))))
152 (flet (;; SUBTYPEP running in the cross-compiler
154 (csubtypep (specifier-type x)
155 (specifier-type y))))
156 (2= t t (any/type #'xsubtypep 'fixnum '(real integer)))
157 (2= t t (any/type #'xsubtypep 'fixnum '(real cons)))
158 (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector)))
159 (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
160 (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
161 (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
162 (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
163 (2= nil t (any/type #'xsubtypep 'fixnum '()))
164 (2= t t (every/type #'xsubtypep 'fixnum '()))
165 (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
166 (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
167 (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
168 (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
169 (2= t t (every/type #'xsubtypep 'fixnum '(real integer)))
170 (2= nil t (every/type #'xsubtypep 'fixnum '(real cons)))
171 (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector)))))
173 ;;; various dead bugs
174 (assert (union-type-p (type-intersection (specifier-type 'list)
175 (specifier-type '(or list vector)))))
176 (assert (type= (type-intersection (specifier-type 'list)
177 (specifier-type '(or list vector)))
178 (specifier-type 'list)))
179 (assert (array-type-p (type-intersection (specifier-type 'vector)
180 (specifier-type '(or list vector)))))
181 (assert (type= (type-intersection (specifier-type 'vector)
182 (specifier-type '(or list vector)))
183 (specifier-type 'vector)))
184 (assert (type= (type-intersection (specifier-type 'number)
185 (specifier-type 'integer))
186 (specifier-type 'integer)))
187 (assert (null (type-intersection2 (specifier-type 'symbol)
188 (specifier-type '(satisfies foo)))))
189 (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo)))))
190 (assert (ctypep :x86 (specifier-type '(satisfies keywordp))))
191 (assert (type= (specifier-type '(member :x86))
192 (specifier-type '(and (member :x86) (satisfies keywordp)))))
193 (let* ((type1 (specifier-type '(member :x86)))
194 (type2 (specifier-type '(or keyword null)))
195 (isect (type-intersection type1 type2)))
196 (assert (type= isect type1))
197 (assert (type= isect (type-intersection type2 type1)))
198 (assert (type= isect (type-intersection type2 type1 type2)))
199 (assert (type= isect (type-intersection type1 type1 type2 type1)))
200 (assert (type= isect (type-intersection type1 type2 type1 type2))))
201 (let* ((type1 (specifier-type 'keyword))
202 (type2 (specifier-type '(or keyword null)))
203 (isect (type-intersection type1 type2)))
204 (assert (type= isect type1))
205 (assert (type= isect (type-intersection type2 type1)))
206 (assert (type= isect (type-intersection type2 type1 type2)))
207 (assert (type= isect (type-intersection type1 type1 type2 type1)))
208 (assert (type= isect (type-intersection type1 type2 type1 type2))))
209 (assert (csubtypep (specifier-type '(or (single-float -1.0 1.0)
211 (specifier-type '(or (real -1 7)
213 (single-float -1.0 1.0)))))
214 (assert (not (csubtypep (specifier-type '(or (real -1 7)
216 (single-float -1.0 1.0)))
217 (specifier-type '(or (single-float -1.0 1.0)
218 (single-float 0.1))))))
220 (assert (sb-xc:typep #\, 'character))
221 (assert (sb-xc:typep #\@ 'character))
223 (assert (type= (type-intersection (specifier-type '(member #\a #\c #\e))
224 (specifier-type '(member #\b #\c #\f)))
225 (specifier-type '(member #\c))))
227 (multiple-value-bind (yes win)
228 (sb-xc:subtypep 'package 'instance)
231 (multiple-value-bind (yes win)
232 (sb-xc:subtypep 'symbol 'instance)
235 (multiple-value-bind (yes win)
236 (sb-xc:subtypep 'package 'funcallable-instance)
239 (multiple-value-bind (yes win)
240 (sb-xc:subtypep 'symbol 'funcallable-instance)
243 (multiple-value-bind (yes win)
244 (sb-xc:subtypep 'funcallable-instance 'function)
247 (multiple-value-bind (yes win)
248 (sb-xc:subtypep 'array 'instance)
251 (multiple-value-bind (yes win)
252 (sb-xc:subtypep 'character 'instance)
255 (multiple-value-bind (yes win)
256 (sb-xc:subtypep 'number 'instance)
259 (multiple-value-bind (yes win)
260 (sb-xc:subtypep 'package '(and (or symbol package) instance))
263 (multiple-value-bind (yes win)
264 (sb-xc:subtypep '(and (or double-float integer) instance) 'nil)
267 (multiple-value-bind (yes win)
268 (sb-xc:subtypep '(and (or double-float integer) funcallable-instance) 'nil)
271 (multiple-value-bind (yes win)
272 (sb-xc:subtypep 'instance 'type-specifier)
275 (multiple-value-bind (yes win)
276 (sb-xc:subtypep 'type-specifier 'instance)
279 (multiple-value-bind (yes win)
280 (sb-xc:subtypep '(and (function (t)) funcallable-instance) 'nil)
282 (multiple-value-bind (yes win)
283 (sb-xc:subtypep '(and fixnum function) 'nil)
286 (multiple-value-bind (yes win)
287 (sb-xc:subtypep '(and fixnum hash-table) 'nil)
290 (multiple-value-bind (yes win)
291 (sb-xc:subtypep '(function) '(function (t &rest t)))
294 ;; Used to run out of stack.
295 (multiple-value-bind (yes win)
296 (sb-xc:subtypep 'null '(or unk0 unk1))
300 (multiple-value-bind (yes win)
301 (sb-xc:subtypep '(and function instance) nil)
304 (multiple-value-bind (yes win)
305 (sb-xc:subtypep nil '(and function instance))
308 (multiple-value-bind (yes win)
309 (sb-xc:subtypep '(and function funcallable-instance) 'funcallable-instance)
312 (multiple-value-bind (yes win)
313 (sb-xc:subtypep 'funcallable-instance '(and function funcallable-instance))
316 (multiple-value-bind (yes win)
317 (sb-xc:subtypep 'stream 'instance)
319 (multiple-value-bind (yes win)
320 (sb-xc:subtypep 'stream 'funcallable-instance)
323 (multiple-value-bind (yes win)
324 (sb-xc:subtypep '(and stream instance) 'instance)
327 (multiple-value-bind (yes win)
328 (sb-xc:subtypep '(and stream funcallable-instance) 'funcallable-instance)
331 (multiple-value-bind (yes win)
332 (sb-xc:subtypep '(and stream instance) 'stream)
335 (multiple-value-bind (yes win)
336 (sb-xc:subtypep '(and stream funcallable-instance) 'stream)
340 (assert (type= (specifier-type 'nil)
341 (specifier-type '(and symbol funcallable-instance))))
343 (/show "done with tests/type.before-xc.lisp")