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 (with-test (:name
:coerce-function-on-macro
)
199 (dolist (fun '(and if
))
200 (assert-error (coerce fun
'function
))))
203 (let ((x (make-array 0 :element-type
`(unsigned-byte ,(1+ i
)))))
204 (eval `(typep ,x
(class-of ,x
)))))
206 (assert (not (typep #c
(1 2) '(member #c
(2 1)))))
207 (assert (typep #c
(1 2) '(member #c
(1 2))))
208 (assert (subtypep 'nil
'(complex nil
)))
209 (assert (subtypep '(complex nil
) 'nil
))
210 (assert (subtypep 'nil
'(complex (eql 0))))
211 (assert (subtypep '(complex (eql 0)) 'nil
))
212 (assert (subtypep 'nil
'(complex (integer 0 0))))
213 (assert (subtypep '(complex (integer 0 0)) 'nil
))
214 (assert (subtypep 'nil
'(complex (rational 0 0))))
215 (assert (subtypep '(complex (rational 0 0)) 'nil
))
216 (assert (subtypep 'complex
'(complex real
)))
217 (assert (subtypep '(complex real
) 'complex
))
218 (assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
219 (assert (subtypep '(complex ratio
) '(complex rational
)))
220 (assert (subtypep '(complex ratio
) 'complex
))
221 (assert (equal (multiple-value-list
222 (subtypep '(complex (integer 1 2))
223 '(member #c
(1 1) #c
(1 2) #c
(2 1) #c
(2 2))))
226 (assert (typep 0 '(real #.
(ash -
1 10000) #.
(ash 1 10000))))
227 (assert (subtypep '(real #.
(ash -
1 1000) #.
(ash 1 1000))
228 '(real #.
(ash -
1 10000) #.
(ash 1 10000))))
229 (assert (subtypep '(real (#.
(ash -
1 1000)) (#.
(ash 1 1000)))
230 '(real #.
(ash -
1 1000) #.
(ash 1 1000))))
232 ;;; Bug, found by Paul F. Dietz
233 (let* ((x (eval #c
(-1 1/2)))
235 (assert (subtypep type
'(complex rational
)))
236 (assert (typep x type
)))
238 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
240 ;;; Fear the Loop of Doom!
242 ;;; (In fact, this is such a fearsome loop that executing it with the
243 ;;; evaluator would take ages... Disable it under those circumstances.)
244 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
245 (with-test (:name
(:type-derivation
:logical-operations
:correctness
))
247 (size (ash 1 n-bits
)))
248 (labels ((brute-force (a b c d op
)
249 (loop with min
= (ash 1 n-bits
)
251 for i from a upto b do
252 (loop for j from c upto d do
253 (let ((x (funcall op i j
)))
254 (setf min
(min min x
)
256 finally
(return (values min max
))))
257 (test (a b c d op deriver
)
258 (multiple-value-bind (brute-low brute-high
)
259 (brute-force a b c d op
)
260 (multiple-value-bind (test-low test-high
)
262 (sb-c::specifier-type
`(integer ,a
,b
))
263 (sb-c::specifier-type
`(integer ,c
,d
)))
264 (unless (and (= brute-low test-low
)
265 (= brute-high test-high
))
266 (format t
"FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
268 brute-low brute-high test-low test-high
)
269 (assert (and (= brute-low test-low
)
270 (= brute-high test-high
))))))))
271 (dolist (op '(logand logior logxor
))
272 (let ((deriver (intern (format nil
"~A-DERIVE-UNSIGNED-BOUNDS" op
)
273 (find-package :sb-c
))))
274 (format t
"testing type derivation: ~A~%" deriver
)
275 (loop for a from
0 below size do
276 (loop for b from a below size do
277 (loop for c from
0 below size do
278 (loop for d from c below size do
279 (test a b c d op deriver
))))))))))
281 (with-test (:name
(:type-derivation
:logical-operations
:scaling
))
282 (let ((type-x1 (sb-c::specifier-type
`(integer ,(expt 2 10000)
284 (type-x2 (sb-c::specifier-type
`(integer ,(expt 2 100000)
286 (type-y (sb-c::specifier-type
'(integer 0 1))))
287 (dolist (op '(logand logior logxor
))
288 (let* ((deriver (intern (format nil
"~A-DERIVE-TYPE-AUX" op
)
289 (find-package :sb-c
)))
290 (scale (/ (runtime (funcall deriver type-x2 type-y
))
291 (runtime (funcall deriver type-x1 type-y
)))))
292 ;; Linear scaling is good, quadratical bad. Draw the line
293 ;; near the geometric mean of the corresponding SCALEs.
295 (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
298 ;;; subtypep on CONS types wasn't taking account of the fact that a
299 ;;; CONS type could be the empty type (but no other non-CONS type) in
301 (multiple-value-bind (yes win
)
302 (subtypep '(and function stream
) 'nil
)
303 (multiple-value-bind (cyes cwin
)
304 (subtypep '(cons (and function stream
) t
)
306 (assert (eq yes cyes
))
307 (assert (eq win cwin
))))
309 ;;; CONS type subtypep could be too enthusiastic about thinking it was
311 (multiple-value-bind (yes win
)
312 (subtypep '(satisfies foo
) '(satisfies bar
))
315 (multiple-value-bind (cyes cwin
)
316 (subtypep '(cons (satisfies foo
) t
)
317 '(cons (satisfies bar
) t
))
319 (assert (null cwin
))))
321 (multiple-value-bind (yes win
)
322 (subtypep 'generic-function
'function
)
325 ;;; this would be in some internal test suite like type.before-xc.lisp
326 ;;; except that generic functions don't exist at that stage.
327 (multiple-value-bind (yes win
)
328 (subtypep 'generic-function
'sb-kernel
:funcallable-instance
)
332 ;;; all sorts of answers are right for this one, but it used to
333 ;;; trigger an AVER instead.
334 (subtypep '(function ()) '(and (function ()) (satisfies identity
)))
336 (assert (sb-kernel:unknown-type-p
(sb-kernel:specifier-type
'an-unkown-type
)))
340 (sb-kernel:specifier-type
'(or (simple-array an-unkown-type
(*))
341 (simple-array an-unkown-type
)))
342 (sb-kernel:specifier-type
'(or (simple-array an-unkown-type
(*))
343 (simple-array an-unkown-type
)))))
347 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))
348 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))))
353 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(*)))
354 (sb-kernel:specifier-type
'(array an-unkown-type
(*))))))
359 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(7)))
360 (sb-kernel:specifier-type
'(simple-array an-unkown-type
(8))))))
363 (sb-kernel:type
/= (sb-kernel:specifier-type
'cons
)
364 (sb-kernel:specifier-type
'(cons single-float single-float
))))
366 (multiple-value-bind (match win
)
367 (sb-kernel:type
= (sb-kernel:specifier-type
'(cons integer
))
368 (sb-kernel:specifier-type
'(cons)))
369 (assert (and (not match
) win
)))
371 (assert (typep #p
"" 'sb-kernel
:instance
))
372 (assert (subtypep '(member #p
"") 'sb-kernel
:instance
))
374 (with-test (:name
(:typep
:character-set
:negation
))
375 (flet ((generate-chars ()
377 collect
(code-char (random char-code-limit
)))))
379 (let* ((chars (generate-chars))
380 (type `(member ,@chars
))
381 (not-type `(not ,type
)))
383 (assert (typep char type
))
384 (assert (not (typep char not-type
))))
385 (let ((other-chars (generate-chars)))
386 (dolist (char other-chars
)
387 (unless (member char chars
)
388 (assert (not (typep char type
)))
389 (assert (typep char not-type
)))))))))
391 (with-test (:name
(:check-type
:store-value
:complex-place
))
392 (let ((a (cons 0.0 2))
393 (handler-invoked nil
))
394 (handler-bind ((error
397 (assert (not handler-invoked
))
398 (setf handler-invoked t
)
399 (invoke-restart 'store-value
1))))
400 (check-type (car a
) integer
))
401 (assert (eql (car a
) 1))))
403 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
404 ;;; the first ASSERT below. The second ASSERT takes care that the fix
405 ;;; doesn't overshoot the mark.
406 (with-test (:name
(:typep
:fixnum-if-unsigned-byte
))
407 (let ((f (compile nil
409 (declare (type (unsigned-byte #.sb-vm
:n-word-bits
) x
))
410 (typep x
(quote fixnum
))))))
411 (assert (not (funcall f
(1+ most-positive-fixnum
))))
412 (assert (funcall f most-positive-fixnum
))))
414 (with-test (:name
(:typep
:member-uses-eql
))
415 (assert (eval '(typep 1/3 '(member 1/3 nil
))))
416 (assert (eval '(typep 1.0 '(member 1.0 t
))))
417 (assert (eval '(typep #c
(1.1
1.2) '(member #c
(1.1
1.2)))))
418 (assert (eval '(typep #c
(1 1) '(member #c
(1 1)))))
419 (let ((bignum1 (+ 12 most-positive-fixnum
))
420 (bignum2 (- (+ 15 most-positive-fixnum
) 3)))
421 (assert (eval `(typep ,bignum1
'(member ,bignum2
))))))
423 (with-test (:name
:opt
+rest
+key-canonicalization
)
424 (let ((type '(function (&optional t
&rest t
&key
(:x t
) (:y t
)) *)))
425 (assert (equal type
(sb-kernel:type-specifier
(sb-kernel:specifier-type type
))))))
427 (with-test (:name
:bug-369
)
428 (let ((types (mapcar #'sb-c
::values-specifier-type
429 '((values (vector package
) &optional
)
430 (values (vector package
) &rest t
)
431 (values (vector hash-table
) &rest t
)
432 (values (vector hash-table
) &optional
)
435 (values nil
&optional
)
437 (values sequence
&optional
)
438 (values sequence
&rest t
)
439 (values list
&optional
)
440 (values list
&rest t
)))))
443 (let ((i (sb-c::values-type-intersection x y
)))
444 (assert (sb-c::type
= i
(sb-c::values-type-intersection i x
)))
445 (assert (sb-c::type
= i
(sb-c::values-type-intersection i y
))))))))
447 (with-test (:name
:bug-485972
)
448 (assert (equal (multiple-value-list (subtypep 'symbol
'keyword
)) '(nil t
)))
449 (assert (equal (multiple-value-list (subtypep 'keyword
'symbol
)) '(t t
))))
451 ;; WARNING: this test case would fail by recursing into the stack's guard page.
452 (with-test (:name
:bug-883498
)
453 (sb-kernel:specifier-type
455 (AND (SATISFIES FOO
) (RATIONAL -
3/2 -
3/2)))))
457 ;; The infinite recursion mentioned in the previous test was caused by an
458 ;; attempt to get the following right.
459 (with-test (:name
:quirky-integer-rational-union
)
460 (assert (subtypep `(or (integer * -
1)
461 (and (rational * -
1/2) (not integer
)))
463 (assert (subtypep `(rational * -
1/2)
465 (and (rational * -
1/2) (not integer
))))))
467 ;; for the longest time (at least 05525d3a), single-value-type would
468 ;; return CHARACTER on this.
469 (with-test (:name
:single-value-
&optional-type
)
470 (assert (sb-c::type
= (sb-c::single-value-type
471 (sb-c::values-specifier-type
'(values &optional character
)))
472 (sb-c::specifier-type
'(or null character
)))))
474 ;; lp#1317308 - TYPE-OF must not return a type specifier
475 ;; involving AND,EQL,MEMBER,NOT,OR,SATISFIES,or VALUES.
476 (with-test (:name
:ANSIly-report-hairy-array-type
)
477 (let ((simp-t (make-array 9))
478 (simp-bit (make-array 16 :element-type
'bit
)))
479 ;; TYPE-OF doesn't have an optimization that returns a constant specifier
480 ;; from a non-constant array of known type. If it did, we'd probably
481 ;; want to check that these results are all equal:
482 ;; - the runtime-determined type
483 ;; - the compile-time-determined constant type
484 ;; - the compile-time-determined type of an equivalent object
485 ;; that is in fact a compile-time constant
486 (flet ((our-type-of (x) (sb-kernel:type-specifier
(sb-kernel:ctype-of x
))))
487 (let ((hairy-t (make-array 3 :displaced-to simp-t
)))
488 (assert (equal (our-type-of hairy-t
)
489 '(and (vector t
3) (not simple-array
))))
490 (assert (equal (type-of hairy-t
) '(vector t
3))))
491 (let ((hairy-t (make-array '(3 2) :displaced-to simp-t
)))
492 (assert (equal (our-type-of hairy-t
)
493 '(and (array t
(3 2)) (not simple-array
))))
494 (assert (equal (type-of hairy-t
) '(array t
(3 2)))))
496 (make-array 5 :displaced-to simp-bit
:element-type
'bit
)))
497 (assert (equal (our-type-of hairy-bit
)
498 '(and (bit-vector 5) (not simple-array
))))
499 (assert (equal (type-of hairy-bit
) '(bit-vector 5)))))))
501 (with-test (:name
:bug-309098
)
502 (let ((u `(or ,@(map 'list
(lambda (x) `(array ,(sb-vm:saetp-specifier x
)))
503 sb-vm
:*specialized-array-element-type-properties
*))))
504 (assert (equal (multiple-value-list (subtypep 'array u
)) '(t t
)))))
506 (with-test (:name
:bug-1258716
)
507 (let ((intersection (sb-kernel:type-intersection
508 (sb-kernel:specifier-type
'simple-vector
)
509 (sb-kernel:specifier-type
`(vector #:unknown
)))))
510 (assert (sb-kernel:array-type-p intersection
))
511 ;; and not *wild-type*
512 (assert (sb-kernel:type
= (sb-kernel:array-type-specialized-element-type intersection
)
513 sb-kernel
:*universal-type
*))))
515 (with-test (:name
:parse-safely
)
516 (dolist (x '(array integer cons
))
517 (assert (handler-case (sb-kernel:specifier-type
`(,x .
0))
518 (sb-kernel::arg-count-error
() t
)
519 (error (c) (print c
) nil
)))))
521 (with-test (:name
:unparse-safely
)
522 (let* ((intersection (sb-kernel:type-intersection
523 (sb-kernel:specifier-type
'(vector (or bit character
)))
524 (sb-kernel:specifier-type
`(vector (or bit symbol
)))))
525 (round-trip (sb-kernel:specifier-type
526 (sb-kernel:type-specifier intersection
))))
527 (assert (sb-kernel:type
= intersection round-trip
))
528 (assert (sb-kernel:array-type-p intersection
))
529 ;; and not *wild-type*
530 (assert (sb-kernel:type
/= (sb-kernel:array-type-specialized-element-type intersection
)
531 (sb-kernel:specifier-type
'bit
)))))
534 (with-test (:name
:adjust-array-changes-type-of
)
535 (let ((a (make-array 10 :adjustable t
)))
536 (assert (equal (type-of a
) '(vector t
10)))
538 (assert (equal (type-of a
) '(vector t
20)))))
540 (in-package "SB-KERNEL")
541 (test-util:with-test
(:name
:partition-array-into-simple
/hairy
)
542 ;; Some tests that (simple-array | hairy-array) = array
543 ;; At present this works only for wild element-type.
544 (multiple-value-bind (eq winp
)
545 (type= (specifier-type '(not (and array
(not simple-array
))))
546 (specifier-type '(or (not array
) simple-array
)))
547 (assert (and eq winp
)))
549 ;; if X is neither simple-array nor hairy-array, it is not an array
550 (assert (type= (specifier-type '(and (not simple-array
)
551 (not (and array
(not simple-array
)))))
552 (specifier-type '(not array
))))
554 ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc
555 (flet ((try (unrestricted simple
)
556 (assert (type= (specifier-type simple
)
559 '(not (and array
(not simple-array
))))
560 (specifier-type unrestricted
))))))
561 (try 'vector
'(simple-array * (*)))
562 (try '(vector t
) 'simple-vector
)
563 (try 'bit-vector
'simple-bit-vector
)
564 (try 'string
'simple-string
)
565 #+sb-unicode
(try 'character-string
'simple-character-string
)
566 (try 'base-string
'simple-base-string
))
568 ;; if X is a known string and not an array-header
569 ;; it must be a SIMPLE-STRING
570 (assert (type= (type-intersection
571 (specifier-type 'string
)
573 '(not (or (and simple-array
(not vector
))
574 (and array
(not simple-array
))))))
575 (specifier-type 'simple-string
))))