3 (load "assertoid.lisp")
5 (defmacro assert-nil-nil (expr)
6 `(assert (equal '(nil nil) (multiple-value-list ,expr))))
7 (defmacro assert-nil-t (expr)
8 `(assert (equal '(nil t) (multiple-value-list ,expr))))
9 (defmacro assert-t-t (expr)
10 `(assert (equal '(t t) (multiple-value-list ,expr))))
12 (let ((types '(character
13 integer fixnum (integer 0 10)
14 single-float (single-float -1.0 1.0) (single-float 0.1)
15 (real 4 8) (real -1 7) (real 2 11)
16 (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
17 ;; FIXME: When bug 91 is fixed, add these to the list:
20 ;; (RATIONAL -1 7) (RATIONAL -2 4)
24 (format t "type I=~S~%" i)
26 (format t " type J=~S~%" j)
27 (assert (subtypep i `(or ,i ,j)))
28 (assert (subtypep i `(or ,j ,i)))
29 (assert (subtypep i `(or ,i ,i ,j)))
30 (assert (subtypep i `(or ,j ,i)))
32 (format t " type K=~S~%" k)
33 (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
34 (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
36 ;;; gotchas that can come up in handling subtypeness as "X is a
37 ;;; subtype of Y if each of the elements of X is a subtype of Y"
38 (let ((subtypep-values (multiple-value-list
39 (subtypep '(single-float -1.0 1.0)
40 '(or (real -100.0 0.0)
41 (single-float 0.0 100.0))))))
42 (assert (member subtypep-values
43 '(;; The system isn't expected to
44 ;; understand the subtype relationship.
46 ;; But if it does, that'd be neat.
48 ;; (And any other return would be wrong.)
52 (defun type-evidently-= (x y)
56 (assert (subtypep 'single-float 'float))
58 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
60 ;;; Bug 50(c,d): numeric types with empty ranges should be NIL
61 (assert (type-evidently-= 'nil '(integer (0) (0))))
62 (assert (type-evidently-= 'nil '(rational (0) (0))))
63 (assert (type-evidently-= 'nil '(float (0.0) (0.0))))
65 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
66 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
67 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
68 (assert (eql (upgraded-array-element-type t) t))
69 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
70 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
72 ;;; Do reasonable things with undefined types, and with compound types
73 ;;; built from undefined types.
76 (assert (typep #(11) '(simple-array t 1)))
77 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
78 ;;; FIXME: This is broken because of compiler bug 123: the compiler
79 ;;; optimizes the type test to T, so it never gets a chance to raise a
80 ;;; runtime error. (It used to work under the IR1 interpreter just
81 ;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard
82 ;;; as the byte compiler does.)
83 #+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
84 (assert (not (typep 11 '(simple-array undef-type 1))))
86 (assert (subtypep '(vector some-undef-type) 'vector))
87 (assert (not (subtypep '(vector some-undef-type) 'integer)))
88 (assert-nil-nil (subtypep 'utype-1 'utype-2))
89 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
90 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
91 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
93 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
94 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.7.2.
95 (assert (raises-error? (typep 11 'and)))
96 (assert (raises-error? (typep 11 'or)))
98 ;;; Of course empty lists of subtypes are still OK.
99 (assert (typep 11 '(and)))
100 (assert (not (typep 11 '(or))))
102 ;;; bug 12: type system didn't grok nontrivial intersections
103 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
104 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
105 (assert (subtypep 'keyword 'symbol))
106 (assert (not (subtypep 'symbol 'keyword)))
107 (assert (subtypep 'ratio 'real))
108 (assert (subtypep 'ratio 'number))
110 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
111 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
112 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
114 (assert-nil-t (subtypep 'atom 'cons))
115 (assert-nil-t (subtypep 'cons 'atom))
116 (assert-nil-t (subtypep '(not list) 'cons))
117 (assert-nil-t (subtypep '(not float) 'single-float))
118 (assert-t-t (subtypep '(not atom) 'cons))
119 (assert-t-t (subtypep 'cons '(not atom)))
120 ;;; ANSI requires that SUBTYPEP relationships among built-in primitive
121 ;;; types never be uncertain, i.e. never return NIL as second value.
122 ;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
123 ;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
124 ;;; CMU CL's HAIRY-TYPE logic punted a lot).
125 (assert-t-t (subtypep 'integer 'atom))
126 (assert-t-t (subtypep 'function 'atom))
127 (assert-nil-t (subtypep 'list 'atom))
128 (assert-nil-t (subtypep 'atom 'integer))
129 (assert-nil-t (subtypep 'atom 'function))
130 (assert-nil-t (subtypep 'atom 'list))
131 ;;; ATOM is equivalent to (NOT CONS):
132 (assert-t-t (subtypep 'integer '(not cons)))
133 (assert-nil-t (subtypep 'list '(not cons)))
134 (assert-nil-t (subtypep '(not cons) 'integer))
135 (assert-nil-t (subtypep '(not cons) 'list))
136 ;;; And we'd better check that all the named types are right. (We also
137 ;;; do some more tests on ATOM here, since once CSR experimented with
138 ;;; making it a named type.)
139 (assert-t-t (subtypep 'nil 'nil))
140 (assert-t-t (subtypep 'nil 'atom))
141 (assert-t-t (subtypep 'nil 't))
142 (assert-nil-t (subtypep 'atom 'nil))
143 (assert-t-t (subtypep 'atom 'atom))
144 (assert-t-t (subtypep 'atom 't))
145 (assert-nil-t (subtypep 't 'nil))
146 (assert-nil-t (subtypep 't 'atom))
147 (assert-t-t (subtypep 't 't))
148 ;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
149 ;;; recognized as a subtype of ATOM:
150 (assert-t-t (subtypep '(not list) 'atom))
151 (assert-nil-t (subtypep 'atom '(not list)))
152 ;;; These used to fail, because when the two arguments to subtypep are
153 ;;; of different specifier-type types (e.g. HAIRY and UNION), there
154 ;;; are two applicable type methods -- in this case
155 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
156 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
157 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
158 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
159 ;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
160 ;;; logic in those type methods fixed it.
161 (assert-nil-t (subtypep '(not cons) 'list))
162 (assert-nil-t (subtypep '(not single-float) 'float))
163 ;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
164 ;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
165 (assert-t-t (subtypep '(and zilch integer) 'zilch))
166 (assert-t-t (subtypep '(and integer zilch) 'zilch))
168 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
169 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
170 ;;; corresponding to the NIL type-specifier; we were bogusly returning
171 ;;; NIL, T (indicating surety) for the following:
172 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
174 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
175 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
176 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
177 ;;;; They look nice but they're nontrivial enough that it's not
178 ;;;; obvious from inspection that everything is OK. Let's make sure
179 ;;;; that things still basically work.
181 ;; structure type tests setup
182 (defstruct structure-foo1)
183 (defstruct (structure-foo2 (:include structure-foo1))
185 (defstruct (structure-foo3 (:include structure-foo2)))
186 (defstruct (structure-foo4 (:include structure-foo3))
189 ;; structure-class tests setup
190 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
191 (defclass structure-class-foo2 (structure-class-foo1)
192 () (:metaclass cl:structure-class))
193 (defclass structure-class-foo3 (structure-class-foo2)
194 () (:metaclass cl:structure-class))
195 (defclass structure-class-foo4 (structure-class-foo3)
196 () (:metaclass cl:structure-class))
198 ;; standard-class tests setup
199 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
200 (defclass standard-class-foo2 (standard-class-foo1)
201 () (:metaclass cl:standard-class))
202 (defclass standard-class-foo3 (standard-class-foo2)
203 () (:metaclass cl:standard-class))
204 (defclass standard-class-foo4 (standard-class-foo3)
205 () (:metaclass cl:standard-class))
207 ;; condition tests setup
208 (define-condition condition-foo1 (condition) ())
209 (define-condition condition-foo2 (condition-foo1) ())
210 (define-condition condition-foo3 (condition-foo2) ())
211 (define-condition condition-foo4 (condition-foo3) ())
213 ;;; inline type tests
214 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
215 (defparameter *tests-of-inline-type-tests*
218 ;; structure type tests
219 (assert (typep (make-structure-foo3) 'structure-foo2))
220 (assert (not (typep (make-structure-foo1) 'structure-foo4)))
221 (assert (typep (nth-value 1
222 (ignore-errors (structure-foo2-x
223 (make-structure-foo1))))
225 (assert (null (ignore-errors
226 (setf (structure-foo2-x (make-structure-foo1)) 11))))
228 ;; structure-class tests
229 (assert (typep (make-instance 'structure-class-foo3)
230 'structure-class-foo2))
231 (assert (not (typep (make-instance 'structure-class-foo1)
232 'structure-class-foo4)))
233 (assert (null (ignore-errors
234 (setf (slot-value (make-instance 'structure-class-foo1)
238 ;; standard-class tests
239 (assert (typep (make-instance 'standard-class-foo3)
240 'standard-class-foo2))
241 (assert (not (typep (make-instance 'standard-class-foo1)
242 'standard-class-foo4)))
243 (assert (null (ignore-errors
244 (setf (slot-value (make-instance 'standard-class-foo1) 'x)
248 (assert (typep (make-condition 'condition-foo3)
250 (assert (not (typep (make-condition 'condition-foo1)
252 (assert (null (ignore-errors
253 (setf (slot-value (make-condition 'condition-foo1) 'x)
255 (assert (subtypep 'error 't))
256 (assert (subtypep 'simple-condition 'condition))
257 (assert (subtypep 'simple-error 'simple-condition))
258 (assert (subtypep 'simple-error 'error))
259 (assert (not (subtypep 'condition 'simple-condition)))
260 (assert (not (subtypep 'error 'simple-error)))
261 (assert (eq (car (sb-kernel:class-direct-superclasses
262 (find-class 'simple-condition)))
263 (find-class 'condition)))
265 (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
267 (sb-pcl:find-class 'condition)))
269 (let ((subclasses (mapcar #'sb-pcl:find-class
273 sb-int:simple-file-error
274 sb-int:simple-style-warning))))
275 (assert (null (set-difference
276 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
281 (assert (equal (sb-pcl:class-precedence-list
282 (sb-pcl:find-class 'simple-condition))
283 (mapcar #'sb-pcl:find-class '(simple-condition
289 (assert (null (sb-kernel:class-direct-superclasses
290 (find-class 'fundamental-stream))))
291 (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
292 'fundamental-stream))
293 (mapcar #'sb-pcl:find-class '(standard-object stream))))
294 (assert (null (set-difference
295 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
296 'fundamental-stream))
297 (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
298 fundamental-character-stream
299 fundamental-output-stream
300 fundamental-input-stream)))))
301 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
302 'fundamental-stream))
303 (mapcar #'sb-pcl:find-class '(fundamental-stream
310 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
311 'fundamental-stream))
312 (mapcar #'sb-pcl:find-class '(fundamental-stream
315 sb-pcl::slot-object stream
316 sb-kernel:instance t))))
317 (assert (subtypep (find-class 'stream) (find-class t)))
318 (assert (subtypep (find-class 'fundamental-stream) 'stream))
319 (assert (not (subtypep 'stream 'fundamental-stream)))))
320 ;;; Test under the interpreter.
321 (eval *tests-of-inline-type-tests*)
322 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
323 ;;; Test under the compiler.
324 (defun tests-of-inline-type-tests ()
325 #.*tests-of-inline-type-tests*)
326 (tests-of-inline-type-tests)
327 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
330 (quit :unix-status 104)