0.7.9.9:

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f79a78c..1c22ac9 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -320,7 +320,7 @@
                    :direct-superclasses supers
                    :direct-slots slots
                    :definition-source `((defclass ,name)
-                                        ,*load-truename*)
+                                        ,*load-pathname*)
                    other)))
     ;; Defclass of a class with a forward-referenced superclass does not
     ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
@@ -460,7 +460,7 @@
   (setf (plist-value class 'class-slot-cells)
        (let (collect)
          (dolist (dslotd direct-slots)
-           (when (eq (slot-definition-allocation dslotd) class)
+           (when (eq :class (slot-definition-allocation dslotd))
              (let ((initfunction (slot-definition-initfunction dslotd)))
                (push (cons (slot-definition-name dslotd)
                               (if initfunction
@@ -499,13 +499,6 @@
                  (lambda (dependent)
                    (apply #'update-dependent class dependent initargs))))
 
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-                                    slot-names &key)
-  (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
-
 (defmethod shared-initialize :after ((slotd structure-slot-definition)
                                     slot-names
                                     &key (allocation :instance))
@@ -683,9 +676,24 @@
 ;;; This is called by :after shared-initialize whenever a class is initialized
 ;;; or reinitialized. The class may or may not be finalized.
 (defun update-class (class finalizep)
+  ;; Comment from Gerd Moellmann:
+  ;;
+  ;; Note that we can't simply delay the finalization when CLASS has
+  ;; no forward referenced superclasses because that causes bootstrap
+  ;; problems.
+  (when (and (not finalizep)
+            (not (class-finalized-p class))
+            (not (class-has-a-forward-referenced-superclass-p class)))
+    (finalize-inheritance class)
+    (return-from update-class))
   (when (or finalizep (class-finalized-p class)
            (not (class-has-a-forward-referenced-superclass-p class)))
     (update-cpl class (compute-class-precedence-list class))
+    ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
+    ;; class.  The hoops above are to ensure that FINALIZE-INHERITANCE
+    ;; is called at finalization, so that MOP programmers can hook
+    ;; into the system as described in "Class Finalization Protocol"
+    ;; (section 5.5.2 of AMOP).
     (update-slots class (compute-slots class))
     (update-gfs-of-class class)
     (update-inits class (compute-default-initargs class))
@@ -719,8 +727,9 @@
        (class-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
-       (cond ((eq alloc :instance) (push eslotd instance-slots))
-             ((classp alloc)       (push eslotd class-slots)))))
+       (case alloc
+          (:instance (push eslotd instance-slots))
+          (:class (push eslotd class-slots)))))
 
     ;; If there is a change in the shape of the instances then the
     ;; old class is now obsolete.
@@ -765,7 +774,7 @@
   (let (collect)
     (dolist (eslotd eslotds)
       (push (assoc (slot-definition-name eslotd)
-                   (class-slot-cells (slot-definition-allocation eslotd)))
+                   (class-slot-cells (slot-definition-class eslotd)))
             collect))
     (nreverse collect)))
 
@@ -862,8 +871,9 @@
        (class-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
-       (cond ((eq alloc :instance) (push eslotd instance-slots))
-             ((classp alloc)       (push eslotd class-slots)))))
+       (case alloc
+          (:instance (push eslotd instance-slots))
+          (:class (push eslotd class-slots)))))
     (let ((nlayout (compute-layout cpl instance-slots)))
       (dolist (eslotd instance-slots)
        (setf (slot-definition-location eslotd)
@@ -871,7 +881,7 @@
     (dolist (eslotd class-slots)
       (setf (slot-definition-location eslotd)
            (assoc (slot-definition-name eslotd)
-                  (class-slot-cells (slot-definition-allocation eslotd)))))
+                  (class-slot-cells (slot-definition-class eslotd)))))
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))