Take pointer, not word count, as upper limit in verify_space()
[sbcl.git] / tests / type.before-xc.lisp
blob5944655d7dfa17a6584821b5ea0e0c8744a9dcd1
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
5 ;;;; more information.
6 ;;;;
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
9 ;;;; from CMU CL.
10 ;;;;
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 (type= *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 (type= *empty-type*
64 (type-intersection (specifier-type '(satisfies keywordp))
65 *empty-type*)))
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))))
71 #+nil ; not any more
72 (assert (type= (specifier-type 'sequence)
73 (type-union (specifier-type 'list) (specifier-type 'vector))))
74 #+nil ; not any more
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
89 null
90 (satisfies keywordp)
91 (satisfies foo)
92 (not fixnum)
93 (not null)
94 (and symbol (satisfies foo))
95 (and (satisfies foo) string)
96 (or symbol sequence)
97 (or single-float character)
98 (or float (satisfies bar))
99 integer (integer 0 1)
100 character standard-char
101 (member 1 2 3)))
102 (/show type-specifier)
103 (let ((ctype (specifier-type type-specifier)))
105 (assert (type= *empty-type* (type-intersection ctype *empty-type*)))
106 (assert (type= *empty-type* (type-intersection *empty-type* ctype)))
107 (assert (type= *empty-type* (type-intersection2 ctype *empty-type*)))
108 (assert (type= *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 (type= *universal-type* (type-union ctype *universal-type*)))
116 (assert (type= *universal-type* (type-union *universal-type* ctype)))
117 (assert (type= *universal-type* (type-union2 ctype *universal-type*)))
118 (assert (type= *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))
141 nil))
142 (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
143 nil)))
145 ;;; tests of 2-value quantifieroids FOO/TYPE
146 (macrolet ((2= (v1 v2 expr2)
147 (let ((x1 (gensym))
148 (x2 (gensym)))
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
153 (xsubtypep (x y)
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)
210 (single-float 0.1)))
211 (specifier-type '(or (real -1 7)
212 (single-float 0.1)
213 (single-float -1.0 1.0)))))
214 (assert (not (csubtypep (specifier-type '(or (real -1 7)
215 (single-float 0.1)
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)
229 (assert yes)
230 (assert win))
231 (multiple-value-bind (yes win)
232 (sb-xc:subtypep 'symbol 'instance)
233 (assert (not yes))
234 (assert win))
235 (multiple-value-bind (yes win)
236 (sb-xc:subtypep 'package 'funcallable-instance)
237 (assert (not yes))
238 (assert win))
239 (multiple-value-bind (yes win)
240 (sb-xc:subtypep 'symbol 'funcallable-instance)
241 (assert (not yes))
242 (assert win))
243 (multiple-value-bind (yes win)
244 (sb-xc:subtypep 'funcallable-instance 'function)
245 (assert yes)
246 (assert win))
247 (multiple-value-bind (yes win)
248 (sb-xc:subtypep 'array 'instance)
249 (assert (not yes))
250 (assert win))
251 (multiple-value-bind (yes win)
252 (sb-xc:subtypep 'character 'instance)
253 (assert (not yes))
254 (assert win))
255 (multiple-value-bind (yes win)
256 (sb-xc:subtypep 'number 'instance)
257 (assert (not yes))
258 (assert win))
259 (multiple-value-bind (yes win)
260 (sb-xc:subtypep 'package '(and (or symbol package) instance))
261 (assert yes)
262 (assert win))
263 (multiple-value-bind (yes win)
264 (sb-xc:subtypep '(and (or double-float integer) instance) 'nil)
265 (assert yes)
266 (assert win))
267 (multiple-value-bind (yes win)
268 (sb-xc:subtypep '(and (or double-float integer) funcallable-instance) 'nil)
269 (assert yes)
270 (assert win))
271 (multiple-value-bind (yes win) (sb-xc:subtypep 'instance 'type-specifier)
272 (assert (not yes))
273 (assert (not win)))
274 (multiple-value-bind (yes win) (sb-xc:subtypep 'type-specifier 'instance)
275 (assert (not yes))
276 (assert win))
277 (multiple-value-bind (yes win) (sb-xc:subtypep 'class 'type-specifier)
278 (assert yes)
279 (assert win))
280 (multiple-value-bind (yes win) (sb-xc:subtypep 'classoid 'type-specifier)
281 (assert yes)
282 (assert win))
283 (multiple-value-bind (yes win)
284 (sb-xc:subtypep '(and (function (t)) funcallable-instance) 'nil)
285 (assert (not win))
286 (assert (not yes)))
287 (multiple-value-bind (yes win)
288 (sb-xc:subtypep '(and fixnum function) 'nil)
289 (assert yes)
290 (assert win))
291 (multiple-value-bind (yes win)
292 (sb-xc:subtypep '(and fixnum hash-table) 'nil)
293 (assert yes)
294 (assert win))
295 (multiple-value-bind (yes win)
296 (sb-xc:subtypep '(function) '(function (t &rest t)))
297 (assert (not yes))
298 (assert win))
299 ;; Used to run out of stack.
300 (multiple-value-bind (yes win)
301 (sb-xc:subtypep 'null '(or unk0 unk1))
302 (assert (not yes))
303 (assert (not win)))
305 (multiple-value-bind (yes win)
306 (sb-xc:subtypep '(and function instance) nil)
307 (assert yes)
308 (assert win))
309 (multiple-value-bind (yes win)
310 (sb-xc:subtypep nil '(and function instance))
311 (assert yes)
312 (assert win))
313 (multiple-value-bind (yes win)
314 (sb-xc:subtypep '(and function funcallable-instance) 'funcallable-instance)
315 (assert yes)
316 (assert win))
317 (multiple-value-bind (yes win)
318 (sb-xc:subtypep 'funcallable-instance '(and function funcallable-instance))
319 (assert yes)
320 (assert win))
321 (multiple-value-bind (yes win)
322 (sb-xc:subtypep 'stream 'instance)
323 (assert (not win))
324 (assert (not yes)))
325 (multiple-value-bind (yes win)
326 (sb-xc:subtypep 'stream 'funcallable-instance)
327 (assert (not yes))
328 (assert win))
329 (multiple-value-bind (yes win)
330 (sb-xc:subtypep '(and stream instance) 'instance)
331 (assert yes)
332 (assert win))
333 (multiple-value-bind (yes win)
334 (sb-xc:subtypep '(and stream funcallable-instance) 'funcallable-instance)
335 (assert yes)
336 (assert win))
337 (multiple-value-bind (yes win)
338 (sb-xc:subtypep '(and stream instance) 'stream)
339 (assert yes)
340 (assert win))
341 (multiple-value-bind (yes win)
342 (sb-xc:subtypep '(and stream funcallable-instance) 'stream)
343 (assert yes)
344 (assert win))
346 (assert (type= (specifier-type 'nil)
347 (specifier-type '(and symbol funcallable-instance))))
349 (assert (not (type= (specifier-type '(function (t) (values &optional)))
350 (specifier-type '(function (t) (values))))))
352 ;; Assert that these types are interned by parsing each twice,
353 ;; dropping the specifier-type cache in between.
354 (dolist (spec '(index cons null boolean character base-char extended-char))
355 (let ((a (specifier-type spec)))
356 (drop-all-hash-caches)
357 (let ((b (specifier-type spec)))
358 (assert (eq a b)))))
359 (drop-all-hash-caches)
360 ;; BOOLEAN's deftype lists the members as (T NIL),
361 ;; but it should also be EQ to (MEMBER NIL T)
362 (assert (eq (specifier-type '(member nil t)) (specifier-type 'boolean)))
364 (/show "done with tests/type.before-xc.lisp")