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 (unless (find-package "BEFORE-XC-TESTS")
16 (make-package "BEFORE-XC-TESTS" :use
'("SB-XC" "SB-KERNEL" "SB-INT")))
17 (do-external-symbols (s "SB-XC") ; Import all symbols from SB-XC, then use CL
18 (shadowing-import s
"BEFORE-XC-TESTS"))
19 (import '(sb-kernel::type-union2
) "BEFORE-XC-TESTS")
20 (cl:use-package
'("COMMON-LISP") "BEFORE-XC-TESTS")
22 (in-package "BEFORE-XC-TESTS")
24 ;;; Assert that some of the type specifiers which we claim have unique internal
25 ;;; representations do, and that parsing does not rely critically on
26 ;;; memoization performed in SPECIFIER-TYPE, which is only a best effort
27 ;;; to produce the EQ model object given an EQUAL specifier.
28 (dolist (type sb-kernel
::*special-union-types
*)
29 (dolist (constituent-type (union-type-types (specifier-type type
)))
30 (let ((specifier (type-specifier constituent-type
)))
31 (drop-all-hash-caches)
32 (let ((parse (specifier-type specifier
)))
33 (drop-all-hash-caches)
34 (let ((reparse (specifier-type specifier
)))
35 (aver (eq parse reparse
)))))))
37 (assert (type= (specifier-type '(and fixnum
(satisfies foo
)))
38 (specifier-type '(and (satisfies foo
) fixnum
))))
39 (assert (type= (specifier-type '(member 1 2 3))
40 (specifier-type '(member 2 3 1))))
41 (assert (type= (specifier-type '(and (member $
1.0 2 3) single-float
))
42 (specifier-type '(member $
1.0))))
44 (assert (typep "hello" '(and array
(not (array t
)))))
45 (assert (typep "hello" 'string
))
46 (assert (typep "hello" 'simple-string
))
47 (assert (typep "hello" 'unboxed-array
))
48 (assert (typep "hello" 'simple-unboxed-array
))
50 (assert (typep #*101 '(and array
(not (array t
)))))
51 (assert (typep #*101 'bit-vector
))
52 (assert (typep #*101 'simple-bit-vector
))
53 (assert (typep #*101 'unboxed-array
))
54 (assert (typep #*101 'simple-unboxed-array
))
56 ;;; When the host does not have (UNSIGNED-BYTE n), this makes an excellent test.
57 ;;; When the host *does* have it, this test is "suspicious" (in the sense that
58 ;;; it would not necessarily detect a bug in our portable array logic),
59 ;;; but is nonetheless valid, and especially since most other lisps don't
60 ;;; have (UNSIGNED-BYTE 2), it's a pretty reasonable thing to check.
61 (dovector (x sb-vm
:*specialized-array-element-type-properties
*)
62 (let ((et (sb-vm:saetp-specifier x
)))
63 ;; Test the numeric array specializations.
64 (unless (member et
'(nil t base-char character
))
65 (let ((a (make-array 11 :element-type et
)))
66 (assert (type= (ctype-of a
) (specifier-type `(simple-array ,et
(11)))))
67 (assert (typep a
'(and array
(not (array t
)))))
68 (assert (typep a
`(simple-array ,et
(11))))
69 (assert (typep a
`(array ,et
(11))))
70 (dolist (type-atom '(unboxed-array simple-unboxed-array
))
71 (assert (typep a type-atom
))
72 (assert (typep a
`(,type-atom
*)))
73 (assert (typep a
`(,type-atom
(*))))
74 (assert (typep a
`(,type-atom
(11)))))))))
76 ;;; Here it doesn't matter what we specify as element-type to MAKE-ARRAY
77 ;;; because it introspects as if it were SIMPLE-VECTOR due to
78 ;;; non-use of make-specialized-array.
79 ;;; (Note use of CL:MAKE-ARRAY. This file of tests causes symbol lookup
80 ;;; to default to using the SB-XC symbol otherwise)
81 (assert (type= (ctype-of (cl:make-array
11 :element-type
'(signed-byte 8)))
82 (specifier-type '(simple-vector 11))))
84 (assert (typep #(1 2 3) 'simple-vector
))
85 (assert (typep #(1 2 3) 'vector
))
86 (assert (not (typep '(1 2 3) 'vector
)))
87 (assert (not (typep 1 'vector
)))
89 (assert (typep '(1 2 3) 'list
))
90 (assert (typep '(1 2 3) 'cons
))
91 (assert (not (typep '(1 2 3) 'null
)))
92 (assert (not (typep "1 2 3" 'list
)))
93 (assert (not (typep 1 'list
)))
95 (assert (typep nil
'null
))
96 (assert (typep nil
'(member nil
)))
97 (assert (typep nil
'(member 1 2 nil
3)))
98 (assert (not (typep nil
'(member 1 2 3))))
100 (assert (type= *empty-type
*
101 (type-intersection (specifier-type 'list
)
102 (specifier-type 'vector
))))
103 (assert (type= *empty-type
*
104 (type-intersection (specifier-type 'list
)
105 (specifier-type 'vector
))))
106 (assert (type= (specifier-type 'null
)
107 (type-intersection (specifier-type 'list
)
108 (specifier-type '(or vector null
)))))
109 (assert (type= (specifier-type 'null
)
110 (type-intersection (specifier-type 'sequence
)
111 (specifier-type 'symbol
))))
112 (assert (type= (specifier-type 'cons
)
113 (type-intersection (specifier-type 'sequence
)
114 (specifier-type '(or cons number
)))))
115 (assert (type= (specifier-type '(simple-array character
(*)))
116 (type-intersection (specifier-type 'sequence
)
117 (specifier-type '(simple-array character
)))))
118 (assert (type= (specifier-type 'list
)
119 (type-intersection (specifier-type 'sequence
)
120 (specifier-type 'list
))))
121 (assert (type= *empty-type
*
122 (type-intersection (specifier-type '(satisfies keywordp
))
125 (assert (type= (specifier-type 'list
)
126 (type-union (specifier-type 'cons
) (specifier-type 'null
))))
127 (assert (type= (specifier-type 'list
)
128 (type-union (specifier-type 'null
) (specifier-type 'cons
))))
130 (assert (type= (specifier-type 'sequence
)
131 (type-union (specifier-type 'list
) (specifier-type 'vector
))))
133 (assert (type= (specifier-type 'sequence
)
134 (type-union (specifier-type 'vector
) (specifier-type 'list
))))
135 (assert (type= (specifier-type 'list
)
136 (type-union (specifier-type 'cons
) (specifier-type 'list
))))
137 (let ((sb-kernel::*xtypep-uncertainty-action
* nil
))
138 (assert (not (csubtypep (type-union (specifier-type 'list
)
139 (specifier-type '(satisfies foo
)))
140 (specifier-type 'list
))))
141 (assert (csubtypep (specifier-type 'list
)
142 (type-union (specifier-type 'list
)
143 (specifier-type '(satisfies foo
))))))
145 ;;; Identities should be identities.
146 (dolist (type-specifier '(nil
153 (and symbol
(satisfies foo
))
154 (and (satisfies foo
) string
)
156 (or single-float character
)
157 (or float
(satisfies bar
))
158 integer
(integer 0 1)
159 character standard-char
161 (let ((ctype (specifier-type type-specifier
)))
163 (assert (type= *empty-type
* (type-intersection ctype
*empty-type
*)))
164 (assert (type= *empty-type
* (type-intersection *empty-type
* ctype
)))
165 (assert (type= *empty-type
* (type-intersection2 ctype
*empty-type
*)))
166 (assert (type= *empty-type
* (type-intersection2 *empty-type
* ctype
)))
168 (assert (type= ctype
(type-intersection ctype
*universal-type
*)))
169 (assert (type= ctype
(type-intersection *universal-type
* ctype
)))
170 (assert (type= ctype
(type-intersection2 ctype
*universal-type
*)))
171 (assert (type= ctype
(type-intersection2 *universal-type
* ctype
)))
173 (assert (type= *universal-type
* (type-union ctype
*universal-type
*)))
174 (assert (type= *universal-type
* (type-union *universal-type
* ctype
)))
175 (assert (type= *universal-type
* (type-union2 ctype
*universal-type
*)))
176 (assert (type= *universal-type
* (type-union2 *universal-type
* ctype
)))
178 (assert (type= ctype
(type-union ctype
*empty-type
*)))
179 (assert (type= ctype
(type-union *empty-type
* ctype
)))
180 (assert (type= ctype
(type-union2 ctype
*empty-type
*)))
181 (assert (type= ctype
(type-union2 *empty-type
* ctype
)))
183 (assert (csubtypep *empty-type
* ctype
))
184 (assert (csubtypep ctype
*universal-type
*))))
186 (assert (subtypep 'simple-vector
'vector
))
187 (assert (subtypep 'simple-vector
'simple-array
))
188 (assert (subtypep 'vector
'array
))
189 (assert (not (subtypep 'vector
'simple-vector
)))
190 (assert (not (subtypep 'vector
'simple-array
)))
192 (macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr
)))))
193 (assert-secondnil (subtypep t
'(satisfies foo
)))
194 (assert-secondnil (subtypep t
'(and (satisfies foo
) (satisfies bar
))))
195 (assert-secondnil (subtypep t
'(or (satisfies foo
) (satisfies bar
))))
196 (assert-secondnil (subtypep '(satisfies foo
) nil
))
197 (assert-secondnil (subtypep '(and (satisfies foo
) (satisfies bar
))
199 (assert-secondnil (subtypep '(or (satisfies foo
) (satisfies bar
))
202 ;;; tests of 2-value quantifieroids FOO/TYPE
203 (macrolet ((2= (v1 v2 expr2
)
206 `(multiple-value-bind (,x1
,x2
) ,expr2
207 (unless (and (eql ,x1
,v1
) (eql ,x2
,v2
))
208 (error "mismatch for EXPR2=~S" ',expr2
))))))
209 (flet (;; SUBTYPEP running in the cross-compiler
211 (csubtypep (specifier-type x
)
212 (specifier-type y
))))
213 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real integer
)))
214 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real cons
)))
215 (2= nil t
(any/type
#'xsubtypep
'fixnum
'(cons vector
)))
216 (2= nil nil
(any/type
#'xsubtypep
'fixnum
'(cons some-unknown-type-foo
)))
217 (2= nil nil
(any/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo cons
)))
218 (2= t t
(any/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo real
)))
219 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real some-unknown-type-foo
)))
220 (2= nil t
(any/type
#'xsubtypep
'fixnum
'()))
221 (2= t t
(every/type
#'xsubtypep
'fixnum
'()))
222 (2= nil nil
(every/type
#'xsubtypep
'fixnum
'(real some-unknown-type-foo
)))
223 (2= nil nil
(every/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo real
)))
224 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo cons
)))
225 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(cons some-unknown-type-foo
)))
226 (2= t t
(every/type
#'xsubtypep
'fixnum
'(real integer
)))
227 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(real cons
)))
228 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(cons vector
)))))
230 ;;; various dead bugs
231 (assert (union-type-p (type-intersection (specifier-type 'list
)
232 (specifier-type '(or list vector
)))))
233 (assert (type= (type-intersection (specifier-type 'list
)
234 (specifier-type '(or list vector
)))
235 (specifier-type 'list
)))
236 (assert (array-type-p (type-intersection (specifier-type 'vector
)
237 (specifier-type '(or list vector
)))))
238 (assert (type= (type-intersection (specifier-type 'vector
)
239 (specifier-type '(or list vector
)))
240 (specifier-type 'vector
)))
241 (assert (type= (type-intersection (specifier-type 'number
)
242 (specifier-type 'integer
))
243 (specifier-type 'integer
)))
244 (let ((sb-kernel::*xtypep-uncertainty-action
* nil
))
245 (assert (null (type-intersection2 (specifier-type 'symbol
)
246 (specifier-type '(satisfies foo
)))))
247 (assert (intersection-type-p (specifier-type '(and symbol
(satisfies foo
))))))
248 (assert (ctypep :x86
(specifier-type '(satisfies keywordp
))))
249 (assert (not (ctypep 'cons
(specifier-type '(satisfies keywordp
)))))
250 (assert (type= (specifier-type '(member :x86
))
251 (specifier-type '(and (member :x86
) (satisfies keywordp
)))))
253 (let* ((type1 (specifier-type '(member :x86
)))
254 (type2 (specifier-type '(or keyword null
)))
255 (isect (type-intersection type1 type2
)))
256 (assert (type= isect type1
))
257 (assert (type= isect
(type-intersection type2 type1
)))
258 (assert (type= isect
(type-intersection type2 type1 type2
)))
259 (assert (type= isect
(type-intersection type1 type1 type2 type1
)))
260 (assert (type= isect
(type-intersection type1 type2 type1 type2
))))
261 (let* ((type1 (specifier-type 'keyword
))
262 (type2 (specifier-type '(or keyword null
)))
263 (isect (type-intersection type1 type2
)))
264 (assert (type= isect type1
))
265 (assert (type= isect
(type-intersection type2 type1
)))
266 (assert (type= isect
(type-intersection type2 type1 type2
)))
267 (assert (type= isect
(type-intersection type1 type1 type2 type1
)))
268 (assert (type= isect
(type-intersection type1 type2 type1 type2
))))
269 (assert (csubtypep (specifier-type '(or (single-float $-
1.0 $
1.0)
270 (single-float $
0.1)))
271 (specifier-type '(or (real -
1 7)
273 (single-float $-
1.0 $
1.0)))))
274 (assert (not (csubtypep (specifier-type '(or (real -
1 7)
276 (single-float $-
1.0 $
1.0)))
277 (specifier-type '(or (single-float $-
1.0 $
1.0)
278 (single-float $
0.1))))))
280 (assert (typep #\
, 'character
))
281 (assert (typep #\
@ 'character
))
283 (assert (type= (type-intersection (specifier-type '(member #\a #\c
#\e
))
284 (specifier-type '(member #\b #\c
#\f)))
285 (specifier-type '(member #\c
))))
287 (multiple-value-bind (yes win
)
288 (subtypep 'package
'instance
)
291 (multiple-value-bind (yes win
)
292 (subtypep 'symbol
'instance
)
295 (multiple-value-bind (yes win
)
296 (subtypep 'package
'funcallable-instance
)
299 (multiple-value-bind (yes win
)
300 (subtypep 'symbol
'funcallable-instance
)
303 (multiple-value-bind (yes win
)
304 (subtypep 'funcallable-instance
'function
)
307 (multiple-value-bind (yes win
)
308 (subtypep 'array
'instance
)
311 (multiple-value-bind (yes win
)
312 (subtypep 'character
'instance
)
315 (multiple-value-bind (yes win
)
316 (subtypep 'number
'instance
)
319 (multiple-value-bind (yes win
)
320 (subtypep 'package
'(and (or symbol package
) instance
))
323 (multiple-value-bind (yes win
)
324 (subtypep '(and (or double-float integer
) instance
) 'nil
)
327 (multiple-value-bind (yes win
)
328 (subtypep '(and (or double-float integer
) funcallable-instance
) 'nil
)
331 (multiple-value-bind (yes win
) (subtypep 'instance
'type-specifier
)
334 (multiple-value-bind (yes win
) (subtypep 'type-specifier
'instance
)
337 (multiple-value-bind (yes win
) (subtypep 'class
'type-specifier
)
340 (multiple-value-bind (yes win
) (subtypep 'classoid
'type-specifier
)
343 (multiple-value-bind (yes win
)
344 (subtypep '(and (function (t)) funcallable-instance
) 'nil
)
347 (multiple-value-bind (yes win
)
348 (subtypep '(and fixnum function
) 'nil
)
351 (multiple-value-bind (yes win
)
352 (subtypep '(and fixnum hash-table
) 'nil
)
355 (multiple-value-bind (yes win
)
356 (subtypep '(function) '(function (t &rest t
)))
359 ;; Used to run out of stack.
360 (let ((sb-kernel::*xtypep-uncertainty-action
* nil
))
361 (multiple-value-bind (yes win
)
362 (handler-bind ((sb-kernel::cross-type-giving-up
#'muffle-warning
))
363 (subtypep 'null
'(or unk0 unk1
)))
367 (multiple-value-bind (yes win
)
368 (subtypep '(and function instance
) nil
)
371 (multiple-value-bind (yes win
)
372 (subtypep nil
'(and function instance
))
375 (multiple-value-bind (yes win
)
376 (subtypep '(and function funcallable-instance
) 'funcallable-instance
)
379 (multiple-value-bind (yes win
)
380 (subtypep 'funcallable-instance
'(and function funcallable-instance
))
383 (multiple-value-bind (yes win
)
384 (subtypep 'stream
'instance
)
387 (multiple-value-bind (yes win
)
388 (subtypep 'stream
'funcallable-instance
)
391 (multiple-value-bind (yes win
)
392 (subtypep '(and stream instance
) 'instance
)
395 (multiple-value-bind (yes win
)
396 (subtypep '(and stream funcallable-instance
) 'funcallable-instance
)
399 (multiple-value-bind (yes win
)
400 (subtypep '(and stream instance
) 'stream
)
403 (multiple-value-bind (yes win
)
404 (subtypep '(and stream funcallable-instance
) 'stream
)
408 (assert (type= (specifier-type 'nil
)
409 (specifier-type '(and symbol funcallable-instance
))))
411 (assert (not (type= (specifier-type '(function (t) (values &optional
)))
412 (specifier-type '(function (t) (values))))))
414 ;; Assert that these types are interned by parsing each twice,
415 ;; dropping the specifier-type cache in between.
416 (dolist (spec '(index cons null boolean character base-char extended-char
))
417 (let ((a (specifier-type spec
)))
418 (drop-all-hash-caches)
419 (let ((b (specifier-type spec
)))
421 (drop-all-hash-caches)
422 ;; BOOLEAN's deftype lists the members as (T NIL),
423 ;; but it should also be EQ to (MEMBER NIL T)
424 (assert (eq (specifier-type '(member nil t
)) (specifier-type 'boolean
)))
428 (assert (= (sb-vm::immediate-constant-sc
(complex $
0.0f0 $
0.0f0
))
429 sb-vm
::fp-complex-single-zero-sc-number
))
430 (assert (= (sb-vm::immediate-constant-sc
(complex $
0.0d0 $
0.0d0
))
431 sb-vm
::fp-complex-double-zero-sc-number
)))
433 ;;; Unparse a union of (up to) 3 things depending on :sb-unicode as 2 things.
434 (assert (sb-kernel::brute-force-type-specifier-equalp
435 (type-specifier (specifier-type '(or string null
)))
436 '(or #+sb-unicode string
#-sb-unicode base-string null
)))
438 (multiple-value-bind (result exactp
)
439 (sb-vm::primitive-type
(specifier-type 'list
))
440 (assert (and (eq result
(sb-vm::primitive-type-or-lose
'list
))
442 (multiple-value-bind (result exactp
)
443 (sb-vm::primitive-type
(specifier-type 'cons
))
444 (assert (and (eq result
(sb-vm::primitive-type-or-lose
'list
))
447 (let ((bs (specifier-type 'base-string
))
448 (not-sbs (specifier-type '(not simple-base-string
)))
449 (not-ss (specifier-type '(not simple-string
))))
450 (let ((intersect (type-intersection bs not-sbs
)))
451 (assert (array-type-p intersect
))
452 (assert (type= intersect
(specifier-type '(and base-string
(not simple-array
))))))
453 ;; should be commutative
454 (let ((intersect (type-intersection not-sbs bs
)))
455 (assert (array-type-p intersect
))
456 (assert (type= intersect
(specifier-type '(and base-string
(not simple-array
))))))
457 ;; test when the righthand side is a larger negation type
458 (let ((intersect (type-intersection bs not-ss
)))
459 (assert (array-type-p intersect
))
460 (assert (type= intersect
(specifier-type '(and base-string
(not simple-array
))))))
461 (let ((intersect (type-intersection not-sbs bs
)))
462 (assert (array-type-p intersect
))
463 (assert (type= intersect
(specifier-type '(and base-string
(not simple-array
)))))))
466 (let ((cs (specifier-type 'sb-kernel
::character-string
))
467 (not-scs (specifier-type '(not sb-kernel
:simple-character-string
)))
468 (not-ss (specifier-type '(not simple-string
))))
469 (let ((intersect (type-intersection cs not-scs
)))
470 (assert (array-type-p intersect
))
471 (assert (type= intersect
(specifier-type '(and sb-kernel
::character-string
(not simple-array
))))))
472 (let ((intersect (type-intersection not-scs cs
)))
473 (assert (array-type-p intersect
))
474 (assert (type= intersect
(specifier-type '(and sb-kernel
::character-string
(not simple-array
))))))
475 ;; test when the righthand side is a larger negation type
476 (let ((intersect (type-intersection cs not-ss
)))
477 (assert (array-type-p intersect
))
478 (assert (type= intersect
(specifier-type '(and sb-kernel
::character-string
(not simple-array
))))))
479 (let ((intersect (type-intersection not-ss cs
)))
480 (assert (array-type-p intersect
))
481 (assert (type= intersect
(specifier-type '(and sb-kernel
::character-string
(not simple-array
)))))))
484 (let ((s (specifier-type 'string
))
485 (not-ss (specifier-type '(not simple-string
))))
486 (let ((intersect (type-intersection s not-ss
)))
487 (assert (union-type-p intersect
))
488 (assert (type= intersect
(specifier-type '(and string
(not simple-array
))))))
489 (let ((intersect (type-intersection not-ss s
)))
490 (assert (union-type-p intersect
))
491 (assert (type= intersect
(specifier-type '(and string
(not simple-array
)))))))
493 (let ((left (specifier-type '(array bit
(2 2))))
494 (right (specifier-type '(not (simple-array bit
)))))
495 (let ((intersect (type-intersection left right
)))
496 (assert (array-type-p intersect
))
497 (assert (type= intersect
(specifier-type
498 '(and (array bit
(2 2))
499 (not simple-array
)))))))
501 ;;; The instance-typep transform shouldn't need two different lowtag tests
502 ;;; on instance types other than [funcallable-]standard-object.
503 ;;; And for some reason we suppose that STREAM may be either funcallable or not.
504 (dolist (type '(pathname logical-pathname condition
))
505 (multiple-value-bind (answer certain
)
506 (csubtypep (find-classoid type
) (specifier-type 'funcallable-instance
))
507 (assert (and (not answer
) certain
)))
508 (aver (csubtypep (find-classoid type
) (specifier-type 'instance
))))
510 (assert (sb-int:list-elts-eq
'(a b
1) '(a b
1)))
511 (assert (not (sb-int:list-elts-eq
'(foo) '(foo bar
))))
512 (assert (not (sb-int:list-elts-eq
'(foo bar
) '(foo))))
514 (assert (sb-int:list-elements-eql
'(a b
1) '(a b
1)))
515 (assert (sb-int:list-elements-eql
'($
1.0d0 x y
) '($
1.0d0 x y
)))
516 (assert (not (sb-int:list-elements-eql
'(foo) '(foo bar
))))
517 (assert (not (sb-int:list-elements-eql
'(foo bar
) '(foo))))
519 ;;; I frankly have no idea whether we really care about the enumerable bit any more,
520 ;;; because while what it's supposed to mean is "could _this_ type which is not a MEMBER
521 ;;; type be internally represented as a MEMBER type?" Wwhat makes it questionable
522 ;;; is that we seldom or never represent numerics as MEMBER. I do not know if this is a
523 ;;; relic of days long past.
524 (assert (sb-kernel::type-enumerable
525 (sb-kernel:specifier-type
'(and integer
(integer 1 5)))))
526 (assert (sb-kernel::type-enumerable
527 (sb-kernel:specifier-type
'(single-float $
1.0 $
1.0))))