1.0.19.24: incorrect function type canonicalization
[sbcl/pkhuong.git] / tests / type.pure.lisp
blob36019b2355b6f9767f6e3957a52781b12d5ead34
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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")
14 (locally
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
22 obj
23 (sb-kernel:specifier-type
24 type-spec)))))))
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
39 ;; CLHS.
40 arithmetic-error
41 function
42 simple-condition
43 array
44 generic-function
45 simple-error
46 atom
47 hash-table
48 simple-string
49 base-char
50 integer
51 simple-type-error
52 base-string
53 keyword
54 simple-vector
55 bignum
56 list
57 simple-warning
58 bit
59 logical-pathname
60 single-float
61 bit-vector
62 long-float
63 standard-char
64 broadcast-stream
65 method
66 standard-class
67 built-in-class
68 method-combination
69 standard-generic-function
70 cell-error
71 nil
72 standard-method
73 character
74 null
75 standard-object
76 class
77 number
78 storage-condition
79 compiled-function
80 package
81 stream
82 complex
83 package-error
84 stream-error
85 concatenated-stream
86 parse-error
87 string
88 condition
89 pathname
90 string-stream
91 cons
92 print-not-readable
93 structure-class
94 control-error
95 program-error
96 structure-object
97 division-by-zero
98 random-state
99 style-warning
100 double-float
101 ratio
102 symbol
103 echo-stream
104 rational
105 synonym-stream
106 end-of-file
107 reader-error
109 error
110 readtable
111 two-way-stream
112 extended-char
113 real
114 type-error
115 file-error
116 restart
117 unbound-slot
118 file-stream
119 sequence
120 unbound-variable
121 fixnum
122 serious-condition
123 undefined-function
124 float
125 short-float
126 unsigned-byte
127 floating-point-inexact
128 signed-byte
129 vector
130 floating-point-invalid-operation
131 simple-array
132 warning
133 floating-point-overflow
134 simple-base-string
135 floating-point-underflow
136 simple-bit-vector)))
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))))
151 '(nil t))))
153 (assert (not (equal (multiple-value-list
154 (subtypep '(function (&rest t)) '(function ())))
155 '(t t))))
157 (assert (subtypep '(function)
158 '(function (&optional * &rest t))))
159 (assert (equal (multiple-value-list
160 (subtypep '(function)
161 '(function (t &rest t))))
162 '(nil 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
175 ;;; return NIL, 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))
183 '(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))))
197 ;;; bug 46c
198 (dolist (fun '(and if))
199 (assert (raises-error? (coerce fun 'function) type-error)))
201 (dotimes (i 100)
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))))
223 '(nil t)))
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)))
233 (type (type-of x)))
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 (let* ((bits 5)
245 (size (ash 1 bits)))
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
252 extreme
253 (funcall op i j))))
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"
258 op minimize)
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
277 ;;; disguise.
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)
282 '(cons nil t))
283 (assert (eq yes cyes))
284 (assert (eq win cwin))))
286 ;;; CONS type subtypep could be too enthusiastic about thinking it was
287 ;;; certain
288 (multiple-value-bind (yes win)
289 (subtypep '(satisfies foo) '(satisfies bar))
290 (assert (null yes))
291 (assert (null win))
292 (multiple-value-bind (cyes cwin)
293 (subtypep '(cons (satisfies foo) t)
294 '(cons (satisfies bar) t))
295 (assert (null cyes))
296 (assert (null cwin))))
298 (multiple-value-bind (yes win)
299 (subtypep 'generic-function 'function)
300 (assert yes)
301 (assert win))
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)
306 (assert yes)
307 (assert win))
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)))
315 (assert
316 (sb-kernel: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)))))
322 (assert
323 (sb-kernel:type=
324 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
325 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))
327 (assert
328 (not
329 (sb-kernel:type=
330 (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
331 (sb-kernel:specifier-type '(array an-unkown-type (*))))))
333 (assert
334 (not
335 (sb-kernel:type=
336 (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
337 (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
339 (assert
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 ()
353 (loop repeat 100
354 collect (code-char (random char-code-limit)))))
355 (dotimes (i 1000)
356 (let* ((chars (generate-chars))
357 (type `(member ,@chars))
358 (not-type `(not ,type)))
359 (dolist (char chars)
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
372 (lambda (c)
373 (declare (ignore c))
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
385 (lambda (x)
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))))))