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 (eql *empty-type*
58 (type-intersection (specifier-type '(satisfies keywordp))
61 (assert (type= (specifier-type 'list)
62 (type-union (specifier-type 'cons) (specifier-type 'null))))
63 (assert (type= (specifier-type 'list)
64 (type-union (specifier-type 'null) (specifier-type 'cons))))
65 (assert (type= (specifier-type 'sequence)
66 (type-union (specifier-type 'list) (specifier-type 'vector))))
67 (assert (type= (specifier-type 'sequence)
68 (type-union (specifier-type 'vector) (specifier-type 'list))))
69 (assert (type= (specifier-type 'list)
70 (type-union (specifier-type 'cons) (specifier-type 'list))))
71 (assert (not (csubtypep (type-union (specifier-type 'list)
72 (specifier-type '(satisfies foo)))
73 (specifier-type 'list))))
74 (assert (csubtypep (specifier-type 'list)
75 (type-union (specifier-type 'list)
76 (specifier-type '(satisfies foo)))))
78 ;;; Identities should be identities.
79 (dolist (type-specifier '(nil
86 (and symbol (satisfies foo))
87 (and (satisfies foo) string)
89 (or single-float character)
90 (or float (satisfies bar))
92 character standard-char
94 (/show type-specifier)
95 (let ((ctype (specifier-type type-specifier)))
97 (assert (eql *empty-type* (type-intersection ctype *empty-type*)))
98 (assert (eql *empty-type* (type-intersection *empty-type* ctype)))
99 (assert (eql *empty-type* (type-intersection2 ctype *empty-type*)))
100 (assert (eql *empty-type* (type-intersection2 *empty-type* ctype)))
102 (assert (type= ctype (type-intersection ctype *universal-type*)))
103 (assert (type= ctype (type-intersection *universal-type* ctype)))
104 (assert (type= ctype (type-intersection2 ctype *universal-type*)))
105 (assert (type= ctype (type-intersection2 *universal-type* ctype)))
107 (assert (eql *universal-type* (type-union ctype *universal-type*)))
108 (assert (eql *universal-type* (type-union *universal-type* ctype)))
109 (assert (eql *universal-type* (type-union2 ctype *universal-type*)))
110 (assert (eql *universal-type* (type-union2 *universal-type* ctype)))
112 (assert (type= ctype (type-union ctype *empty-type*)))
113 (assert (type= ctype (type-union *empty-type* ctype)))
114 (assert (type= ctype (type-union2 ctype *empty-type*)))
115 (assert (type= ctype (type-union2 *empty-type* ctype)))
117 (assert (csubtypep *empty-type* ctype))
118 (assert (csubtypep ctype *universal-type*))))
119 (/show "finished with identities-should-be-identities block")
121 (assert (sb-xc:subtypep 'simple-vector 'vector))
122 (assert (sb-xc:subtypep 'simple-vector 'simple-array))
123 (assert (sb-xc:subtypep 'vector 'array))
124 (assert (not (sb-xc:subtypep 'vector 'simple-vector)))
125 (assert (not (sb-xc:subtypep 'vector 'simple-array)))
127 (macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr)))))
128 (assert-secondnil (sb-xc:subtypep t '(satisfies foo)))
129 (assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar))))
130 (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar))))
131 (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil))
132 (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar))
134 (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
137 ;;; tests of 2-value quantifieroids FOO/TYPE
138 (macrolet ((2= (v1 v2 expr2)
141 `(multiple-value-bind (,x1 ,x2) ,expr2
142 (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2))
143 (error "mismatch for EXPR2=~S" ',expr2))))))
144 (flet (;; SUBTYPEP running in the cross-compiler
146 (csubtypep (specifier-type x)
147 (specifier-type y))))
148 (2= t t (any/type #'xsubtypep 'fixnum '(real integer)))
149 (2= t t (any/type #'xsubtypep 'fixnum '(real cons)))
150 (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector)))
151 (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
152 (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
153 (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
154 (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
155 (2= nil t (any/type #'xsubtypep 'fixnum '()))
156 (2= t t (every/type #'xsubtypep 'fixnum '()))
157 (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
158 (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
159 (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
160 (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
161 (2= t t (every/type #'xsubtypep 'fixnum '(real integer)))
162 (2= nil t (every/type #'xsubtypep 'fixnum '(real cons)))
163 (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector)))))
165 ;;; various dead bugs
166 (assert (union-type-p (type-intersection (specifier-type 'list)
167 (specifier-type '(or list vector)))))
168 (assert (type= (type-intersection (specifier-type 'list)
169 (specifier-type '(or list vector)))
170 (specifier-type 'list)))
171 (assert (array-type-p (type-intersection (specifier-type 'vector)
172 (specifier-type '(or list vector)))))
173 (assert (type= (type-intersection (specifier-type 'vector)
174 (specifier-type '(or list vector)))
175 (specifier-type 'vector)))
176 (assert (type= (type-intersection (specifier-type 'number)
177 (specifier-type 'integer))
178 (specifier-type 'integer)))
179 (assert (null (type-intersection2 (specifier-type 'symbol)
180 (specifier-type '(satisfies foo)))))
181 (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo)))))
182 (assert (ctypep :x86 (specifier-type '(satisfies keywordp))))
183 (assert (type= (specifier-type '(member :x86))
184 (specifier-type '(and (member :x86) (satisfies keywordp)))))
185 (let* ((type1 (specifier-type '(member :x86)))
186 (type2 (specifier-type '(or keyword null)))
187 (isect (type-intersection type1 type2)))
188 (assert (type= isect type1))
189 (assert (type= isect (type-intersection type2 type1)))
190 (assert (type= isect (type-intersection type2 type1 type2)))
191 (assert (type= isect (type-intersection type1 type1 type2 type1)))
192 (assert (type= isect (type-intersection type1 type2 type1 type2))))
193 (let* ((type1 (specifier-type 'keyword))
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 (assert (csubtypep (specifier-type '(or (single-float -1.0 1.0)
203 (specifier-type '(or (real -1 7)
205 (single-float -1.0 1.0)))))
206 (assert (not (csubtypep (specifier-type '(or (real -1 7)
208 (single-float -1.0 1.0)))
209 (specifier-type '(or (single-float -1.0 1.0)
210 (single-float 0.1))))))
212 (assert (sb-xc:typep #\, 'character))
213 (assert (sb-xc:typep #\@ 'character))
215 (assert (type= (type-intersection (specifier-type '(member #\a #\c #\e))
216 (specifier-type '(member #\b #\c #\f)))
217 (specifier-type '(member #\c))))
219 (multiple-value-bind (yes win)
220 (sb-xc:subtypep 'package 'instance)
223 (multiple-value-bind (yes win)
224 (sb-xc:subtypep 'symbol 'instance)
227 (multiple-value-bind (yes win)
228 (sb-xc:subtypep 'package 'funcallable-instance)
231 (multiple-value-bind (yes win)
232 (sb-xc:subtypep 'symbol 'funcallable-instance)
235 (multiple-value-bind (yes win)
236 (sb-xc:subtypep 'funcallable-instance 'function)
239 (multiple-value-bind (yes win)
240 (sb-xc:subtypep 'array 'instance)
243 (multiple-value-bind (yes win)
244 (sb-xc:subtypep 'character 'instance)
247 (multiple-value-bind (yes win)
248 (sb-xc:subtypep 'number 'instance)
251 (multiple-value-bind (yes win)
252 (sb-xc:subtypep 'package '(and (or symbol package) instance))
255 (multiple-value-bind (yes win)
256 (sb-xc:subtypep '(and (or double-float integer) instance) 'nil)
259 (multiple-value-bind (yes win)
260 (sb-xc:subtypep '(and (or double-float integer) funcallable-instance) 'nil)
263 (multiple-value-bind (yes win)
264 (sb-xc:subtypep 'instance 'type-specifier)
267 (multiple-value-bind (yes win)
268 (sb-xc:subtypep 'type-specifier 'instance)
271 (multiple-value-bind (yes win)
272 (sb-xc:subtypep '(and (function (t)) funcallable-instance) 'nil)
274 (multiple-value-bind (yes win)
275 (sb-xc:subtypep '(and fixnum function) 'nil)
278 (multiple-value-bind (yes win)
279 (sb-xc:subtypep '(and fixnum hash-table) 'nil)
282 (multiple-value-bind (yes win)
283 (sb-xc:subtypep '(function) '(function (t &rest t)))
287 (/show "done with tests/type.before-xc.lisp")