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 ;; FIXME: Enable these tests when bug 84 is fixed.
133 (assert-secondnil (sb-xc:subtypep
'(satisfies foo
) nil
))
134 (assert-secondnil (sb-xc:subtypep
'(and (satisfies foo
) (satisfies bar
))
136 (assert-secondnil (sb-xc:subtypep
'(or (satisfies foo
) (satisfies bar
))
140 ;;; tests of 2-value quantifieroids FOO/TYPE
141 (macrolet ((2= (v1 v2 expr2
)
144 `(multiple-value-bind (,x1
,x2
) ,expr2
145 (unless (and (eql ,x1
,v1
) (eql ,x2
,v2
))
146 (error "mismatch for EXPR2=~S" ',expr2
))))))
147 (flet (;; SUBTYPEP running in the cross-compiler
149 (csubtypep (specifier-type x
)
150 (specifier-type y
))))
151 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real integer
)))
152 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real cons
)))
153 (2= nil t
(any/type
#'xsubtypep
'fixnum
'(cons vector
)))
154 (2= nil nil
(any/type
#'xsubtypep
'fixnum
'(cons some-unknown-type-foo
)))
155 (2= nil nil
(any/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo cons
)))
156 (2= t t
(any/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo real
)))
157 (2= t t
(any/type
#'xsubtypep
'fixnum
'(real some-unknown-type-foo
)))
158 (2= nil t
(any/type
#'xsubtypep
'fixnum
'()))
159 (2= t t
(every/type
#'xsubtypep
'fixnum
'()))
160 (2= nil nil
(every/type
#'xsubtypep
'fixnum
'(real some-unknown-type-foo
)))
161 (2= nil nil
(every/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo real
)))
162 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(some-unknown-type-foo cons
)))
163 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(cons some-unknown-type-foo
)))
164 (2= t t
(every/type
#'xsubtypep
'fixnum
'(real integer
)))
165 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(real cons
)))
166 (2= nil t
(every/type
#'xsubtypep
'fixnum
'(cons vector
)))))
168 ;;; various dead bugs
169 (assert (union-type-p (type-intersection (specifier-type 'list
)
170 (specifier-type '(or list vector
)))))
171 (assert (type= (type-intersection (specifier-type 'list
)
172 (specifier-type '(or list vector
)))
173 (specifier-type 'list
)))
174 (assert (array-type-p (type-intersection (specifier-type 'vector
)
175 (specifier-type '(or list vector
)))))
176 (assert (type= (type-intersection (specifier-type 'vector
)
177 (specifier-type '(or list vector
)))
178 (specifier-type 'vector
)))
179 (assert (type= (type-intersection (specifier-type 'number
)
180 (specifier-type 'integer
))
181 (specifier-type 'integer
)))
182 (assert (null (type-intersection2 (specifier-type 'symbol
)
183 (specifier-type '(satisfies foo
)))))
184 (assert (intersection-type-p (specifier-type '(and symbol
(satisfies foo
)))))
185 (assert (ctypep :x86
(specifier-type '(satisfies keywordp
))))
186 (assert (type= (specifier-type '(member :x86
))
187 (specifier-type '(and (member :x86
) (satisfies keywordp
)))))
188 (let* ((type1 (specifier-type '(member :x86
)))
189 (type2 (specifier-type '(or keyword null
)))
190 (isect (type-intersection type1 type2
)))
191 (assert (type= isect type1
))
192 (assert (type= isect
(type-intersection type2 type1
)))
193 (assert (type= isect
(type-intersection type2 type1 type2
)))
194 (assert (type= isect
(type-intersection type1 type1 type2 type1
)))
195 (assert (type= isect
(type-intersection type1 type2 type1 type2
))))
196 (let* ((type1 (specifier-type 'keyword
))
197 (type2 (specifier-type '(or keyword null
)))
198 (isect (type-intersection type1 type2
)))
199 (assert (type= isect type1
))
200 (assert (type= isect
(type-intersection type2 type1
)))
201 (assert (type= isect
(type-intersection type2 type1 type2
)))
202 (assert (type= isect
(type-intersection type1 type1 type2 type1
)))
203 (assert (type= isect
(type-intersection type1 type2 type1 type2
))))
204 (assert (csubtypep (specifier-type '(or (single-float -
1.0 1.0)
206 (specifier-type '(or (real -
1 7)
208 (single-float -
1.0 1.0)))))
209 (assert (not (csubtypep (specifier-type '(or (real -
1 7)
211 (single-float -
1.0 1.0)))
212 (specifier-type '(or (single-float -
1.0 1.0)
213 (single-float 0.1))))))
215 (/show
"done with tests/type.before-xc.lisp")