+;;;; This file is for testing typechecking of writes to CLOS object slots
+;;;; for code compiled with a (SAFETY 3) optimization policy.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(shadow 'slot)
+
+(declaim (optimize safety))
+
+(defclass foo ()
+ ((slot :initarg :slot :type fixnum :accessor slot)))
+(defclass foo/gf (sb-mop:standard-generic-function)
+ ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
+ (:metaclass sb-mop:funcallable-standard-class))
+(defmethod succeed/sv ((x foo))
+ (setf (slot-value x 'slot) 1))
+(defmethod fail/sv ((x foo))
+ (setf (slot-value x 'slot) t))
+(defmethod succeed/acc ((x foo))
+ (setf (slot x) 1))
+(defmethod fail/acc ((x foo))
+ (setf (slot x) t))
+(defmethod succeed/sv/gf ((x foo/gf))
+ (setf (slot-value x 'slot/gf) 1))
+(defmethod fail/sv/gf ((x foo/gf))
+ (setf (slot-value x 'slot/gf) t))
+(defmethod succeed/acc/gf ((x foo/gf))
+ (setf (slot/gf x) 1))
+(defmethod fail/acc/gf ((x foo/gf))
+ (setf (slot/gf x) t))
+(defvar *t* t)
+(defvar *one* 1)
+
+;; evaluator
+(with-test (:name (:evaluator))
+ (eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
+ (assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
+ type-error))
+ (eval '(setf (slot (make-instance 'foo)) 1))
+ (assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t))
+ type-error))
+ (eval '(succeed/sv (make-instance 'foo)))
+ (assert (raises-error? (eval '(fail/sv (make-instance 'foo)))
+ type-error))
+ (eval '(succeed/acc (make-instance 'foo)))
+ (assert (raises-error? (eval '(fail/acc (make-instance 'foo)))
+ type-error))
+ (eval '(make-instance 'foo :slot 1))
+ (assert (raises-error? (eval '(make-instance 'foo :slot t))
+ type-error))
+ (eval '(make-instance 'foo :slot *one*))
+ (assert (raises-error? (eval '(make-instance 'foo :slot *t*))
+ type-error)))
+;; evaluator/gf
+(with-test (:name (:evaluator/gf))
+ (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
+ (assert (raises-error?
+ (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
+ type-error))
+ (eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
+ (assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
+ type-error))
+ (eval '(succeed/sv/gf (make-instance 'foo/gf)))
+ (assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf)))
+ type-error))
+ (eval '(succeed/acc/gf (make-instance 'foo/gf)))
+ (assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf)))
+ type-error))
+ (eval '(make-instance 'foo/gf :slot/gf 1))
+ (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t))
+ type-error))
+ (eval '(make-instance 'foo/gf :slot/gf *one*))
+ (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*))
+ type-error)))
+
+;; compiler
+(with-test (:name (:compiler))
+ (funcall (compile nil '(lambda ()
+ (setf (slot-value (make-instance 'foo) 'slot) 1))))
+ (funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1))))
+ (assert (raises-error?
+ (funcall
+ (compile nil '(lambda () (setf (slot (make-instance 'foo)) t))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo)))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo)))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot 1))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot t))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot *one*))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*))))
+ type-error)))
+
+(with-test (:name (:compiler :setf :slot-value))
+ (assert (raises-error?
+ (funcall
+ (compile nil '(lambda ()
+ (setf (slot-value (make-instance 'foo) 'slot) t))))
+ type-error)))
+
+; compiler/gf
+(with-test (:name (:compiler/gf))
+ (funcall (compile nil
+ '(lambda ()
+ (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
+ (funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))))
+ (assert (raises-error?
+ (funcall
+ (compile nil
+ '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (fail/sv/gf (make-instance 'foo/gf)))))
+ type-error))
+ (funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (fail/acc/gf (make-instance 'foo/gf)))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (make-instance 'foo/gf :slot/gf t))))
+ type-error))
+ (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*))))
+ (assert (raises-error?
+ (funcall (compile nil '(lambda ()
+ (make-instance 'foo/gf :slot/gf *t*))))
+ type-error)))
+
+(with-test (:name (:compiler/gf :setf :slot-value))
+ (assert (raises-error?
+ (funcall
+ (compile nil
+ '(lambda ()
+ (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
+ type-error)))
+
+
+(with-test (:name (:slot-inheritance :slot-value :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :type float)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :slot-value :t/single-float))
+ (defclass a () ((slot1 :initform 0.0)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :writer :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :type float :accessor slot1-of)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :writer :float/single-float))
+ (defclass a () ((slot1 :initform 0.0 :accessor slot1-of)))
+ (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
+ (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
+ (inheritance-test (make-instance 'a))
+ (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
+
+(with-test (:name (:slot-inheritance :type-intersection))
+ (defclass a* ()
+ ((slot1 :initform 1
+ :initarg :slot1
+ :accessor slot1-of
+ :type fixnum)))
+ (defclass b* ()
+ ((slot1 :initform 1
+ :initarg :slot1
+ :accessor slot1-of
+ :type unsigned-byte)))
+ (defclass c* (a* b*)
+ ())
+ (setf (slot1-of (make-instance 'a*)) -1)
+ (setf (slot1-of (make-instance 'b*)) (1+ most-positive-fixnum))
+ (setf (slot1-of (make-instance 'c*)) 1)
+ (assert (raises-error? (setf (slot1-of (make-instance 'c*)) -1)
+ type-error))
+ (assert (raises-error? (setf (slot1-of (make-instance 'c*))
+ (1+ most-positive-fixnum))
+ type-error))
+ (assert (raises-error? (make-instance 'c* :slot1 -1)
+ type-error))
+ (assert (raises-error? (make-instance 'c* :slot1 (1+ most-positive-fixnum))
+ type-error)))
+
+(defclass a ()
+ ((slot1 :initform nil
+ :initarg :slot1
+ :accessor slot1-of
+ :type (or null function))))
+(defclass b (a)
+ ((slot1 :initform nil
+ :initarg :slot1
+ :accessor slot1-of
+ :type (or null (function (fixnum) fixnum)))))
+
+(with-test (:name (:type :function))
+ (setf (slot1-of (make-instance 'a)) (lambda () 1))
+ (setf (slot1-of (make-instance 'b)) (lambda () 1))
+ (assert (raises-error? (setf (slot1-of (make-instance 'a)) 1)
+ type-error))
+ (assert (raises-error? (setf (slot1-of (make-instance 'b)) 1)
+ type-error))
+ (make-instance 'a :slot1 (lambda () 1))
+ (make-instance 'b :slot1 (lambda () 1)))
+
+