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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 5e5f933..ca020b4 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,57 +118,9 @@
 (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
 
-(defmethod class-finalized-p ((class pcl-class))
-  (with-slots (wrapper) class
-    (not (null wrapper))))
-
 (defmethod class-prototype ((class std-class))
   (with-slots (prototype) class
     (or prototype (setq prototype (allocate-instance class)))))
@@ -322,30 +288,36 @@
 		    :definition-source `((defclass ,name)
 					 ,*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
-    ;; does not yet exist. Maybe should return NIL in that case as RES
-    ;; is not useful to the user?
-    (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res)))))
+    res))
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class name (find-class name nil) 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 (name (class null) &rest args &key)
+(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)
+    (set-class-type-translation class name)
     class))
 
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
+(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
-    (unless (eq (class-of class) meta) (change-class class meta))
+    (unless (eq (class-of class) meta)
+      (apply #'change-class class meta initargs))
     (apply #'reinitialize-instance class initargs)
     (setf (find-class name) class)
+    (set-class-type-translation class name)
     class))
 
 (defmethod class-predicate-name ((class t))
@@ -354,12 +326,11 @@
 (defun fix-super (s)
   (cond ((classp s) s)
         ((not (legal-class-name-p s))
-          (error "~S is not a class or a legal class name." s))
+	 (error "~S is not a class or a legal class name." s))
         (t
-          (or (find-class s nil)
-              (setf (find-class s)
-                      (make-instance 'forward-referenced-class
-                                     :name s))))))
+	 (or (find-class s nil)
+	     (make-instance 'forward-referenced-class
+			    :name s)))))
 
 (defun ensure-class-values (class args)
   (let* ((initargs (copy-list args))
@@ -382,45 +353,77 @@
     ;; However, after playing around a little, I couldn't find that
     ;; way, so I've left it as is, but if someone does come up with a
     ;; better way... -- CSR, 2002-09-08
-    (loop for (slot . more) on (getf initargs :direct-slots)
-	  for slot-name = (getf slot :name)
-	  if (some (lambda (s) (eq slot-name (getf s :name))) more) 
-	  ;; FIXME: It's quite possible that we ought to define an
-	  ;; SB-INT:PROGRAM-ERROR function to signal these and other
-	  ;; errors throughout the code base that are required to be
-	  ;; of type PROGRAM-ERROR.
-	  do (error 'simple-program-error 
-		    :format-control "More than one direct slot with name ~S."
-		    :format-arguments (list slot-name))
-	  else 
-	  do (loop for (option value . more) on slot by #'cddr
-		   when (and (member option 
-				     '(:allocation :type 
+    (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
+	((endp direct-slots) nil)
+      (destructuring-bind (slot &rest more) direct-slots
+	(let ((slot-name (getf slot :name)))
+	  (when (some (lambda (s) (eq slot-name (getf s :name))) more)
+	    ;; FIXME: It's quite possible that we ought to define an
+	    ;; SB-INT:PROGRAM-ERROR function to signal these and other
+	    ;; errors throughout the codebase that are required to be
+	    ;; of type PROGRAM-ERROR.
+	    (error 'simple-program-error
+		   :format-control "~@<There is more than one direct slot ~
+                                   with name ~S.~:>"
+		   :format-arguments (list slot-name)))
+	  (do ((stuff slot (cddr stuff)))
+	      ((endp stuff) nil)
+	    (destructuring-bind (option value &rest more) stuff
+	      (cond
+		((and (member option '(:allocation :type
 				       :initform :documentation))
-			     (not (eq unsupplied
-				      (getf more option unsupplied)))) 
-		   do (error 'simple-program-error 
-			     :format-control "Duplicate slot option ~S for slot ~S."
-			     :format-arguments (list option slot-name))))
+		      (not (eq unsupplied
+			       (getf more option unsupplied))))
+		 (error 'simple-program-error
+			:format-control "~@<Duplicate slot option ~S for ~
+                                        slot named ~S.~:>"
+			:format-arguments (list option slot-name)))
+		((and (eq option :readers)
+		      (notevery #'symbolp value))
+		 (error 'simple-program-error
+			:format-control "~@<Slot reader names for slot ~
+                                        named ~S must be symbols.~:>"
+			:format-arguments (list slot-name)))
+		((and (eq option :initargs)
+		      (notevery #'symbolp value))
+		 (error 'simple-program-error
+			:format-control "~@<Slot initarg names for slot ~
+                                        named ~S must be symbols.~:>"
+			:format-arguments (list slot-name)))))))))
     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
 	  for name = (car initarg) 
 	  when (some (lambda (a) (eq (car a) name)) more) 
 	  do (error 'simple-program-error 
-		    :format-control "Duplicate initialization argument ~
-                                     name ~S in :default-initargs of class ~A."
+		    :format-control "~@<Duplicate initialization argument ~
+                                    name ~S in :DEFAULT-INITARGS.~:>"
 		    :format-arguments (list name class)))
-    (loop (unless (remf initargs :metaclass) (return)))
+    (let ((metaclass 0)
+	  (default-initargs 0))
+      (do ((args initargs (cddr args)))
+	  ((endp args) nil)
+	(case (car args)
+	  (:metaclass
+	   (when (> (incf metaclass) 1)
+	     (error 'simple-program-error
+		    :format-control "~@<More than one :METACLASS ~
+                                    option specified.~:>")))
+	  (:direct-default-initargs
+	   (when (> (incf default-initargs) 1)
+	     (error 'simple-program-error
+		    :format-control "~@<More than one :DEFAULT-INITARGS ~
+                                    option specified.~:>"))))))
+    (remf initargs :metaclass)
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))
-    (values meta
-            (list* :direct-superclasses
-                   (and (neq supplied-supers unsupplied)
-                        (mapcar #'fix-super supplied-supers))
-                   :direct-slots
-                   (and (neq supplied-slots unsupplied) supplied-slots)
-                   initargs))))
+    (values
+     meta
+     (nconc
+      (when (neq supplied-supers unsupplied)
+	(list :direct-superclasses (mapcar #'fix-super supplied-supers)))
+      (when (neq supplied-slots unsupplied)
+	(list :direct-slots supplied-slots))
+      initargs))))
 
-
 (defmethod shared-initialize :after
 	   ((class std-class)
 	    slot-names
@@ -428,7 +431,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
@@ -458,15 +460,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)
@@ -476,9 +485,71 @@
 				     (make-class-predicate-name (class-name
 								 class))))))
   (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
   (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
+  (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))
+
+(defmethod shared-initialize :after ((class forward-referenced-class)
+				     slot-names &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (make-preliminary-layout class))
+
+(defvar *allow-forward-referenced-classes-in-cpl-p* nil)
+
+;;; Give CLASS a preliminary layout if it doesn't have one already, to
+;;; make it known to the type system.
+(defun make-preliminary-layout (class)
+  (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)))))))
+
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
   (declare (ignore slot-names name))
@@ -499,10 +570,85 @@
 		  (lambda (dependent)
 		    (apply #'update-dependent class dependent initargs))))
 
-(defmethod shared-initialize :after ((slotd structure-slot-definition)
-				     slot-names
-				     &key (allocation :instance))
+(defmethod shared-initialize :after ((class condition-class) slot-names
+				     &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
+			 (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)))
+      (add-direct-subclasses class direct-superclasses)
+      (setq predicate-name (make-class-predicate-name (class-name class)))
+      (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
+     (allocation :instance) allocation-class)
+  (declare (ignore slot-names allocation-class))
   (unless (eq allocation :instance)
     (error "Structure slots must have :INSTANCE allocation.")))
 
@@ -521,18 +667,14 @@
                                     +slot-unbound+))
                                 direct-slots)))
          (reader-names (mapcar (lambda (slotd)
-                                 (intern (format nil
-                                                 "~A~A reader"
-                                                 conc-name
-                                                 (slot-definition-name
-                                                  slotd))))
+                                 (list 'slot-accessor name
+				       (slot-definition-name slotd)
+				       'reader))
                                direct-slots))
          (writer-names (mapcar (lambda (slotd)
-                                 (intern (format nil
-                                                 "~A~A writer"
-                                                 conc-name
-                                                 (slot-definition-name
-                                                  slotd))))
+                                 (list 'slot-accessor name
+				       (slot-definition-name slotd)
+				       'writer))
                                direct-slots))
          (readers-init
            (mapcar (lambda (slotd reader-name)
@@ -559,6 +701,19 @@
                (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
@@ -593,29 +748,32 @@
 			      (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))
     (setf (slot-value class 'slots) (compute-slots class))
-    (let ((lclass (cl:find-class (class-name class))))
-      (setf (sb-kernel:class-pcl-class lclass) class)
-      (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass)))
+    (let ((lclass (find-classoid (class-name class))))
+      (setf (classoid-pcl-class lclass) class)
+      (setf (slot-value class 'wrapper) (classoid-layout lclass)))
+    (setf (slot-value class 'finalized-p) t)
     (update-pv-table-cache-info class)
     (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -626,8 +784,8 @@
                                         (class-name class))))))
     (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))
 
@@ -642,7 +800,10 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
-	   (let ((gf (ensure-generic-function gfspec)))
+	   (let* ((ll (case r/w (r '(object)) (w '(new-value object))))
+		  (gf (if (fboundp gfspec)
+			  (ensure-generic-function gfspec)
+			  (ensure-generic-function gfspec :lambda-list ll))))
 	     (case r/w
 	       (r (if (eq add/remove 'add)
 		      (add-reader-method class gf name)
@@ -667,6 +828,17 @@
 
 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
+
+(defmethod finalize-inheritance ((class forward-referenced-class))
+  ;; FIXME: should we not be thinking a bit about what kinds of error
+  ;; we're throwing?  Maybe we need a clos-error type to mix in?  Or
+  ;; possibly a forward-referenced-class-error, though that's
+  ;; difficult given e.g. class precedence list calculations...
+  (error
+   "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
+       ~2I~_~S~:>"
+   class))
+
 
 (defun class-has-a-forward-referenced-superclass-p (class)
   (or (forward-referenced-class-p class)
@@ -688,6 +860,7 @@
     (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
@@ -696,14 +869,18 @@
     ;; (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-make-instance-function-table 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.
@@ -738,8 +915,10 @@
 				  :key #'slot-definition-location)))
 	   (nslots (length nlayout))
 	   (nwrapper-class-slots (compute-class-slots class-slots))
-	   (owrapper (class-wrapper class))
-	   (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+	   (owrapper (when (class-finalized-p class)
+		       (class-wrapper class)))
+	   (olayout (when owrapper
+		      (wrapper-instance-slots-layout owrapper)))
 	   (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
 	   (nwrapper
 	    (cond ((null owrapper)
@@ -766,9 +945,10 @@
 	      (wrapper-class-slots nwrapper) nwrapper-class-slots
 	      (wrapper-no-of-instance-slots nwrapper) nslots
 	      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)
@@ -778,27 +958,6 @@
             collect))
     (nreverse collect)))
 
-(defun compute-layout (cpl instance-eslotds)
-  (let* ((names
-	   (let (collect)
-	     (dolist (eslotd instance-eslotds)
-	       (when (eq (slot-definition-allocation eslotd) :instance)
-		 (push (slot-definition-name eslotd) collect)))
-             (nreverse collect)))
-	 (order ()))
-    (labels ((rwalk (tail)
-	       (when tail
-		 (rwalk (cdr tail))
-		 (dolist (ss (class-slots (car tail)))
-		   (let ((n (slot-definition-name ss)))
-		     (when (member n names)
-		       (setq order (cons n order)
-			     names (remove n names))))))))
-      (rwalk (if (slot-boundp (car cpl) 'slots)
-		 cpl
-		 (cdr cpl)))
-      (reverse (append names order)))))
-
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
 	     (let ((cpl (class-precedence-list class)))
@@ -816,33 +975,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))
@@ -852,44 +1002,98 @@
   ;; The list is in most-specific-first order.
   (let ((name-dslotds-alist ()))
     (dolist (c (class-precedence-list class))
-      (let ((dslotds (class-direct-slots c)))
-	(dolist (d dslotds)
-	  (let* ((name (slot-definition-name d))
-		 (entry (assq name name-dslotds-alist)))
-	    (if entry
-		(push d (cdr entry))
-		(push (list name d) name-dslotds-alist))))))
+      (dolist (slot (class-direct-slots c))
+	(let* ((name (slot-definition-name slot))
+	       (entry (assq name name-dslotds-alist)))
+	  (if entry
+	      (push slot (cdr entry))
+	      (push (list name slot) name-dslotds-alist)))))
     (mapcar (lambda (direct)
 	      (compute-effective-slot-definition class
+						 (car direct)
 						 (nreverse (cdr direct))))
 	    name-dslotds-alist)))
 
-(defmethod compute-slots :around ((class std-class))
+(defmethod compute-slots ((class standard-class))
+  (call-next-method))
+
+(defmethod compute-slots :around ((class standard-class))
   (let ((eslotds (call-next-method))
-	(cpl (class-precedence-list class))
-	(instance-slots ())
-	(class-slots    ()))
-    (dolist (eslotd eslotds)
-      (let ((alloc (slot-definition-allocation eslotd)))
-	(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)
-	      (position (slot-definition-name eslotd) nlayout))))
-    (dolist (eslotd class-slots)
+	(location -1))
+    (dolist (eslotd eslotds eslotds)
       (setf (slot-definition-location eslotd)
-	    (assoc (slot-definition-name eslotd)
-		   (class-slot-cells (slot-definition-class eslotd)))))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
+	    (ecase (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))))
+		 (aver (consp 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)))))
+      (initialize-internal-slot-functions eslotd))))
+
+(defmethod compute-slots ((class funcallable-standard-class))
+  (call-next-method))
+
+(defmethod compute-slots :around ((class funcallable-standard-class))
+  (labels ((instance-slot-names (slotds)
+	     (let (collect)
+	       (dolist (slotd slotds (nreverse collect))
+		 (when (eq (slot-definition-allocation slotd) :instance)
+		   (push (slot-definition-name slotd) collect)))))
+	   ;; This sorts slots so that slots of classes later in the CPL
+           ;; come before slots of other classes.  This is crucial for
+           ;; funcallable instances because it ensures that the slots of
+           ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
+           ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
+           ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
+           ;; a funcallable instance.
+	   (compute-layout (eslotds)
+	     (let ((first ())
+		   (names (instance-slot-names eslotds)))
+	       (dolist (class
+			(reverse (class-precedence-list class))
+			(nreverse (nconc names first)))
+		 (dolist (ss (class-slots class))
+		   (let ((name (slot-definition-name ss)))
+		     (when (member name names)
+		       (push name first)
+		       (setq names (delete name names)))))))))
+    (let ((all-slotds (call-next-method))
+	  (instance-slots ())
+	  (class-slots ()))
+      (dolist (slotd all-slotds)
+	(ecase (slot-definition-allocation slotd)
+	  (:instance (push slotd instance-slots))
+	  (:class (push slotd class-slots))))
+      (let ((layout (compute-layout instance-slots)))
+	(dolist (slotd instance-slots)
+	  (setf (slot-definition-location slotd)
+		(position (slot-definition-name slotd) layout))
+	  (initialize-internal-slot-functions slotd)))
+      (dolist (slotd class-slots)
+	(let ((name (slot-definition-name slotd))
+	      (from-class (slot-definition-allocation-class slotd)))
+	  (setf (slot-definition-location slotd)
+		(assoc name (class-slot-cells from-class)))
+	  (aver (consp (slot-definition-location slotd)))
+	  (initialize-internal-slot-functions slotd)))
+      all-slotds)))
 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
 	    (mapcar (lambda (dslotd)
-		      (compute-effective-slot-definition class
-							 (list dslotd)))
+		      (compute-effective-slot-definition
+		       class
+		       (slot-definition-name dslotd)
+		       (list dslotd)))
 		    (class-direct-slots superclass)))
 	  (reverse (slot-value class 'class-precedence-list))))
 
@@ -898,16 +1102,17 @@
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
-(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
+(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))
 
@@ -918,6 +1123,7 @@
 	 (initform nil)
 	 (initargs nil)
 	 (allocation nil)
+	 (allocation-class nil)
 	 (type t)
 	 (namep  nil)
 	 (initp  nil)
@@ -935,6 +1141,7 @@
 		  initp t)))
 	(unless allocp
 	  (setq allocation (slot-definition-allocation slotd)
+		allocation-class (slot-definition-class slotd)
 		allocp t))
 	(setq initargs (append (slot-definition-initargs slotd) initargs))
 	(let ((slotd-type (slot-definition-type slotd)))
@@ -946,6 +1153,7 @@
 	  :initfunction initfunction
 	  :initargs initargs
 	  :allocation allocation
+	  :allocation-class allocation-class
 	  :type type
 	  :class class)))
 
@@ -1063,7 +1271,7 @@
 ;;; 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)
+;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
 ;;;                    :UNINITIALIZED)))
 ;;;
 ;;; Thanks to Gerd Moellmann for the explanation.  -- CSR, 2002-10-29
@@ -1079,17 +1287,24 @@
 	      ;; 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))
+	      (eq (layout-invalid owrapper) t))
       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
 				    class)))
 	(setf (wrapper-instance-slots-layout nwrapper)
 	      (wrapper-instance-slots-layout owrapper))
 	(setf (wrapper-class-slots nwrapper)
 	      (wrapper-class-slots owrapper))
-	(sb-sys:without-interrupts
+	(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))
@@ -1106,14 +1321,16 @@
 	    (wrapper-instance-slots-layout owrapper))
       (setf (wrapper-class-slots nwrapper)
 	    (wrapper-class-slots owrapper))
-      (sb-sys:without-interrupts
+      (with-pcl-lock
 	(update-lisp-class-layout class nwrapper)
 	(setf (slot-value class 'wrapper) nwrapper)
 	(invalidate-wrapper owrapper :obsolete nwrapper)
 	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:
@@ -1171,15 +1388,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)
@@ -1198,11 +1425,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)