X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=5e5f9332015f457b3e1b52641a2a5077c42d50b7;hb=a96369c72588c5457d71d6aaea35f2c450b19ef5;hp=ed9995efb18727a2f79f87190b5c16cd03f1a27f;hpb=9d67a20f91f72ec73847e283bcf9b2b4f74b1d25;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index ed9995e..5e5f933 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
@@ -676,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))
@@ -1033,14 +1048,38 @@
     (or (eq new-super-meta-class *the-class-std-class*)
 	(eq (class-of class) new-super-meta-class))))
 
+;;; What this does depends on which of the four possible values of
+;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
+;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
+;;; nothing to do, as the new wrapper has already been created.  If
+;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
+;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
+;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
+;;;
+;;; This leaves the case where LAYOUT-INVALID returns T, which happens
+;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
+;;; invalidated all the subclasses in SB-KERNEL land).  Again, here we
+;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
+;;; obsolete the wrapper.
+;;;
+;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
+;;; for (AVER (NOT (EQ (SB-KERNEL:LAYOUT-INVALID OWRAPPER)
+;;;                    :UNINITIALIZED)))
+;;;
+;;; Thanks to Gerd Moellmann for the explanation.  -- CSR, 2002-10-29
 (defun force-cache-flushes (class)
   (let* ((owrapper (class-wrapper class)))
-    ;; We only need to do something if the state is still T. If the
-    ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
-    ;; will already be doing what we want. In particular, we must be
-    ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
-    ;; means do what FLUSH does and then some.
-    (unless (invalid-wrapper-p owrapper)
+    ;; We only need to do something if the wrapper is still valid. If
+    ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
+    ;; both of those will already be doing what we want. In
+    ;; particular, we must be sure we never change an OBSOLETE into a
+    ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
+    (when (or (not (invalid-wrapper-p owrapper))
+	      ;; KLUDGE: despite the observations above, this remains
+	      ;; a violation of locality or what might be considered
+	      ;; good style.  There has to be a better way!  -- CSR,
+	      ;; 2002-10-29
+	      (eq (sb-kernel:layout-invalid owrapper) t))
       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
 				    class)))
 	(setf (wrapper-instance-slots-layout nwrapper)
@@ -1267,6 +1306,17 @@
   (or (eq s *the-class-t*)
       (eq s *the-class-stream*)))
 
+;;; Some necessary methods for FORWARD-REFERENCED-CLASS
+(defmethod class-direct-slots ((class forward-referenced-class)) ())
+(defmethod class-direct-default-initargs ((class forward-referenced-class)) ())
+(macrolet ((def (method)
+             `(defmethod ,method ((class forward-referenced-class))
+                (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
+                       ',method class))))
+  (def class-default-initargs)
+  (def class-precedence-list)
+  (def class-slots))
+
 (defmethod validate-superclass ((c slot-class)
 				(f forward-referenced-class))
   t)