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: broken by 0.pre7.15 #!-SB-INTERPRETER stuff
74 #+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
75 (assert (not (typep 11 '(simple-array undef-type 1))))
77 (assert (subtypep '(vector some-undef-type) 'vector))
78 (assert (not (subtypep '(vector some-undef-type) 'integer)))
79 (assert-nil-nil (subtypep 'utype-1 'utype-2))
80 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
81 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
82 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
84 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
85 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
86 (assert (raises-error? (typep 11 'and)))
87 (assert (raises-error? (typep 11 'or)))
89 ;;; Of course empty lists of subtypes are still OK.
90 (assert (typep 11 '(and)))
91 (assert (not (typep 11 '(or))))
93 ;;; bug 12: type system didn't grok nontrivial intersections
94 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
95 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
96 (assert (subtypep 'keyword 'symbol))
97 (assert (not (subtypep 'symbol 'keyword)))
98 (assert (subtypep 'ratio 'real))
99 (assert (subtypep 'ratio 'number))
101 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow
102 ;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally
103 ;;;; be nicer, and Martin Atzmueller ported the patches.
104 ;;;; They look nice but they're nontrivial enough that it's not obvious
105 ;;;; from inspection that everything is OK. Let's make sure that things
106 ;;;; still basically work.
108 ;; structure type tests setup
109 (defstruct structure-foo1)
110 (defstruct (structure-foo2 (:include structure-foo1))
112 (defstruct (structure-foo3 (:include structure-foo2)))
113 (defstruct (structure-foo4 (:include structure-foo3))
116 ;; structure-class tests setup
117 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
118 (defclass structure-class-foo2 (structure-class-foo1)
119 () (:metaclass cl:structure-class))
120 (defclass structure-class-foo3 (structure-class-foo2)
121 () (:metaclass cl:structure-class))
122 (defclass structure-class-foo4 (structure-class-foo3)
123 () (:metaclass cl:structure-class))
125 ;; standard-class tests setup
126 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
127 (defclass standard-class-foo2 (standard-class-foo1)
128 () (:metaclass cl:standard-class))
129 (defclass standard-class-foo3 (standard-class-foo2)
130 () (:metaclass cl:standard-class))
131 (defclass standard-class-foo4 (standard-class-foo3)
132 () (:metaclass cl:standard-class))
134 ;; condition tests setup
135 (define-condition condition-foo1 (condition) ())
136 (define-condition condition-foo2 (condition-foo1) ())
137 (define-condition condition-foo3 (condition-foo2) ())
138 (define-condition condition-foo4 (condition-foo3) ())
140 (format t "~&/before DEFUN TEST-INLINE-TYPE-TESTS~%")
142 (fmakunbound 'test-inline-type-tests)
143 (defun test-inline-type-tests ()
144 ;; structure type tests
145 (assert (typep (make-structure-foo3) 'structure-foo2))
146 (assert (not (typep (make-structure-foo1) 'structure-foo4)))
147 (assert (null (ignore-errors
148 (setf (structure-foo2-x (make-structure-foo1)) 11))))
150 ;; structure-class tests
151 (assert (typep (make-instance 'structure-class-foo3)
152 'structure-class-foo2))
153 (assert (not (typep (make-instance 'structure-class-foo1)
154 'structure-class-foo4)))
155 (assert (null (ignore-errors
156 (setf (slot-value (make-instance 'structure-class-foo1) 'x)
159 ;; standard-class tests
160 (assert (typep (make-instance 'standard-class-foo3)
161 'standard-class-foo2))
162 (assert (not (typep (make-instance 'standard-class-foo1)
163 'standard-class-foo4)))
164 (assert (null (ignore-errors
165 (setf (slot-value (make-instance 'standard-class-foo1) 'x)
169 (assert (typep (make-condition 'condition-foo3)
171 (assert (not (typep (make-condition 'condition-foo1)
173 (assert (null (ignore-errors
174 (setf (slot-value (make-condition 'condition-foo1) 'x)
176 (assert (subtypep 'error 't))
177 (assert (subtypep 'simple-condition 'condition))
178 (assert (subtypep 'simple-error 'simple-condition))
179 (assert (subtypep 'simple-error 'error))
180 (assert (not (subtypep 'condition 'simple-condition)))
181 (assert (not (subtypep 'error 'simple-error)))
182 (assert (eq (car (sb-kernel:class-direct-superclasses (find-class
184 (find-class 'condition)))
186 (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
188 (sb-pcl:find-class 'condition)))
189 (assert (null (set-difference
190 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
192 (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
193 sb-int:simple-style-warning)))))
196 (assert (equal (sb-pcl:class-precedence-list
197 (sb-pcl:find-class 'simple-condition))
198 (mapcar #'sb-pcl:find-class '(simple-condition condition
199 sb-kernel:instance t))))
202 (assert (null (sb-kernel:class-direct-superclasses (find-class
203 'fundamental-stream))))
204 (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
205 'fundamental-stream))
206 (mapcar #'sb-pcl:find-class '(standard-object stream))))
207 (assert (null (set-difference
208 (sb-pcl:class-direct-subclasses (sb-pcl:find-class
209 'fundamental-stream))
210 (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
211 fundamental-character-stream
212 fundamental-output-stream
213 fundamental-input-stream)))))
214 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
215 'fundamental-stream))
216 (mapcar #'sb-pcl:find-class '(fundamental-stream
223 (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
224 'fundamental-stream))
225 (mapcar #'sb-pcl:find-class '(fundamental-stream
228 sb-pcl::slot-object stream
229 sb-kernel:instance t))))
230 (assert (subtypep (find-class 'stream) (find-class t)))
231 (assert (subtypep (find-class 'fundamental-stream) 'stream))
232 (assert (not (subtypep 'stream 'fundamental-stream))))
234 (format t "~&/done with DEFUN TEST-INLINE-TYPE-TESTS~%")
236 ;;; inline-type tests:
237 ;;; Test the interpreted version.
238 (test-inline-type-tests)
239 (format t "~&/done with interpreted (TEST-INLINE-TYPE-TESTS)~%")
240 ;;; Test the compiled version.
241 #| ; FIXME: fails 'cause FUNCALL of COMPILEd function broken ca. 0.pre7.15
242 (compile nil #'test-inline-type-tests)
243 (test-inline-type-tests)
247 (quit :unix-status 104)