1.0.28.65: fix compiling with *PROFILE-HASH-CACHE* set to T

[sbcl.git] / src / pcl / init.lisp

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 8b55efa..6696bba 100644 (file)
--- 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))
 \f
 ;;; If initargs are valid return nil, otherwise signal an error.