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!
242 (flet ((brute-force (a b c d op minimize)
243 (loop with extreme = (if minimize (ash 1 bits) 0)
244 with collector = (if minimize #'min #'max)
245 for i from a upto b do
246 (loop for j from c upto d do
247 (setf extreme (funcall collector
250 finally (return extreme))))
251 (dolist (op '(logand logior logxor))
252 (dolist (minimize '(t nil))
253 (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
255 (find-package :sb-c))))
256 (loop for a from 0 below size do
257 (loop for b from a below size do
258 (loop for c from 0 below size do
259 (loop for d from c below size do
260 (let* ((brute (brute-force a b c d op minimize))
261 (x-type (sb-c::specifier-type `(integer ,a ,b)))
262 (y-type (sb-c::specifier-type `(integer ,c ,d)))
263 (derived (funcall deriver x-type y-type)))
264 (unless (= brute derived)
265 (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~%
266 ACTUAL ~D DERIVED ~D~%"
267 op a b c d minimize brute derived)
268 (assert (= brute derived)))))))))))))
270 ;;; subtypep on CONS types wasn't taking account of the fact that a
271 ;;; CONS type could be the empty type (but no other non-CONS type) in
273 (multiple-value-bind (yes win)
274 (subtypep '(and function stream) 'nil)
275 (multiple-value-bind (cyes cwin)
276 (subtypep '(cons (and function stream) t)
278 (assert (eq yes cyes))
279 (assert (eq win cwin))))
281 ;;; CONS type subtypep could be too enthusiastic about thinking it was
283 (multiple-value-bind (yes win)
284 (subtypep '(satisfies foo) '(satisfies bar))
287 (multiple-value-bind (cyes cwin)
288 (subtypep '(cons (satisfies foo) t)
289 '(cons (satisfies bar) t))
291 (assert (null cwin))))