1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (in-package "CL-USER")
15 (declare (notinline mapcar
))
16 (mapcar (lambda (args)
17 (destructuring-bind (obj type-spec result
) args
18 (flet ((matches-result?
(x)
19 (eq (if x t nil
) result
)))
20 (assert (matches-result?
(typep obj type-spec
)))
21 (assert (matches-result?
(sb-kernel:ctypep
23 (sb-kernel:specifier-type
25 '((nil (or null vector
) t
)
26 (nil (or number vector
) nil
)
27 (12 (or null vector
) nil
)
28 (12 (and (or number vector
) real
) t
))))
31 ;;; This test is motivated by bug #195, which previously had (THE REAL
32 ;;; #(1 2 3)) give an error which prints as "This is not a (OR
33 ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)". We ideally want all of the
34 ;;; defined-by-ANSI types to unparse as themselves or at least
35 ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
36 ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
37 ;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
38 (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
69 standard-generic-function
127 floating-point-inexact
130 floating-point-invalid-operation
133 floating-point-overflow
135 floating-point-underflow
137 (dolist (type standard-types
)
138 (format t
"~&~S~%" type
)
139 (assert (not (sb-kernel:unknown-type-p
(sb-kernel:specifier-type type
))))
140 (assert (atom (sb-kernel:type-specifier
(sb-kernel:specifier-type type
))))))
142 ;;; a bug underlying the reported bug #221: The SB-KERNEL type code
143 ;;; signalled an error on this expression.
144 (subtypep '(function (fixnum) (values package boolean
))
145 '(function (t) (values package boolean
)))
147 ;;; bug reported by Valtteri Vuorik
148 (compile nil
'(lambda () (member (char "foo" 0) '(#\.
#\
/) :test
#'char
=)))
149 (assert (not (equal (multiple-value-list
150 (subtypep '(function ()) '(function (&rest t
))))
153 (assert (not (equal (multiple-value-list
154 (subtypep '(function (&rest t
)) '(function ())))
157 (assert (subtypep '(function)
158 '(function (&optional
* &rest t
))))
159 (assert (equal (multiple-value-list
160 (subtypep '(function)
161 '(function (t &rest t
))))
163 (assert (and (subtypep 'function
'(function))
164 (subtypep '(function) 'function
)))
166 ;;; Absent any exciting generalizations of |R, the type RATIONAL is
167 ;;; partitioned by RATIO and INTEGER. Ensure that the type system
168 ;;; knows about this. [ the type system is permitted to return NIL,
169 ;;; NIL for these, so if future maintenance breaks these tests that
170 ;;; way, that's fine. What the SUBTYPEP calls are _not_ allowed to
171 ;;; return is NIL, T, because that's completely wrong. ]
172 (assert (subtypep '(or integer ratio
) 'rational
))
173 (assert (subtypep 'rational
'(or integer ratio
)))
174 ;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
176 (assert (subtypep t
'(or real
(not real
))))
177 (assert (subtypep t
'(or keyword
(not keyword
))))
178 (assert (subtypep '(and cons
(not (cons symbol integer
)))
179 '(or (cons (not symbol
) *) (cons * (not integer
)))))
180 (assert (subtypep '(or (cons (not symbol
) *) (cons * (not integer
)))
181 '(and cons
(not (cons symbol integer
)))))
182 (assert (subtypep '(or (eql 0) (rational (0) 10))
184 (assert (subtypep '(rational 0 10)
185 '(or (eql 0) (rational (0) 10))))
186 ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
187 ;;; same type gave exceedingly wrong results
188 (assert (null (subtypep '(or (cons fixnum single-float
)
189 (cons bignum single-float
))
190 '(cons single-float single-float
))))
191 (assert (subtypep '(cons integer single-float
)
192 '(or (cons fixnum single-float
) (cons bignum single-float
))))
194 (assert (not (nth-value 1 (subtypep '(and null some-unknown-type
)
195 'another-unknown-type
))))
198 (dolist (fun '(and if
))
199 (assert (raises-error?
(coerce fun
'function
) type-error
)))
202 (let ((x (make-array 0 :element-type
`(unsigned-byte ,(1+ i
)))))
203 (eval `(typep ,x
(class-of ,x
)))))
205 (assert (not (typep #c
(1 2) '(member #c
(2 1)))))
206 (assert (typep #c
(1 2) '(member #c
(1 2))))
207 (assert (subtypep 'nil
'(complex nil
)))
208 (assert (subtypep '(complex nil
) 'nil
))
209 (assert (subtypep 'nil
'(complex (eql 0))))
210 (assert (subtypep '(complex (eql 0)) 'nil
))
211 (assert (subtypep 'nil
'(complex (integer 0 0))))
212 (assert (subtypep '(complex (integer 0 0)) 'nil
))
213 (assert (subtypep 'nil
'(complex (rational 0 0))))
214 (assert (subtypep '(complex (rational 0 0)) 'nil
))
215 (assert (subtypep 'complex
'(complex real
)))
216 (assert (subtypep '(complex real
) 'complex
))
217 (assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
218 (assert (subtypep '(complex ratio
) '(complex rational
)))
219 (assert (subtypep '(complex ratio
) 'complex
))
220 (assert (equal (multiple-value-list
221 (subtypep '(complex (integer 1 2))
222 '(member #c
(1 1) #c
(1 2) #c
(2 1) #c
(2 2))))
225 (assert (typep 0 '(real #.
(ash -
1 10000) #.
(ash 1 10000))))
226 (assert (subtypep '(real #.
(ash -
1 1000) #.
(ash 1 1000))
227 '(real #.
(ash -
1 10000) #.
(ash 1 10000))))
228 (assert (subtypep '(real (#.
(ash -
1 1000)) (#.
(ash 1 1000)))
229 '(real #.
(ash -
1 1000) #.
(ash 1 1000))))
231 ;;; Bug, found by Paul F. Dietz
232 (let* ((x (eval #c
(-1 1/2)))
234 (assert (subtypep type
'(complex rational
)))
235 (assert (typep x type
)))
237 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
239 ;;; Fear the Loop of Doom!
241 ;;; (In fact, this is such a fearsome loop that executing it with the
242 ;;; evaluator would take ages... Disable it under those circumstances.)
243 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
246 (flet ((brute-force (a b c d op minimize
)
247 (loop with extreme
= (if minimize
(ash 1 bits
) 0)
248 with collector
= (if minimize
#'min
#'max
)
249 for i from a upto b do
250 (loop for j from c upto d do
251 (setf extreme
(funcall collector
254 finally
(return extreme
))))
255 (dolist (op '(logand logior logxor
))
256 (dolist (minimize '(t nil
))
257 (let ((deriver (intern (format nil
"~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
259 (find-package :sb-c
))))
260 (format t
"testing type derivation: ~A~%" deriver
)
261 (loop for a from
0 below size do
262 (loop for b from a below size do
263 (loop for c from
0 below size do
264 (loop for d from c below size do
265 (let* ((brute (brute-force a b c d op minimize
))
266 (x-type (sb-c::specifier-type
`(integer ,a
,b
)))
267 (y-type (sb-c::specifier-type
`(integer ,c
,d
)))
268 (derived (funcall deriver x-type y-type
)))
269 (unless (= brute derived
)
270 (format t
"FAIL: ~A [~D,~D] [~D,~D] ~A~%
271 ACTUAL ~D DERIVED ~D~%"
272 op a b c d minimize brute derived
)
273 (assert (= brute derived
)))))))))))))
275 ;;; subtypep on CONS types wasn't taking account of the fact that a
276 ;;; CONS type could be the empty type (but no other non-CONS type) in
278 (multiple-value-bind (yes win
)
279 (subtypep '(and function stream
) 'nil
)
280 (multiple-value-bind (cyes cwin
)
281 (subtypep '(cons (and function stream
) t
)
283 (assert (eq yes cyes
))
284 (assert (eq win cwin
))))
286 ;;; CONS type subtypep could be too enthusiastic about thinking it was
288 (multiple-value-bind (yes win
)
289 (subtypep '(satisfies foo
) '(satisfies bar
))
292 (multiple-value-bind (cyes cwin
)
293 (subtypep '(cons (satisfies foo
) t
)
294 '(cons (satisfies bar
) t
))
296 (assert (null cwin
))))
298 (multiple-value-bind (yes win
)
299 (subtypep 'generic-function
'function
)
302 ;;; this would be in some internal test suite like type.before-xc.lisp
303 ;;; except that generic functions don't exist at that stage.
304 (multiple-value-bind (yes win
)
305 (subtypep 'generic-function
'sb-kernel
:funcallable-instance
)
309 ;;; all sorts of answers are right for this one, but it used to
310 ;;; trigger an AVER instead.
311 (subtypep '(function ()) '(and (function ()) (satisfies identity
)))
313 (assert (sb-kernel:unknown-type-p
(sb-kernel:specifier-type
'an-unkown-type
)))
317 (sb-kernel:specifier-type
'(or (simple-array an-unkown-type
(*))
318 (simple-array an-unkown-type
)))
319 (sb-kernel:specifier-type
'(or (simple-array an-unkown-type
(*))
320 (simple-array an-unkown-type
)))))
324 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))
325 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))))
330 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))
331 (sb-kernel:specifier-type
'(array an-unkown-type
(*))))))
336 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(7)))
337 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(8))))))
340 (sb-kernel:type
/= (sb-kernel:specifier-type
'cons
)
341 (sb-kernel:specifier-type
'(cons single-float single-float
))))
343 (multiple-value-bind (match win
)
344 (sb-kernel:type
= (sb-kernel:specifier-type
'(cons integer
))
345 (sb-kernel:specifier-type
'(cons)))
346 (assert (and (not match
) win
)))
348 (assert (typep #p
"" 'sb-kernel
:instance
))
349 (assert (subtypep '(member #p
"") 'sb-kernel
:instance
))
351 (with-test (:name
(:typep
:character-set
:negation
))
352 (flet ((generate-chars ()
354 collect
(code-char (random char-code-limit
)))))
356 (let* ((chars (generate-chars))
357 (type `(member ,@chars
))
358 (not-type `(not ,type
)))
360 (assert (typep char type
))
361 (assert (not (typep char not-type
))))
362 (let ((other-chars (generate-chars)))
363 (dolist (char other-chars
)
364 (unless (member char chars
)
365 (assert (not (typep char type
)))
366 (assert (typep char not-type
)))))))))
368 (with-test (:name
(:check-type
:store-value
:complex-place
))
369 (let ((a (cons 0.0 2))
370 (handler-invoked nil
))
371 (handler-bind ((error
374 (assert (not handler-invoked
))
375 (setf handler-invoked t
)
376 (invoke-restart 'store-value
1))))
377 (check-type (car a
) integer
))
378 (assert (eql (car a
) 1))))
380 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
381 ;;; the first ASSERT below. The second ASSERT takes care that the fix
382 ;;; doesn't overshoot the mark.
383 (with-test (:name
(:typep
:fixnum-if-unsigned-byte
))
384 (let ((f (compile nil
386 (declare (type (unsigned-byte #.sb-vm
:n-word-bits
) x
))
387 (typep x
(quote fixnum
))))))
388 (assert (not (funcall f
(1+ most-positive-fixnum
))))
389 (assert (funcall f most-positive-fixnum
))))
391 (with-test (:name
(:typep
:member-uses-eql
))
392 (assert (eval '(typep 1/3 '(member 1/3 nil
))))
393 (assert (eval '(typep 1.0 '(member 1.0 t
))))
394 (assert (eval '(typep #c
(1.1
1.2) '(member #c
(1.1
1.2)))))
395 (assert (eval '(typep #c
(1 1) '(member #c
(1 1)))))
396 (let ((bignum1 (+ 12 most-positive-fixnum
))
397 (bignum2 (- (+ 15 most-positive-fixnum
) 3)))
398 (assert (eval `(typep ,bignum1
'(member ,bignum2
))))))
400 (with-test (:name
:opt
+rest
+key-canonicalization
)
401 (let ((type '(function (&optional t
&rest t
&key
(:x t
) (:y t
)) *)))
402 (assert (equal type
(sb-kernel:type-specifier
(sb-kernel:specifier-type type
))))))