1 ;;;; This file is for testing typechecking of writes to CLOS object slots
2 ;;;; for code compiled with a (SAFETY 3) optimization policy.
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 ;;; Typechecking should be working, but it isn't.
16 #+interpreter
(invoke-restart 'run-tests
::skip-file
)
20 (declaim (optimize safety
))
25 ;;;; Slot type checking for standard instances
28 ((slot :initarg
:slot
:type fixnum
:accessor slot
)))
29 (defmethod succeed/sv
((x foo
))
30 (setf (slot-value x
'slot
) 1))
31 (defmethod fail/sv
((x foo
))
32 (setf (slot-value x
'slot
) t
))
33 (defmethod succeed/acc
((x foo
))
35 (defmethod fail/acc
((x foo
))
38 ;;; Test slot type checking for standard instances in EVALed code.
39 (with-test (:name
(standard-object slot-value setf
:initarg type-error eval
))
40 (eval '(setf (slot-value (make-instance 'foo
) 'slot
) 1))
41 (assert-error (eval '(setf (slot-value (make-instance 'foo
) 'slot
) t
))
43 (eval '(setf (slot (make-instance 'foo
)) 1))
44 (assert-error (eval '(setf (slot (make-instance 'foo
)) t
))
46 (eval '(succeed/sv
(make-instance 'foo
)))
47 (assert-error (eval '(fail/sv
(make-instance 'foo
)))
49 (eval '(succeed/acc
(make-instance 'foo
)))
50 (assert-error (eval '(fail/acc
(make-instance 'foo
)))
52 (eval '(make-instance 'foo
:slot
1))
53 (assert-error (eval '(make-instance 'foo
:slot t
))
55 (eval '(make-instance 'foo
:slot
*one
*))
56 (assert-error (eval '(make-instance 'foo
:slot
*t
*))
59 ;;; Test slot type checking for standard instances in compiled code.
60 (with-test (:name
(standard-object slot-value setf
:initarg type-error
62 (checked-compile-and-assert (:optimize
:safe
)
64 (setf (slot-value (make-instance 'foo
) 'slot
) 1))
66 (checked-compile-and-assert ()
68 (setf (slot-value (make-instance 'foo
) 'slot
) t
))
69 (() (condition 'type-error
)))
71 (checked-compile-and-assert (:optimize
:safe
)
72 '(lambda () (setf (slot (make-instance 'foo
)) 1))
74 (checked-compile-and-assert (:optimize
:safe
)
75 '(lambda () (setf (slot (make-instance 'foo
)) t
))
76 (() (condition 'type-error
)))
78 (checked-compile-and-assert (:optimize
:safe
)
79 '(lambda () (succeed/sv
(make-instance 'foo
)))
81 (checked-compile-and-assert (:optimize
:safe
)
82 '(lambda () (fail/sv
(make-instance 'foo
)))
83 (() (condition 'type-error
)))
85 (checked-compile-and-assert (:optimize
:safe
)
86 '(lambda () (succeed/acc
(make-instance 'foo
)))
88 (checked-compile-and-assert (:optimize
:safe
)
89 '(lambda () (fail/acc
(make-instance 'foo
)))
90 (() (condition 'type-error
)))
92 ;; These four cases trigger PCL's constructor mechanism and
94 ;; FIXME: the type mismatch is handled poorly:
95 ;; When the function is *called*, an entry is added to the
96 ;; constructor cache, this process signals a TYPE-WARNING, usually
97 ;; meant for compile-time. When the call proceeds and executes the
98 ;; newly cached constructor, the expected runtime TYPE-ERROR is
101 ;; FIXME: also note that constructor type checks are only inserted
102 ;; when SAFETY is 3, which is different from other slot type checks.
103 (checked-compile-and-assert (:optimize
:maximally-safe
)
104 '(lambda () (make-instance 'foo
:slot
1))
105 (() '(cons foo null
) :test
(lambda (values expected
)
106 (typep values
(first expected
)))))
107 (checked-compile-and-assert (:optimize
:maximally-safe
)
108 '(lambda () (make-instance 'foo
:slot t
))
109 (() (condition '(or sb-int
:type-warning type-error
))))
111 (checked-compile-and-assert (:optimize
:maximally-safe
)
112 '(lambda () (make-instance 'foo
:slot
*one
*))
113 (() '(cons foo null
) :test
(lambda (values expected
)
114 (typep values
(first expected
)))))
115 (checked-compile-and-assert (:optimize
:maximally-safe
)
116 '(lambda () (make-instance 'foo
:slot
*t
*))
117 (() (condition 'type-error
))))
119 ;;;; Slot type checking for funcallable instances
121 (defclass foo
/gf
(sb-mop:standard-generic-function
)
122 ((slot/gf
:initarg
:slot
/gf
:type fixnum
:accessor slot
/gf
))
123 (:metaclass sb-mop
:funcallable-standard-class
))
124 (defmethod succeed/sv
/gf
((x foo
/gf
))
125 (setf (slot-value x
'slot
/gf
) 1))
126 (defmethod fail/sv
/gf
((x foo
/gf
))
127 (setf (slot-value x
'slot
/gf
) t
))
128 (defmethod succeed/acc
/gf
((x foo
/gf
))
129 (setf (slot/gf x
) 1))
130 (defmethod fail/acc
/gf
((x foo
/gf
))
131 (setf (slot/gf x
) t
))
133 ;;; Test slot type checking for funcallable instances in EVALed code.
134 (with-test (:name
(sb-mop:funcallable-standard-object slot-value setf
135 :initarg type-error eval
))
136 (eval '(setf (slot-value (make-instance 'foo
/gf
) 'slot
/gf
) 1))
138 (eval '(setf (slot-value (make-instance 'foo
/gf
) 'slot
/gf
) t
))
140 (eval '(setf (slot/gf
(make-instance 'foo
/gf
)) 1))
141 (assert-error (eval '(setf (slot/gf
(make-instance 'foo
/gf
)) t
))
143 (eval '(succeed/sv
/gf
(make-instance 'foo
/gf
)))
144 (assert-error (eval '(fail/sv
/gf
(make-instance 'foo
/gf
)))
146 (eval '(succeed/acc
/gf
(make-instance 'foo
/gf
)))
147 (assert-error (eval '(fail/acc
/gf
(make-instance 'foo
/gf
)))
149 (eval '(make-instance 'foo
/gf
:slot
/gf
1))
150 (assert-error (eval '(make-instance 'foo
/gf
:slot
/gf t
))
152 (eval '(make-instance 'foo
/gf
:slot
/gf
*one
*))
153 (assert-error (eval '(make-instance 'foo
/gf
:slot
/gf
*t
*))
156 ;;; Test slot type checking for funcallable instances in compiled
158 (with-test (:name
(sb-mop:funcallable-standard-object slot-value setf
159 :initarg type-error compile
))
160 (checked-compile-and-assert (:optimize
:safe
)
162 (setf (slot-value (make-instance 'foo
/gf
) 'slot
/gf
) 1))
164 (checked-compile-and-assert (:optimize
:safe
)
166 (setf (slot-value (make-instance 'foo
/gf
) 'slot
/gf
) t
))
167 (() (condition 'type-error
)))
169 (checked-compile-and-assert (:optimize
:safe
)
170 '(lambda () (setf (slot/gf
(make-instance 'foo
/gf
)) 1))
172 (checked-compile-and-assert (:optimize
:safe
)
173 '(lambda () (setf (slot/gf
(make-instance 'foo
/gf
)) t
))
174 (() (condition 'type-error
)))
176 (checked-compile-and-assert (:optimize
:safe
)
177 '(lambda () (succeed/sv
/gf
(make-instance 'foo
/gf
)))
179 (checked-compile-and-assert (:optimize
:safe
)
181 (fail/sv
/gf
(make-instance 'foo
/gf
)))
182 (() (condition 'type-error
)))
184 (checked-compile-and-assert (:optimize
:safe
)
185 '(lambda () (succeed/acc
/gf
(make-instance 'foo
/gf
)))
187 (checked-compile-and-assert (:optimize
:safe
)
188 '(lambda () (fail/acc
/gf
(make-instance 'foo
/gf
)))
189 (() (condition 'type-error
)))
191 ;; FIXME: Comments for corresponding cases in standard instance test
192 ;; apply here as well.
193 (checked-compile-and-assert (:optimize
:maximally-safe
)
194 '(lambda () (make-instance 'foo
/gf
:slot
/gf
1))
195 (() '(cons foo
/gf null
) :test
(lambda (actual expected
)
196 (typep actual
(first expected
)))))
197 (checked-compile-and-assert (:optimize
:maximally-safe
)
198 '(lambda () (make-instance 'foo
/gf
:slot
/gf t
))
199 (() (condition '(or sb-int
:type-warning type-error
))))
201 (checked-compile-and-assert (:optimize
:maximally-safe
)
202 '(lambda () (make-instance 'foo
/gf
:slot
/gf
*one
*))
203 (() '(cons foo
/gf null
) :test
(lambda (actual expected
)
204 (typep actual
(first expected
)))))
205 (checked-compile-and-assert (:optimize
:maximally-safe
)
206 '(lambda () (make-instance 'foo
/gf
:slot
/gf
*t
*))
207 (() (condition 'type-error
))))
209 ;;;; Type checking for inherited slots
211 (defclass inheritance-a
/slot-value
/float
()
212 ((slot1 :initform
0.0 :type float
)))
213 (defclass inheritance-b
/slot-value
/float
(inheritance-a/slot-value
/float
)
214 ((slot1 :initform
0.0 :type single-float
)))
215 (defmethod inheritance/slot-value
/float
((a inheritance-a
/slot-value
/float
))
216 (setf (slot-value a
'slot1
) 1d0
))
218 (with-test (:name
(:slot-inheritance slot-value float single-float
))
219 (inheritance/slot-value
/float
220 (make-instance 'inheritance-a
/slot-value
/float
))
221 (assert-error (inheritance/slot-value
/float
222 (make-instance 'inheritance-b
/slot-value
/float
))
225 (defclass inheritance-a
/slot-value
/t
()
226 ((slot1 :initform
0.0)))
227 (defclass inheritance-b
/slot-value
/t
(inheritance-a/slot-value
/t
)
228 ((slot1 :initform
0.0 :type single-float
)))
229 (defmethod inheritance/slot-value
/t
((a inheritance-a
/slot-value
/t
))
230 (setf (slot-value a
'slot1
) 1d0
))
232 (with-test (:name
(:slot-inheritance slot-value t single-float
))
233 (inheritance/slot-value
/t
(make-instance 'inheritance-a
/slot-value
/t
))
234 (assert-error (inheritance/slot-value
/t
235 (make-instance 'inheritance-b
/slot-value
/t
))
238 (defclass inheritance-a
/accessor
/float
()
239 ((slot1 :initform
0.0 :type float
:accessor slot1-of
)))
240 (defclass inheritance-b
/accessor
/float
(inheritance-a/accessor
/float
)
241 ((slot1 :initform
0.0 :type single-float
)))
242 (defmethod inheritance/accessor
/float
((a inheritance-a
/accessor
/float
))
243 (setf (slot1-of a
) 1d0
))
245 (with-test (:name
(:slot-inheritance
:writer float single-float
))
246 (inheritance/accessor
/float
247 (make-instance 'inheritance-a
/accessor
/float
))
248 (assert-error (inheritance/accessor
/float
249 (make-instance 'inheritance-b
/accessor
/float
))
252 (defclass inheritance-a
/accessor
/t
()
253 ((slot1 :initform
0.0 :accessor slot1-of
)))
254 (defclass inheritance-b
/accessor
/t
(inheritance-a/accessor
/t
)
255 ((slot1 :initform
0.0 :type single-float
)))
256 (defmethod inheritance/accessor
/t
((a inheritance-a
/accessor
/t
))
257 (setf (slot1-of a
) 1d0
))
259 (with-test (:name
(:slot-inheritance
:writer t single-float
))
260 (inheritance/accessor
/t
(make-instance 'inheritance-a
/accessor
/t
))
261 (assert-error (inheritance/accessor
/t
262 (make-instance 'inheritance-b
/accessor
/t
))
265 (defclass inheritance-intersection-a
* ()
270 (defclass inheritance-intersection-b
* ()
274 :type unsigned-byte
)))
275 (defclass inheritance-intersection-c
* (inheritance-intersection-a*
276 inheritance-intersection-b
*)
279 (with-test (:name
(:slot-inheritance
:type-intersection
))
280 (setf (slot1-of (make-instance 'inheritance-intersection-a
*)) -
1)
281 (setf (slot1-of (make-instance 'inheritance-intersection-b
*))
282 (1+ most-positive-fixnum
))
283 (setf (slot1-of (make-instance 'inheritance-intersection-c
*)) 1)
284 (assert-error (setf (slot1-of (make-instance 'inheritance-intersection-c
*))
287 (assert-error (setf (slot1-of (make-instance 'inheritance-intersection-c
*))
288 (1+ most-positive-fixnum
))
290 (assert-error (make-instance 'inheritance-intersection-c
* :slot1 -
1)
292 (assert-error (make-instance 'inheritance-intersection-c
*
293 :slot1
(1+ most-positive-fixnum
))
296 (defclass slot-type-function-a
()
297 ((slot1 :initform nil
300 :type
(or null function
))))
301 (defclass slot-type-function-b
(slot-type-function-a)
302 ((slot1 :initform nil
305 :type
(or null
(function (fixnum) fixnum
)))))
307 (with-test (:name
(:type function type-error
))
308 (setf (slot1-of (make-instance 'slot-type-function-a
)) (lambda () 1))
309 (setf (slot1-of (make-instance 'slot-type-function-b
)) (lambda () 1))
310 (assert-error (setf (slot1-of (make-instance 'slot-type-function-a
)) 1)
312 (assert-error (setf (slot1-of (make-instance 'slot-type-function-b
)) 1)
314 (make-instance 'slot-type-function-a
:slot1
(lambda () 1))
315 (make-instance 'slot-type-function-b
:slot1
(lambda () 1)))
317 (defclass my-alt-metaclass
(standard-class) ())
318 (defmethod sb-mop:validate-superclass
((class my-alt-metaclass
) superclass
)
320 (defclass my-alt-metaclass-instance-class
()
321 ((slot :type fixnum
:initarg
:slot
))
322 (:metaclass my-alt-metaclass
))
323 (defun make-my-instance (class)
324 (make-instance class
:slot
:not-a-fixnum
))
326 (with-test (:name
:alternate-metaclass
/standard-instance-structure-protocol
)
327 (assert-error (make-my-instance 'my-alt-metaclass-instance-class
)
330 (with-test (:name
(:typecheck
:allocation
:class
))
331 ;; :CLASS slot :INITFORMs are executed at class definition time
333 (eval `(locally (declare (optimize safety
))
334 (defclass class-allocation-test-bad
()
335 ((slot :initform
"slot"
338 :allocation
:class
)))))
340 (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD")))
341 (eval `(locally (declare (optimize safety
))
343 ((slot :initarg
:slot
344 :type
(integer 100 200)
345 :allocation
:class
)))))
347 `(macrolet ((check (form)
348 `(assert (multiple-value-bind (ok err
)
349 (ignore-errors ,form
)
351 (typep err
'type-error
)
352 (equal '(integer 100 200)
353 (type-error-expected-type err
)))))))
354 (macrolet ((test (form)
356 (check (eval '(locally (declare (optimize safety
))
358 (check (funcall (checked-compile
360 (declare (optimize safety
))
362 (test-slot (value form
)
364 (assert (eql ,value
(slot-value (eval ',form
) 'slot
)))
365 (assert (eql ,value
(slot-value (funcall (checked-compile
368 (test (make-instance ',name
:slot
:bad
))
369 (assert (not (slot-boundp (make-instance ',name
) 'slot
)))
370 (let ((* (make-instance ',name
:slot
101)))
372 (test (setf (slot-value * 'slot
) (list 1 2 3)))
373 (setf (slot-value * 'slot
) 110)
375 (test-slot 110 (make-instance ',name
))
376 (test-slot 111 (make-instance ',name
:slot
111)))))))