* bug fix: compiling a call to SLOT-VALUE with a constant slot-name
when no class with the named slot yet exists no longer causes a
compile-time style-warning.
+ * bug fix: :ALLOCATION :CLASS slots are type-checked properly
+ in safe code. (reported by Didier Verna)
changes in sbcl-1.0.23 relative to 1.0.22:
* enhancement: when disassembling method functions, disassembly
unless (initialize-slot-from-initarg class instance slotd)
collect slotd)))
(dolist (slotd initfn-slotds)
- (if (eq (slot-definition-allocation slotd) :class)
- (when (or (eq t slot-names)
- (memq (slot-definition-name slotd) slot-names))
- (unless (slot-boundp-using-class class instance slotd)
- (initialize-slot-from-initfunction class instance slotd)))
- (when (or (eq t slot-names)
- (memq (slot-definition-name slotd) slot-names))
- (initialize-slot-from-initfunction class instance slotd)))))
+ (unless (eq (slot-definition-allocation slotd) :class)
+ ;; :ALLOCATION :CLASS slots use the :INITFORM when class is defined
+ ;; or redefined, not when instances are allocated.
+ (when (or (eq t slot-names)
+ (memq (slot-definition-name slotd) slot-names))
+ (initialize-slot-from-initfunction class instance slotd)))))
instance))
\f
;;; If initargs are valid return nil, otherwise signal an error.
(find-class metaclass)))
(t *the-class-standard-class*))
(nreverse reversed-plist)))))
+
+(defun call-initfun (fun slotd safe)
+ (declare (function fun))
+ (let ((value (funcall fun)))
+ (when safe
+ (let ((typecheck (slot-definition-type-check-function slotd)))
+ (when typecheck
+ (funcall (the function typecheck) value))))
+ value))
\f
(defmethod shared-initialize :after
((class std-class) slot-names &key
super-class of the class ~S, ~
but the meta-classes ~S and ~S are incompatible. ~
Define a method for ~S to avoid this error.~@:>"
- superclass class (class-of superclass) (class-of class)
- 'validate-superclass)))
+ superclass class (class-of superclass) (class-of class)
+ 'validate-superclass)))
(setf (slot-value class 'direct-superclasses) direct-superclasses))
(t
(setq direct-superclasses (slot-value class 'direct-superclasses))))
(plist-value class 'direct-default-initargs)))
(setf (plist-value class 'class-slot-cells)
(let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+ (safe (safe-p class))
(collect '()))
(dolist (dslotd direct-slots)
(when (eq :class (slot-definition-allocation dslotd))
(eq t slot-names)
(member name slot-names :test #'eq))
(let* ((initfunction (slot-definition-initfunction dslotd))
- (value (if initfunction
- (funcall initfunction)
- +slot-unbound+)))
+ (value
+ (if initfunction
+ (call-initfun initfunction dslotd safe)
+ +slot-unbound+)))
(push (cons name value) collect))
(push old collect)))))
(nreverse collect)))
(std-compute-slots class))
(defun std-compute-slots-around (class eslotds)
- (let ((location -1))
+ (let ((location -1)
+ (safe (safe-p class)))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
(case (slot-definition-allocation eslotd)
c))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
- ;; We may have inherited an initfunction
+ ;; We may have inherited an initfunction FIXME: Is this
+ ;; really right? Is the initialization in
+ ;; SHARED-INITIALIZE (STD-CLASS) not enough?
(let ((initfun (slot-definition-initfunction eslotd)))
(if initfun
- (rplacd cell (funcall initfun))
+ (rplacd cell (call-initfun initfun eslotd safe))
cell))
cell)))))
(unless (slot-definition-class eslotd)
(make-instance class :slot :not-a-fixnum))
(assert (raises-error? (make-my-instance 'my-alt-metaclass-instance-class)
type-error)))
+
+(with-test (:name :typecheck-class-allocation)
+ ;; :CLASS slot :INITFORMs are executed at class definition time
+ (assert (raises-error?
+ (eval `(locally (declare (optimize safety))
+ (defclass class-allocation-test-bad ()
+ ((slot :initform "slot"
+ :initarg :slot
+ :type fixnum
+ :allocation :class)))))
+ type-error))
+ (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD")))
+ (eval `(locally (declare (optimize safety))
+ (defclass ,name ()
+ ((slot :initarg :slot
+ :type (integer 100 200)
+ :allocation :class)))))
+ (eval
+ `(macrolet ((check (form)
+ `(assert (multiple-value-bind (ok err)
+ (ignore-errors ,form)
+ (and (not ok)
+ (typep err 'type-error)
+ (equal '(integer 100 200)
+ (type-error-expected-type err)))))))
+ (macrolet ((test (form)
+ `(progn
+ (check (eval '(locally (declare (optimize safety))
+ ,form)))
+ (check (funcall (compile nil '(lambda ()
+ (declare (optimize safety))
+ ,form))))))
+ (test-slot (value form)
+ `(progn
+ (assert (eql ,value (slot-value (eval ',form) 'slot)))
+ (assert (eql ,value (slot-value (funcall (compile nil '(lambda () ,form)))
+ 'slot))))))
+ (test (make-instance ',name :slot :bad))
+ (assert (not (slot-boundp (make-instance ',name) 'slot)))
+ (let ((* (make-instance ',name :slot 101)))
+ (test-slot 101 *)
+ (test (setf (slot-value * 'slot) (list 1 2 3)))
+ (setf (slot-value * 'slot) 110)
+ (test-slot 110 *))
+ (test-slot 110 (make-instance ',name))
+ (test-slot 111 (make-instance ',name :slot 111)))))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.23.35"
+"1.0.23.36"
projects / sbcl.git / commitdiff