X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=cec50b1581688c224055656cea9f3a68d8b38ab3;hb=67dc5cf478dfe5e3f517001febb9a8f7b922eacf;hp=34a1d5a1462da9bcc104e8c7ccdb04f4ccdcd871;hpb=015c86a5eaaa3d2490d221ae56ffec36d2007529;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 34a1d5a..cec50b1 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -86,6 +86,20 @@
 	(compute-slot-accessor-info slotd type gf)))
     (initialize-internal-slot-gfs name)))
 
+;;; CMUCL (Gerd PCL 2003-04-25) comment:
+;;;
+;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
+;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
+;;; writing/testing effective slot SLOTD.
+;;;
+;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
+;;; GF.  Store the effective method in the effective slot definition
+;;; object itself; these GFs have special dispatch functions calling
+;;; effective methods directly retrieved from effective slot
+;;; definition objects, as an optimization.
+;;;
+;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
+;;; or some such.
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
 				       type gf)
   (let* ((name (slot-value slotd 'name))
@@ -104,50 +118,6 @@
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
 
-(defmethod shared-initialize :after ((object documentation-mixin)
-				     slot-names
-				     &key (documentation nil documentation-p))
-  (declare (ignore slot-names))
-  (when documentation-p
-    (setf (plist-value object 'documentation) documentation)))
-
-;;; default if DOC-TYPE doesn't match one of the specified types
-(defmethod documentation (object doc-type)
-  (warn "unsupported DOCUMENTATION: type ~S for object ~S"
-	doc-type
-	(type-of object))
-  nil)
-
-;;; default if DOC-TYPE doesn't match one of the specified types
-(defmethod (setf documentation) (new-value object doc-type)
-  ;; CMU CL made this an error, but since ANSI says that even for supported
-  ;; doc types an implementation is permitted to discard docs at any time
-  ;; for any reason, this feels to me more like a warning. -- WHN 19991214
-  (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
-	doc-type
-	(type-of object))
-  new-value)
-
-(defmethod documentation ((object documentation-mixin) doc-type)
-  (declare (ignore doc-type))
-  (plist-value object 'documentation))
-
-(defmethod (setf documentation) (new-value
-				 (object documentation-mixin)
-				 doc-type)
-  (declare (ignore doc-type))
-  (setf (plist-value object 'documentation) new-value))
-
-(defmethod documentation ((slotd standard-slot-definition) doc-type)
-  (declare (ignore doc-type))
-  (slot-value slotd 'documentation))
-
-(defmethod (setf documentation) (new-value
-				 (slotd standard-slot-definition)
-				 doc-type)
-  (declare (ignore doc-type))
-  (setf (slot-value slotd 'documentation) new-value))
-
 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 
@@ -163,6 +133,10 @@
 		  (allocate-instance class)
 		  (allocate-standard-instance wrapper))))))
 
+(defmethod class-prototype ((class condition-class))
+  (with-slots (prototype) class
+    (or prototype (setf prototype (allocate-instance class)))))
+
 (defmethod class-direct-default-initargs ((class slot-class))
   (plist-value class 'direct-default-initargs))
 
@@ -171,6 +145,8 @@
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
+(defmethod (setf class-slot-cells) (new-value (class std-class))
+  (setf (plist-value class 'class-slot-cells) new-value))
 
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that
@@ -309,28 +285,42 @@
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))
-  (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
+  (setf (slot-value specl 'type)
+        `(eql ,(specializer-object specl)))
+  (setf (info :type :translator specl)
+        (constantly (make-member-type :members (list (specializer-object specl))))))
+
 
-(defun real-load-defclass (name metaclass-name supers slots other)
-  (let ((res (apply #'ensure-class name :metaclass metaclass-name
-		    :direct-superclasses supers
-		    :direct-slots slots
-		    :definition-source `((defclass ,name)
-					 ,*load-pathname*)
-		    other)))
-    res))
+(defun real-load-defclass (name metaclass-name supers slots other
+                           readers writers slot-names)
+  (with-single-package-locked-error (:symbol name "defining ~S as a class")
+    (%compiler-defclass name readers writers slot-names)
+    (let ((res (apply #'ensure-class name :metaclass metaclass-name
+                      :direct-superclasses supers
+                      :direct-slots slots
+                      :definition-source `((defclass ,name)
+                                           ,*load-pathname*)
+                      other)))
+      res)))
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class (find-class name nil) name all))
+(defun ensure-class (name &rest args)
+  (apply #'ensure-class-using-class
+	 (let ((class (find-class name nil)))
+	   (when (and class (eq name (class-name class)))
+	     ;; NAME is the proper name of CLASS, so redefine it
+	     class))
+	 name
+	 args))
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
     (set-class-type-translation (class-prototype meta) name)
-    (setf class (apply #'make-instance meta :name name initargs)
-	  (find-class name) class)
+    (setf class (apply #'make-instance meta :name name initargs))
+    (without-package-locks
+      (setf (find-class name) class))
     (set-class-type-translation class name)
     class))
 
@@ -340,7 +330,8 @@
     (unless (eq (class-of class) meta)
       (apply #'change-class class meta initargs))
     (apply #'reinitialize-instance class initargs)
-    (setf (find-class name) class)
+    (without-package-locks
+      (setf (find-class name) class))
     (set-class-type-translation class name)
     class))
 
@@ -455,7 +446,6 @@
 		 (direct-slots nil direct-slots-p)
 		 (direct-default-initargs nil direct-default-initargs-p)
 		 (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names))
   (cond (direct-superclasses-p
 	 (setq direct-superclasses
 	       (or direct-superclasses
@@ -485,15 +475,22 @@
       (setq direct-default-initargs
 	    (plist-value class 'direct-default-initargs)))
   (setf (plist-value class 'class-slot-cells)
-	(let (collect)
+	(let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+	      (collect '()))
 	  (dolist (dslotd direct-slots)
 	    (when (eq :class (slot-definition-allocation dslotd))
-	      (let ((initfunction (slot-definition-initfunction dslotd)))
-		(push (cons (slot-definition-name dslotd)
-			       (if initfunction
-				   (funcall initfunction)
-				   +slot-unbound+))
-                      collect))))
+	      ;; see CLHS 4.3.6
+	      (let* ((name (slot-definition-name dslotd))
+		     (old (assoc name old-class-slot-cells)))
+		(if (or (not old)
+			(eq t slot-names)
+			(member name slot-names))
+		    (let* ((initfunction (slot-definition-initfunction dslotd))
+			   (value (if initfunction
+				      (funcall initfunction)
+				      +slot-unbound+)))
+		      (push (cons name value) collect))
+		    (push old collect)))))
           (nreverse collect)))
   (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -505,6 +502,26 @@
   (add-direct-subclasses class direct-superclasses)
   (make-class-predicate class predicate-name)
   (update-class class nil)
+  (do* ((slots (slot-value class 'slots) (cdr slots))
+	(dupes nil))
+       ((null slots) (when dupes
+		       (style-warn
+			;; FIXME: the indentation request ("~4I")
+			;; below appears not to do anything.  Finding
+			;; out why would be nice.  -- CSR, 2003-04-24
+			"~@<slot names with the same SYMBOL-NAME but ~
+                         different SYMBOL-PACKAGE (possible package problem) ~
+                         for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
+			class
+			dupes)))
+    (let* ((slot (car slots))
+	   (oslots (remove (slot-definition-name slot) (cdr slots)
+			   :test #'string/= :key #'slot-definition-name)))
+      (when oslots
+	(pushnew (cons (slot-definition-name slot)
+		       (mapcar #'slot-definition-name oslots))
+		 dupes
+		 :test #'string= :key #'car))))
   (add-slot-accessors class direct-slots)
   (make-preliminary-layout class))
 
@@ -521,32 +538,33 @@
   (flet ((compute-preliminary-cpl (root)
 	   (let ((*allow-forward-referenced-classes-in-cpl-p* t))
 	     (compute-class-precedence-list root))))
-    (unless (class-finalized-p class)
-      (let ((name (class-name class)))
-	(setf (find-class name) class)
-	;; KLUDGE: This is fairly horrible.  We need to make a
-	;; full-fledged CLASSOID here, not just tell the compiler that
-	;; some class is forthcoming, because there are legitimate
-	;; questions one can ask of the type system, implemented in
-	;; terms of CLASSOIDs, involving forward-referenced classes. So.
-	(when (and (eq *boot-state* 'complete)
-		   (null (find-classoid name nil)))
-	  (setf (find-classoid name)
-		(make-standard-classoid :name name)))
-	(set-class-type-translation class name)
-	(let ((layout (make-wrapper 0 class))
-	      (classoid (find-classoid name)))
-	  (setf (layout-classoid layout) classoid)
-	  (setf (classoid-pcl-class classoid) class)
-	  (setf (slot-value class 'wrapper) layout)
-	  (let ((cpl (compute-preliminary-cpl class)))
-	    (setf (layout-inherits layout)
-		  (order-layout-inherits
-		   (map 'simple-vector #'class-wrapper
-			(reverse (rest cpl))))))
-	  (register-layout layout :invalidate t)
-	  (setf (classoid-layout classoid) layout)
-	  (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
+    (without-package-locks
+     (unless (class-finalized-p class)
+       (let ((name (class-name class)))
+	 (setf (find-class name) class)
+	 ;; KLUDGE: This is fairly horrible.  We need to make a
+	 ;; full-fledged CLASSOID here, not just tell the compiler that
+	 ;; some class is forthcoming, because there are legitimate
+	 ;; questions one can ask of the type system, implemented in
+	 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
+	 (when (and (eq *boot-state* 'complete)
+		    (null (find-classoid name nil)))
+	   (setf (find-classoid name)
+		 (make-standard-classoid :name name)))
+	 (set-class-type-translation class name)
+	 (let ((layout (make-wrapper 0 class))
+	       (classoid (find-classoid name)))
+	   (setf (layout-classoid layout) classoid)
+	   (setf (classoid-pcl-class classoid) class)
+	   (setf (slot-value class 'wrapper) layout)
+	   (let ((cpl (compute-preliminary-cpl class)))
+	     (setf (layout-inherits layout)
+		   (order-layout-inherits
+		    (map 'simple-vector #'class-wrapper
+			 (reverse (rest cpl))))))
+	   (register-layout layout :invalidate t)
+	   (setf (classoid-layout classoid) layout)
+	   (mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
 
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
@@ -569,21 +587,80 @@
 		    (apply #'update-dependent class dependent initargs))))
 
 (defmethod shared-initialize :after ((class condition-class) slot-names
-				     &key direct-superclasses)
+				     &key direct-slots direct-superclasses)
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (class-name class))))
-    (with-slots (wrapper class-precedence-list prototype predicate-name
+    (with-slots (wrapper class-precedence-list cpl-available-p
+                         prototype predicate-name
 			 (direct-supers direct-superclasses))
 	class
+      (setf (slot-value class 'direct-slots)
+	    (mapcar (lambda (pl) (make-direct-slotd class pl))
+		    direct-slots))
       (setf (slot-value class 'finalized-p) t)
       (setf (classoid-pcl-class classoid) class)
       (setq direct-supers direct-superclasses)
       (setq wrapper (classoid-layout classoid))
       (setq class-precedence-list (compute-class-precedence-list class))
-      (setq prototype (make-condition (class-name class)))
+      (setq cpl-available-p t)
       (add-direct-subclasses class direct-superclasses)
       (setq predicate-name (make-class-predicate-name (class-name class)))
-      (make-class-predicate class predicate-name))))
+      (make-class-predicate class predicate-name)
+      (setf (slot-value class 'slots) (compute-slots class))))
+  ;; Comment from Gerd's PCL, 2003-05-15:
+  ;;
+  ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
+  ;; override condition accessors with generic functions.  We do this
+  ;; differently.
+  (update-pv-table-cache-info class))
+
+(defmethod direct-slot-definition-class ((class condition-class)
+					 &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class condition-class)
+					    &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class condition-class))
+  (aver (slot-value class 'finalized-p))
+  nil)
+
+(defmethod compute-effective-slot-definition
+    ((class condition-class) slot-name dslotds)
+  (let ((slotd (call-next-method)))
+    (setf (slot-definition-reader-function slotd)
+	  (lambda (x)
+	    (handler-case (condition-reader-function x slot-name)
+	      ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
+	      ;; is unbound; maybe it should be a CELL-ERROR of some
+	      ;; sort?
+	      (error () (values (slot-unbound class x slot-name))))))
+    (setf (slot-definition-writer-function slotd)
+	  (lambda (v x)
+	    (condition-writer-function x v slot-name)))
+    (setf (slot-definition-boundp-function slotd)
+	  (lambda (x)
+	    (multiple-value-bind (v c)
+		(ignore-errors (condition-reader-function x slot-name))
+	      (declare (ignore v))
+	      (null c))))
+    slotd))
+
+(defmethod compute-slots ((class condition-class))
+  (mapcan (lambda (superclass)
+	    (mapcar (lambda (dslotd)
+		      (compute-effective-slot-definition
+		       class (slot-definition-name dslotd) (list dslotd)))
+		    (class-direct-slots superclass)))
+	  (reverse (slot-value class 'class-precedence-list))))
+
+(defmethod compute-slots :around ((class condition-class))
+  (let ((eslotds (call-next-method)))
+    (mapc #'initialize-internal-slot-functions eslotds)
+    eslotds))
 
 (defmethod shared-initialize :after
     ((slotd structure-slot-definition) slot-names &key
@@ -593,8 +670,8 @@
     (error "Structure slots must have :INSTANCE allocation.")))
 
 (defun make-structure-class-defstruct-form (name direct-slots include)
-  (let* ((conc-name (intern (format nil "~S structure class " name)))
-         (constructor (intern (format nil "~Aconstructor" conc-name)))
+  (let* ((conc-name (format-symbol *package* "~S structure class " name))
+         (constructor (format-symbol *package* "~Aconstructor" conc-name))
          (defstruct `(defstruct (,name
                                  ,@(when include
                                          `((:include ,(class-name include))))
@@ -641,13 +718,26 @@
                (cons nil nil))))
     (values defstruct-form constructor reader-names writer-names)))
 
+(defun make-defstruct-allocation-function (class)
+  (let ((dd (get-structure-dd (class-name class))))
+    (lambda ()
+      (let ((instance (%make-instance (dd-length dd)))
+	    (raw-index (dd-raw-index dd)))
+	(setf (%instance-layout instance)
+	      (sb-kernel::compiler-layout-or-lose (dd-name dd)))
+	(when raw-index
+	  (setf (%instance-ref instance raw-index)
+		(make-array (dd-raw-length dd)
+			    :element-type '(unsigned-byte 32))))
+	instance))))
+
 (defmethod shared-initialize :after
-      ((class structure-class)
-       slot-names
-       &key (direct-superclasses nil direct-superclasses-p)
-	    (direct-slots nil direct-slots-p)
-	    direct-default-initargs
-	    (predicate-name nil predicate-name-p))
+    ((class structure-class)
+     slot-names
+     &key (direct-superclasses nil direct-superclasses-p)
+     (direct-slots nil direct-slots-p)
+     direct-default-initargs
+     (predicate-name nil predicate-name-p))
   (declare (ignore slot-names direct-default-initargs))
   (if direct-superclasses-p
       (setf (slot-value class 'direct-superclasses)
@@ -665,35 +755,37 @@
 		    (mapcar (lambda (pl)
 			      (when defstruct-p
 				(let* ((slot-name (getf pl :name))
-				       (acc-name
-					(format nil
-						"~S structure class ~A"
-						name slot-name))
-				       (accessor (intern acc-name)))
+				       (accessor
+					(format-symbol *package*
+						       "~S structure class ~A"
+						       name slot-name)))
 				  (setq pl (list* :defstruct-accessor-symbol
 						  accessor pl))))
 			      (make-direct-slotd class pl))
 			    direct-slots)))
 	(setq direct-slots (slot-value class 'direct-slots)))
-    (when defstruct-p
-      (let ((include (car (slot-value class 'direct-superclasses))))
-        (multiple-value-bind (defstruct-form constructor reader-names writer-names)
-            (make-structure-class-defstruct-form name direct-slots include)
-          (unless (structure-type-p name) (eval defstruct-form))
-          (mapc (lambda (dslotd reader-name writer-name)
-		  (let* ((reader (gdefinition reader-name))
-			 (writer (when (gboundp writer-name)
-				   (gdefinition writer-name))))
-		    (setf (slot-value dslotd 'internal-reader-function)
-			  reader)
-		    (setf (slot-value dslotd 'internal-writer-function)
-			  writer)))
-                direct-slots reader-names writer-names)
-          (setf (slot-value class 'defstruct-form) defstruct-form)
-          (setf (slot-value class 'defstruct-constructor) constructor))))
+    (if defstruct-p
+	(let ((include (car (slot-value class 'direct-superclasses))))
+	  (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+	      (make-structure-class-defstruct-form name direct-slots include)
+	    (unless (structure-type-p name) (eval defstruct-form))
+	    (mapc (lambda (dslotd reader-name writer-name)
+		    (let* ((reader (gdefinition reader-name))
+			   (writer (when (gboundp writer-name)
+				     (gdefinition writer-name))))
+		      (setf (slot-value dslotd 'internal-reader-function)
+			    reader)
+		      (setf (slot-value dslotd 'internal-writer-function)
+			    writer)))
+		  direct-slots reader-names writer-names)
+	    (setf (slot-value class 'defstruct-form) defstruct-form)
+	    (setf (slot-value class 'defstruct-constructor) constructor)))
+	(setf (slot-value class 'defstruct-constructor)
+	      (make-defstruct-allocation-function class)))
     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)
-            (compute-class-precedence-list class))
+          (compute-class-precedence-list class))
+    (setf (slot-value class 'cpl-available-p) t)
     (setf (slot-value class 'slots) (compute-slots class))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
@@ -710,7 +802,7 @@
     (make-class-predicate class predicate-name)
     (add-slot-accessors class direct-slots)))
 
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
+(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'structure-direct-slot-definition))
 
@@ -725,18 +817,26 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
-	   (let ((gf (ensure-generic-function gfspec)))
-	     (case r/w
-	       (r (if (eq add/remove 'add)
-		      (add-reader-method class gf name)
-		      (remove-reader-method class gf)))
-	       (w (if (eq add/remove 'add)
-		      (add-writer-method class gf name)
-		      (remove-writer-method class gf)))))))
+           (let ((gf (if (fboundp gfspec)
+                         (without-package-locks 
+                           (ensure-generic-function gfspec))
+                         (ensure-generic-function 
+                          gfspec :lambda-list (case r/w 
+                                                (r '(object)) 
+                                                (w '(new-value object)))))))
+             (case r/w
+               (r (if (eq add/remove 'add)
+                      (add-reader-method class gf name)
+                      (remove-reader-method class gf)))
+               (w (if (eq add/remove 'add)
+                      (add-writer-method class gf name)
+                      (remove-writer-method class gf)))))))
     (dolist (dslotd dslotds)
       (let ((slot-name (slot-definition-name dslotd)))
-	(dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
-	(dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
+        (dolist (r (slot-definition-readers dslotd)) 
+          (fix r slot-name 'r))
+        (dolist (w (slot-definition-writers dslotd)) 
+          (fix w slot-name 'w))))))
 
 (defun add-direct-subclasses (class supers)
   (dolist (super supers)
@@ -775,36 +875,44 @@
   ;; 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))
+  (without-package-locks
+   (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)))
-    (finalize-inheritance class)
-    (return-from update-class))
-  (when (or finalizep (class-finalized-p class)
-	    (not (class-has-a-forward-referenced-superclass-p class)))
-    (setf (find-class (class-name class)) 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))
-    (update-ctors 'finalize-inheritance :class class))
-  (unless finalizep
-    (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
+     (setf (find-class (class-name class)) 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-initargs class (compute-default-initargs class))
+     (update-ctors 'finalize-inheritance :class class))
+   (unless finalizep
+     (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))))
 
 (defun update-cpl (class cpl)
   (if (class-finalized-p class)
-      (unless (equal (class-precedence-list class) cpl)
+      (unless (and (equal (class-precedence-list class) cpl)
+		   (dolist (c cpl t)
+		     (when (position :class (class-direct-slots c)
+				     :key #'slot-definition-allocation)
+		       (return nil))))
 	;; comment from the old CMU CL sources:
 	;;   Need to have the cpl setup before update-lisp-class-layout
 	;;   is called on CMU CL.
 	(setf (slot-value class 'class-precedence-list) cpl)
+        (setf (slot-value class 'cpl-available-p) t)
 	(force-cache-flushes class))
-      (setf (slot-value class 'class-precedence-list) cpl))
+      (progn
+        (setf (slot-value class 'class-precedence-list) cpl)
+        (setf (slot-value class 'cpl-available-p) t)))
   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
@@ -865,7 +973,8 @@
 	      wrapper nwrapper))
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
-	(update-pv-table-cache-info class)))))
+	(update-pv-table-cache-info class)
+	(maybe-update-standard-class-locations class)))))
 
 (defun compute-class-slots (eslotds)
   (let (collect)
@@ -892,33 +1001,24 @@
 		   (update-gf-dfun class gf))
 		 gf-table)))))
 
-(defun update-inits (class inits)
+(defun update-initargs (class inits)
   (setf (plist-value class 'default-initargs) inits))
 
 (defmethod compute-default-initargs ((class slot-class))
-  (let ((cpl (class-precedence-list class))
-	(direct (class-direct-default-initargs class)))
-    (labels ((walk (tail)
-	       (if (null tail)
-		   nil
-		   (let ((c (pop tail)))
-		     (append (if (eq c class)
-				 direct
-				 (class-direct-default-initargs c))
-			     (walk tail))))))
-      (let ((initargs (walk cpl)))
-	(delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
+  (let ((initargs (loop for c in (class-precedence-list class)
+			append (class-direct-default-initargs c))))
+    (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
 
 ;;;; protocols for constructing direct and effective slot definitions
 
-(defmethod direct-slot-definition-class ((class std-class) initargs)
+(defmethod direct-slot-definition-class ((class std-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'standard-direct-slot-definition))
 
 (defun make-direct-slotd (class initargs)
   (let ((initargs (list* :class class initargs)))
     (apply #'make-instance
-	   (direct-slot-definition-class class initargs)
+	   (apply #'direct-slot-definition-class class initargs)
 	   initargs)))
 
 (defmethod compute-slots ((class std-class))
@@ -948,15 +1048,35 @@
 	(location -1))
     (dolist (eslotd eslotds eslotds)
       (setf (slot-definition-location eslotd)
-	    (ecase (slot-definition-allocation eslotd)
+	    (case (slot-definition-allocation eslotd)
 	      (:instance
 	       (incf location))
 	      (:class
 	       (let* ((name (slot-definition-name eslotd))
-		      (from-class (slot-definition-allocation-class eslotd))
-		      (cell (assq name (class-slot-cells from-class))))
+		      (from-class 
+		       (or 
+			(slot-definition-allocation-class eslotd)
+			;; we get here if the user adds an extra slot
+			;; himself...
+			(setf (slot-definition-allocation-class eslotd) 
+			      class)))
+		      ;; which raises the question of what we should
+		      ;; do if we find that said user has added a slot
+		      ;; with the same name as another slot...
+		      (cell (or (assq name (class-slot-cells from-class))
+				(setf (class-slot-cells from-class)
+				      (cons (cons name +slot-unbound+)
+					    (class-slot-cells from-class))))))
 		 (aver (consp cell))
-		 cell))))
+		 (if (eq +slot-unbound+ (cdr cell))
+		     ;; We may have inherited an initfunction
+		     (let ((initfun (slot-definition-initfunction eslotd)))
+		       (if initfun
+			   (rplacd cell (funcall initfun))
+			   cell))
+		     cell)))))
+      (unless (slot-definition-class eslotd)
+	(setf (slot-definition-class eslotd) class))
       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))
@@ -990,7 +1110,7 @@
 	  (instance-slots ())
 	  (class-slots ()))
       (dolist (slotd all-slotds)
-	(ecase (slot-definition-allocation slotd)
+	(case (slot-definition-allocation slotd)
 	  (:instance (push slotd instance-slots))
 	  (:class (push slotd class-slots))))
       (let ((layout (compute-layout instance-slots)))
@@ -1025,14 +1145,14 @@
 (defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
   (declare (ignore name))
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-	 (class (effective-slot-definition-class class initargs)))
+	 (class (apply #'effective-slot-definition-class class initargs)))
     (apply #'make-instance class initargs)))
 
-(defmethod effective-slot-definition-class ((class std-class) initargs)
+(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'standard-effective-slot-definition))
 
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
+(defmethod effective-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'structure-effective-slot-definition))
 
@@ -1217,7 +1337,14 @@
 	(with-pcl-lock
 	  (update-lisp-class-layout class nwrapper)
 	  (setf (slot-value class 'wrapper) nwrapper)
-	  (invalidate-wrapper owrapper :flush nwrapper))))))
+	  ;; Use :OBSOLETE instead of :FLUSH if any superclass has
+	  ;; been obsoleted.
+ 	  (if (find-if (lambda (x) 
+ 			 (and (consp x) (eq :obsolete (car x))))
+ 		       (layout-inherits owrapper) 
+ 		       :key #'layout-invalid)
+ 	      (invalidate-wrapper owrapper :obsolete nwrapper)
+	      (invalidate-wrapper owrapper :flush nwrapper)))))))
 
 (defun flush-cache-trap (owrapper nwrapper instance)
   (declare (ignore owrapper))
@@ -1241,7 +1368,9 @@
 	class)))
 
 (defmethod make-instances-obsolete ((class symbol))
-  (make-instances-obsolete (find-class class)))
+  (make-instances-obsolete (find-class class))
+  ;; ANSI wants the class name when called with a symbol.
+  class)
 
 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
 ;;; see an obsolete instance. The times when it is called are:
@@ -1299,15 +1428,25 @@
 	     (added ())
 	     (discarded ())
 	     (plist ()))
-	;; local  --> local	transfer
-	;; local  --> shared       discard
-	;; local  -->  --	  discard
-	;; shared --> local	transfer
-	;; shared --> shared       discard
-	;; shared -->  --	  discard
-	;;  --    --> local	add
+
+	;; local  --> local	transfer value
+	;; local  --> shared    discard value, discard slot
+	;; local  -->  --	discard slot
+	;; shared --> local	transfer value
+	;; shared --> shared    -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
+	;; shared -->  --	discard value
+	;;  --    --> local	add slot
 	;;  --    --> shared	--
 
+	;; Collect class slots from inherited wrappers. Needed for
+	;; shared -> local transfers of inherited slots.
+	(let ((inherited (layout-inherits owrapper)))
+	  (loop for i from (1- (length inherited)) downto 0
+		for layout = (aref inherited i)
+		when (typep layout 'wrapper)
+		do (dolist (slot (wrapper-class-slots layout))
+		     (pushnew slot oclass-slots :key #'car))))
+
 	;; Go through all the old local slots.
         (let ((opos 0))
           (dolist (name olayout)
@@ -1326,11 +1465,8 @@
 	  (let ((name (car oclass-slot-and-val))
 		(val (cdr oclass-slot-and-val)))
 	    (let ((npos (posq name nlayout)))
-	      (if npos
-		  (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
-		  (progn (push name discarded)
-			 (unless (eq val +slot-unbound+)
-			   (setf (getf plist name) val)))))))
+	      (when npos
+		(setf (clos-slots-ref nslots npos) val)))))
 
 	;; Go through all the new local slots to compute the added slots.
 	(dolist (nlocal nlayout)