X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=1c22ac9540a0abf519b14453069354dfcd20464a;hb=a260738d7a71680079d972b102b4e4db4e8dc3ae;hp=f79a78c270bf24de5cde40c587adcc6b903b0e4b;hpb=bcbcc0d0660b3b3741203b3dfdd3443b201bf690;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f79a78c..1c22ac9 100644
--- 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))