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))
244 (with-test (:name (:type-derivation :logical-operations :correctness))
246 (size (ash 1 n-bits)))
247 (labels ((brute-force (a b c d op)
248 (loop with min = (ash 1 n-bits)
250 for i from a upto b do
251 (loop for j from c upto d do
252 (let ((x (funcall op i j)))
253 (setf min (min min x)
255 finally (return (values min max))))
256 (test (a b c d op deriver)
257 (multiple-value-bind (brute-low brute-high)
258 (brute-force a b c d op)
259 (multiple-value-bind (test-low test-high)
261 (sb-c::specifier-type `(integer ,a ,b))
262 (sb-c::specifier-type `(integer ,c ,d)))
263 (unless (and (= brute-low test-low)
264 (= brute-high test-high))
265 (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
267 brute-low brute-high test-low test-high)
268 (assert (and (= brute-low test-low)
269 (= brute-high test-high))))))))
270 (dolist (op '(logand logior logxor))
271 (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
272 (find-package :sb-c))))
273 (format t "testing type derivation: ~A~%" deriver)
274 (loop for a from 0 below size do
275 (loop for b from a below size do
276 (loop for c from 0 below size do
277 (loop for d from c below size do
278 (test a b c d op deriver))))))))))
280 (with-test (:name (:type-derivation :logical-operations :scaling))
281 (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
283 (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
285 (type-y (sb-c::specifier-type '(integer 0 1))))
286 (dolist (op '(logand logior logxor))
287 (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
288 (find-package :sb-c)))
289 (scale (/ (runtime (funcall deriver type-x2 type-y))
290 (runtime (funcall deriver type-x1 type-y)))))
291 ;; Linear scaling is good, quadratical bad. Draw the line
292 ;; near the geometric mean of the corresponding SCALEs.
294 (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
297 ;;; subtypep on CONS types wasn't taking account of the fact that a
298 ;;; CONS type could be the empty type (but no other non-CONS type) in
300 (multiple-value-bind (yes win)
301 (subtypep '(and function stream) 'nil)
302 (multiple-value-bind (cyes cwin)
303 (subtypep '(cons (and function stream) t)
305 (assert (eq yes cyes))
306 (assert (eq win cwin))))
308 ;;; CONS type subtypep could be too enthusiastic about thinking it was
310 (multiple-value-bind (yes win)
311 (subtypep '(satisfies foo) '(satisfies bar))
314 (multiple-value-bind (cyes cwin)
315 (subtypep '(cons (satisfies foo) t)
316 '(cons (satisfies bar) t))
318 (assert (null cwin))))
320 (multiple-value-bind (yes win)
321 (subtypep 'generic-function 'function)
324 ;;; this would be in some internal test suite like type.before-xc.lisp
325 ;;; except that generic functions don't exist at that stage.
326 (multiple-value-bind (yes win)
327 (subtypep 'generic-function 'sb-kernel:funcallable-instance)
331 ;;; all sorts of answers are right for this one, but it used to
332 ;;; trigger an AVER instead.
333 (subtypep '(function ()) '(and (function ()) (satisfies identity)))
335 (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type)))
339 (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
340 (simple-array an-unkown-type)))
341 (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
342 (simple-array an-unkown-type)))))
346 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
347 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))
352 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
353 (sb-kernel:specifier-type '(array an-unkown-type (*))))))
358 (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
359 (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
362 (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
363 (sb-kernel:specifier-type '(cons single-float single-float))))
365 (multiple-value-bind (match win)
366 (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
367 (sb-kernel:specifier-type '(cons)))
368 (assert (and (not match) win)))
370 (assert (typep #p"" 'sb-kernel:instance))
371 (assert (subtypep '(member #p"") 'sb-kernel:instance))
373 (with-test (:name (:typep :character-set :negation))
374 (flet ((generate-chars ()
376 collect (code-char (random char-code-limit)))))
378 (let* ((chars (generate-chars))
379 (type `(member ,@chars))
380 (not-type `(not ,type)))
382 (assert (typep char type))
383 (assert (not (typep char not-type))))
384 (let ((other-chars (generate-chars)))
385 (dolist (char other-chars)
386 (unless (member char chars)
387 (assert (not (typep char type)))
388 (assert (typep char not-type)))))))))
390 (with-test (:name (:check-type :store-value :complex-place))
391 (let ((a (cons 0.0 2))
392 (handler-invoked nil))
393 (handler-bind ((error
396 (assert (not handler-invoked))
397 (setf handler-invoked t)
398 (invoke-restart 'store-value 1))))
399 (check-type (car a) integer))
400 (assert (eql (car a) 1))))
402 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
403 ;;; the first ASSERT below. The second ASSERT takes care that the fix
404 ;;; doesn't overshoot the mark.
405 (with-test (:name (:typep :fixnum-if-unsigned-byte))
406 (let ((f (compile nil
408 (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
409 (typep x (quote fixnum))))))
410 (assert (not (funcall f (1+ most-positive-fixnum))))
411 (assert (funcall f most-positive-fixnum))))
413 (with-test (:name (:typep :member-uses-eql))
414 (assert (eval '(typep 1/3 '(member 1/3 nil))))
415 (assert (eval '(typep 1.0 '(member 1.0 t))))
416 (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
417 (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
418 (let ((bignum1 (+ 12 most-positive-fixnum))
419 (bignum2 (- (+ 15 most-positive-fixnum) 3)))
420 (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
422 (with-test (:name :opt+rest+key-canonicalization)
423 (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
424 (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
426 (with-test (:name :bug-369)
427 (let ((types (mapcar #'sb-c::values-specifier-type
428 '((values (vector package) &optional)
429 (values (vector package) &rest t)
430 (values (vector hash-table) &rest t)
431 (values (vector hash-table) &optional)
434 (values nil &optional)
436 (values sequence &optional)
437 (values sequence &rest t)
438 (values list &optional)
439 (values list &rest t)))))
442 (let ((i (sb-c::values-type-intersection x y)))
443 (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
444 (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
446 (with-test (:name :bug-485972)
447 (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
448 (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))
450 ;; WARNING: this test case would fail by recursing into the stack's guard page.
451 (with-test (:name :bug-883498)
452 (sb-kernel:specifier-type
454 (AND (SATISFIES FOO) (RATIONAL -3/2 -3/2)))))
456 ;; The infinite recursion mentioned in the previous test was caused by an
457 ;; attempt to get the following right.
458 (with-test (:name :quirky-integer-rational-union)
459 (assert (subtypep `(or (integer * -1)
460 (and (rational * -1/2) (not integer)))
462 (assert (subtypep `(rational * -1/2)
464 (and (rational * -1/2) (not integer))))))