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)))))))))