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 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
61 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
62 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
63 (assert (eql (upgraded-array-element-type t) t))
64 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
65 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
67 ;;; Do reasonable things with undefined types, and with compound types
68 ;;; built from undefined types.
71 (assert (typep #(11) '(simple-array t 1)))
72 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
73 ;;; FIXME: This is broken because of compiler bug 123: the compiler
74 ;;; optimizes the type test to T, so it never gets a chance to raise a
75 ;;; runtime error. (It used to work under the IR1 interpreter just
76 ;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard
77 ;;; as the byte compiler does.)
78 #+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
79 (assert (not (typep 11 '(simple-array undef-type 1))))
81 (assert (subtypep '(vector some-undef-type) 'vector))
82 (assert (not (subtypep '(vector some-undef-type) 'integer)))
83 (assert-nil-nil (subtypep 'utype-1 'utype-2))
84 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
85 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
86 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
88 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
89 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
90 (assert (raises-error? (typep 11 'and)))
91 (assert (raises-error? (typep 11 'or)))
93 ;;; Of course empty lists of subtypes are still OK.
94 (assert (typep 11 '(and)))
95 (assert (not (typep 11 '(or))))
97 ;;; bug 12: type system didn't grok nontrivial intersections
98 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
99 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
100 (assert (subtypep 'keyword 'symbol))
101 (assert (not (subtypep 'symbol 'keyword)))
102 (assert (subtypep 'ratio 'real))
103 (assert (subtypep 'ratio 'number))
105 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
106 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
107 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
108 ;;;; They look nice but they're nontrivial enough that it's not
109 ;;;; obvious from inspection that everything is OK. Let's make sure
110 ;;;; that things still basically work.
112 ;; structure type tests setup
113 (defstruct structure-foo1)
114 (defstruct (structure-foo2 (:include structure-foo1))
116 (defstruct (structure-foo3 (:include structure-foo2)))
117 (defstruct (structure-foo4 (:include structure-foo3))
120 ;; structure-class tests setup
121 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
122 (defclass structure-class-foo2 (structure-class-foo1)
123 () (:metaclass cl:structure-class))
124 (defclass structure-class-foo3 (structure-class-foo2)
125 () (:metaclass cl:structure-class))
126 (defclass structure-class-foo4 (structure-class-foo3)
127 () (:metaclass cl:structure-class))
129 ;; standard-class tests setup
130 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
131 (defclass standard-class-foo2 (standard-class-foo1)
132 () (:metaclass cl:standard-class))
133 (defclass standard-class-foo3 (standard-class-foo2)
134 () (:metaclass cl:standard-class))
135 (defclass standard-class-foo4 (standard-class-foo3)
136 () (:metaclass cl:standard-class))
138 ;; condition tests setup
139 (define-condition condition-foo1 (condition) ())
140 (define-condition condition-foo2 (condition-foo1) ())
141 (define-condition condition-foo3 (condition-foo2) ())
142 (define-condition condition-foo4 (condition-foo3) ())
144 ;;; inline type tests
145 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
146 (defparameter *tests-of-inline-type-tests*
149 ;; structure type tests
150 (assert (typep (make-structure-foo3) 'structure-foo2))
151 (assert (not (typep (make-structure-foo1) 'structure-foo4)))
152 (assert (typep (nth-value 1
153 (ignore-errors (structure-foo2-x
154 (make-structure-foo1))))
156 (assert (null (ignore-errors
157 (setf (structure-foo2-x (make-structure-foo1)) 11))))
159 ;; structure-class tests
160 (assert (typep (make-instance 'structure-class-foo3)
161 'structure-class-foo2))
162 (assert (not (typep (make-instance 'structure-class-foo1)
163 'structure-class-foo4)))
164 (assert (null (ignore-errors
165 (setf (slot-value (make-instance 'structure-class-foo1)
169 ;; standard-class tests
170 (assert (typep (make-instance 'standard-class-foo3)
171 'standard-class-foo2))
172 (assert (not (typep (make-instance 'standard-class-foo1)
173 'standard-class-foo4)))
174 (assert (null (ignore-errors
175 (setf (slot-value (make-instance 'standard-class-foo1) 'x)
179 (assert (typep (make-condition 'condition-foo3)
181 (assert (not (typep (make-condition 'condition-foo1)
183 (assert (null (ignore-errors
184 (setf (slot-value (make-condition 'condition-foo1) 'x)
186 (assert (subtypep 'error 't))
187 (assert (subtypep 'simple-condition 'condition))
188 (assert (subtypep 'simple-error 'simple-condition))
189 (assert (subtypep 'simple-error 'error))
190 (assert (not (subtypep 'condition 'simple-condition)))
191 (assert (not (subtypep 'error 'simple-error)))
192 (assert (eq (car (sb-kernel:class-direct-superclasses
193 (find-class 'simple-condition)))
194 (find-class 'condition)))
196 (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
198 (sb-pcl:find-class 'condition)))
199 (assert (null (set-difference
200 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
202 (mapcar #'sb-pcl:find-class
205 sb-int:simple-file-error
206 sb-int:simple-style-warning)))))
209 (assert (equal (sb-pcl:class-precedence-list
210 (sb-pcl:find-class 'simple-condition))
211 (mapcar #'sb-pcl:find-class '(simple-condition
217 (assert (null (sb-kernel:class-direct-superclasses
218 (find-class 'fundamental-stream))))
219 (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
220 'fundamental-stream))
221 (mapcar #'sb-pcl:find-class '(standard-object stream))))
222 (assert (null (set-difference
223 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
224 'fundamental-stream))
225 (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
226 fundamental-character-stream
227 fundamental-output-stream
228 fundamental-input-stream)))))
229 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
230 'fundamental-stream))
231 (mapcar #'sb-pcl:find-class '(fundamental-stream
238 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
239 'fundamental-stream))
240 (mapcar #'sb-pcl:find-class '(fundamental-stream
243 sb-pcl::slot-object stream
244 sb-kernel:instance t))))
245 (assert (subtypep (find-class 'stream) (find-class t)))
246 (assert (subtypep (find-class 'fundamental-stream) 'stream))
247 (assert (not (subtypep 'stream 'fundamental-stream)))))
248 ;;; Test under the interpreter.
249 (eval *tests-of-inline-type-tests*)
250 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
251 ;;; Test under the compiler.
252 (defun tests-of-inline-type-tests ()
253 #.*tests-of-inline-type-tests*)
254 (tests-of-inline-type-tests)
255 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
258 (quit :unix-status 104)