1 ;;;; tests of the type system, intended to be executed as soon as
2 ;;;; the cross-compiler is built
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (in-package "SB!KERNEL")
17 (/show "beginning tests/type.before-xc.lisp")
19 (assert (type= (specifier-type '(and fixnum (satisfies foo)))
20 (specifier-type '(and (satisfies foo) fixnum))))
21 (assert (type= (specifier-type '(member 1 2 3))
22 (specifier-type '(member 2 3 1))))
23 (assert (type= (specifier-type '(and (member 1.0 2 3) single-float))
24 (specifier-type '(member 1.0))))
26 (assert (sb-xc:typep #(1 2 3) 'simple-vector))
27 (assert (sb-xc:typep #(1 2 3) 'vector))
28 (assert (not (sb-xc:typep '(1 2 3) 'vector)))
29 (assert (not (sb-xc:typep 1 'vector)))
31 (assert (sb-xc:typep '(1 2 3) 'list))
32 (assert (sb-xc:typep '(1 2 3) 'cons))
33 (assert (not (sb-xc:typep '(1 2 3) 'null)))
34 (assert (not (sb-xc:typep "1 2 3" 'list)))
35 (assert (not (sb-xc:typep 1 'list)))
37 (assert (sb-xc:typep nil 'null))
38 (assert (sb-xc:typep nil '(member nil)))
39 (assert (sb-xc:typep nil '(member 1 2 nil 3)))
40 (assert (not (sb-xc:typep nil '(member 1 2 3))))
42 (assert (type= *empty-type*
43 (type-intersection (specifier-type 'list)
44 (specifier-type 'vector))))
45 (assert (eql *empty-type*
46 (type-intersection (specifier-type 'list)
47 (specifier-type 'vector))))
48 (assert (type= (specifier-type 'null)
49 (type-intersection (specifier-type 'list)
50 (specifier-type '(or vector null)))))
51 (assert (type= (specifier-type 'null)
52 (type-intersection (specifier-type 'sequence)
53 (specifier-type 'symbol))))
54 (assert (type= (specifier-type 'cons)
55 (type-intersection (specifier-type 'sequence)
56 (specifier-type '(or cons number)))))
57 (assert (eql *empty-type*
58 (type-intersection (specifier-type '(satisfies keywordp))
61 ;;; Identities should be identities.
62 (dolist (type-specifier '(nil
69 (and symbol (satisfies foo))
70 (and (satisfies foo) string)
72 (or single-float character)
73 (or float (satisfies bar))
75 character standard-char
77 (/show type-specifier)
78 (let ((ctype (specifier-type type-specifier)))
80 (assert (eql *empty-type* (type-intersection ctype *empty-type*)))
81 (assert (eql *empty-type* (type-intersection *empty-type* ctype)))
82 (assert (eql *empty-type* (type-intersection2 ctype *empty-type*)))
83 (assert (eql *empty-type* (type-intersection2 *empty-type* ctype)))
85 (assert (type= ctype (type-intersection ctype *universal-type*)))
86 (assert (type= ctype (type-intersection *universal-type* ctype)))
87 (assert (type= ctype (type-intersection2 ctype *universal-type*)))
88 (assert (type= ctype (type-intersection2 *universal-type* ctype)))
90 ;; FIXME: TYPE-UNION still acts CMU-CL-ish as of 0.6.11.13, so
91 ;; e.g. (TYPE-UNION #<HAIRY-TYPE (SATISFIES KEYWORDP)> *EMPTY-TYPE*)
92 ;; returns a UNION-TYPE instead of the HAIRY-TYPE. When that's
93 ;; fixed, these tests should be enabled.
94 ;;(assert (eql ctype (type-union ctype *empty-type*)))
95 ;;(assert (eql ctype (type-union *empty-type* ctype)))
97 ;; FIXME: TYPE-UNION2 is not defined yet as of 0.6.11.13, and when
98 ;; it's defined, these tests should be enabled.
99 ;;(assert (eql *empty-type* (type-union2 ctype *empty-type*)))
100 ;;(assert (eql *empty-type* (type-union2 *empty-type* ctype)))
102 ;;(assert (eql *universal-type* (type-union ctype *universal-type*)))
103 ;;(assert (eql *universal-type* (type-union *universal-type* ctype)))
104 ;;(assert (eql ctype (type-union2 ctype *universal-type*)))
105 ;;(assert (eql ctype (type-union2 *universal-type* ctype)))
107 (assert (csubtypep *empty-type* ctype))
108 (assert (csubtypep ctype *universal-type*))))
109 (/show "finished with identities-should-be-identities block")
111 (assert (sb-xc:subtypep 'simple-vector 'vector))
112 (assert (sb-xc:subtypep 'simple-vector 'simple-array))
113 (assert (sb-xc:subtypep 'vector 'array))
114 (assert (not (sb-xc:subtypep 'vector 'simple-vector)))
115 (assert (not (sb-xc:subtypep 'vector 'simple-array)))
117 (macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr)))))
118 (assert-secondnil (sb-xc:subtypep t '(satisfies foo)))
119 (assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar))))
120 (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar))))
121 ;; FIXME: Enable these tests when bug 84 is fixed.
123 (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil))
124 (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar))
126 (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
130 ;;; tests of 2-value quantifieroids FOO/TYPE
131 (macrolet ((2= (v1 v2 expr2)
134 `(multiple-value-bind (,x1 ,x2) ,expr2
135 (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2))
136 (error "mismatch for EXPR2=~S" ',expr2))))))
137 (flet (;; SUBTYPEP running in the cross-compiler
139 (csubtypep (specifier-type x)
140 (specifier-type y))))
141 (2= t t (any/type #'xsubtypep 'fixnum '(real integer)))
142 (2= t t (any/type #'xsubtypep 'fixnum '(real cons)))
143 (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector)))
144 (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
145 (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
146 (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
147 (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
148 (2= nil t (any/type #'xsubtypep 'fixnum '()))
149 (2= t t (every/type #'xsubtypep 'fixnum '()))
150 (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
151 (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
152 (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
153 (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
154 (2= t t (every/type #'xsubtypep 'fixnum '(real integer)))
155 (2= nil t (every/type #'xsubtypep 'fixnum '(real cons)))
156 (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector)))))
158 ;;; various dead bugs
159 (assert (union-type-p (type-intersection (specifier-type 'list)
160 (specifier-type '(or list vector)))))
161 (assert (type= (type-intersection (specifier-type 'list)
162 (specifier-type '(or list vector)))
163 (specifier-type 'list)))
164 (assert (array-type-p (type-intersection (specifier-type 'vector)
165 (specifier-type '(or list vector)))))
166 (assert (type= (type-intersection (specifier-type 'vector)
167 (specifier-type '(or list vector)))
168 (specifier-type 'vector)))
169 (assert (type= (type-intersection (specifier-type 'number)
170 (specifier-type 'integer))
171 (specifier-type 'integer)))
172 (assert (null (type-intersection2 (specifier-type 'symbol)
173 (specifier-type '(satisfies foo)))))
174 (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo)))))
176 (/show "done with tests/type.before-xc.lisp")