X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Finit.lisp;h=6696bbaac304ff422a8f2cf2f5df44fe9f51db46;hb=d25e3478acccec70402ff32554669a982be8e281;hp=8b55efa825430f50679d37cc0b658f50af7eea5d;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 8b55efa..6696bba 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -68,9 +68,8 @@ (apply #'shared-initialize instance nil initargs) instance) -(defmethod update-instance-for-different-class ((previous std-object) - (current std-object) - &rest initargs) +(defmethod update-instance-for-different-class + ((previous standard-object) (current standard-object) &rest initargs) ;; First we must compute the newly added slots. The spec defines ;; newly added slots as "those local slots for which no slot of ;; the same name exists in the previous class." @@ -88,11 +87,9 @@ (list* 'shared-initialize current added-slots initargs))) (apply #'shared-initialize current added-slots initargs))) -(defmethod update-instance-for-redefined-class ((instance std-object) - added-slots - discarded-slots - property-list - &rest initargs) +(defmethod update-instance-for-redefined-class + ((instance standard-object) added-slots discarded-slots property-list + &rest initargs) (check-initargs-1 (class-of instance) initargs (list (list* 'update-instance-for-redefined-class @@ -111,36 +108,31 @@ (initialize-slot-from-initfunction (class instance slotd) ;; CLHS: If a before method stores something in a slot, ;; that slot won't be initialized from its :INITFORM, if any. - (if (typep instance 'structure-object) - (when (eq (funcall - ;; not SLOT-VALUE-USING-CLASS, as that - ;; throws an error if the value is the - ;; unbound marker. - (slot-definition-internal-reader-function slotd) - instance) - +slot-unbound+) - (setf (slot-value-using-class class instance slotd) - (let ((initfn (slot-definition-initfunction slotd))) - (when initfn - (funcall initfn))))) - (unless (or (null (slot-definition-initfunction slotd)) - (slot-boundp-using-class class instance slotd)) - (setf (slot-value-using-class class instance slotd) - (funcall (slot-definition-initfunction slotd))))))) + (let ((initfun (slot-definition-initfunction slotd))) + (if (typep instance 'structure-object) + ;; We don't have a consistent unbound marker for structure + ;; object slots, and structure object redefinition is not + ;; really supported anyways -- so unconditionally + ;; initializing the slot should be fine. + (when initfun + (setf (slot-value-using-class class instance slotd) + (funcall initfun))) + (unless (or (not initfun) + (slot-boundp-using-class class instance slotd)) + (setf (slot-value-using-class class instance slotd) + (funcall initfun))))))) (let* ((class (class-of instance)) (initfn-slotds (loop for slotd in (class-slots class) unless (initialize-slot-from-initarg class instance slotd) - collect 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)) ;;; If initargs are valid return nil, otherwise signal an error.