0.9.14.26:

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f5a0172..28bbf00 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -30,8 +30,8 @@
     (boundp (slot-definition-boundp-function slotd))))
 
 (defmethod (setf slot-accessor-function) (function
     (boundp (slot-definition-boundp-function slotd))))
 
 (defmethod (setf slot-accessor-function) (function

-                                         (slotd effective-slot-definition)
-                                         type)
+                                          (slotd effective-slot-definition)
+                                          type)

   (ecase type
     (reader (setf (slot-definition-reader-function slotd) function))
     (writer (setf (slot-definition-writer-function slotd) function))
   (ecase type
     (reader (setf (slot-definition-reader-function slotd) function))
     (writer (setf (slot-definition-writer-function slotd) function))

@@ -46,56 +46,65 @@
   (let ((flags (slot-value slotd 'accessor-flags)))
     (declare (type fixnum flags))
     (if (eq type 'all)
   (let ((flags (slot-value slotd 'accessor-flags)))
     (declare (type fixnum flags))
     (if (eq type 'all)

-       (eql +slotd-all-function-std-p+ flags)
-       (let ((mask (ecase type
-                     (reader +slotd-reader-function-std-p+)
-                     (writer +slotd-writer-function-std-p+)
-                     (boundp +slotd-boundp-function-std-p+))))
-         (declare (type fixnum mask))
-         (not (zerop (the fixnum (logand mask flags))))))))
+        (eql +slotd-all-function-std-p+ flags)
+        (let ((mask (ecase type
+                      (reader +slotd-reader-function-std-p+)
+                      (writer +slotd-writer-function-std-p+)
+                      (boundp +slotd-boundp-function-std-p+))))
+          (declare (type fixnum mask))
+          (not (zerop (the fixnum (logand mask flags))))))))

 
 (defmethod (setf slot-accessor-std-p) (value
 
 (defmethod (setf slot-accessor-std-p) (value

-                                      (slotd effective-slot-definition)
-                                      type)
+                                       (slotd effective-slot-definition)
+                                       type)

   (let ((mask (ecase type
   (let ((mask (ecase type

-               (reader +slotd-reader-function-std-p+)
-               (writer +slotd-writer-function-std-p+)
-               (boundp +slotd-boundp-function-std-p+)))
-       (flags (slot-value slotd 'accessor-flags)))
+                (reader +slotd-reader-function-std-p+)
+                (writer +slotd-writer-function-std-p+)
+                (boundp +slotd-boundp-function-std-p+)))
+        (flags (slot-value slotd 'accessor-flags)))

     (declare (type fixnum mask flags))
     (setf (slot-value slotd 'accessor-flags)
     (declare (type fixnum mask flags))
     (setf (slot-value slotd 'accessor-flags)

-         (if value
-             (the fixnum (logior mask flags))
-             (the fixnum (logand (the fixnum (lognot mask)) flags)))))
+          (if value
+              (the fixnum (logior mask flags))
+              (the fixnum (logand (the fixnum (lognot mask)) flags)))))

   value)
 
 (defmethod initialize-internal-slot-functions ((slotd
   value)
 
 (defmethod initialize-internal-slot-functions ((slotd

-                                               effective-slot-definition))
+                                                effective-slot-definition))

   (let* ((name (slot-value slotd 'name))
   (let* ((name (slot-value slotd 'name))

-        (class (slot-value slotd 'class)))
-    (let ((table (or (gethash name *name->class->slotd-table*)
-                    (setf (gethash name *name->class->slotd-table*)
-                          (make-hash-table :test 'eq :size 5)))))
-      (setf (gethash class table) slotd))
+         (class (slot-value slotd '%class)))

     (dolist (type '(reader writer boundp))
       (let* ((gf-name (ecase type
     (dolist (type '(reader writer boundp))
       (let* ((gf-name (ecase type

-                             (reader 'slot-value-using-class)
-                             (writer '(setf slot-value-using-class))
-                             (boundp 'slot-boundp-using-class)))
-            (gf (gdefinition gf-name)))
-       (compute-slot-accessor-info slotd type gf)))
-    (initialize-internal-slot-gfs name)))
+                              (reader 'slot-value-using-class)
+                              (writer '(setf slot-value-using-class))
+                              (boundp 'slot-boundp-using-class)))
+             (gf (gdefinition gf-name)))
+        (compute-slot-accessor-info slotd type gf)))))

 
 

+;;; 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)
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)

-                                      type gf)
+                                       type gf)

   (let* ((name (slot-value slotd 'name))
   (let* ((name (slot-value slotd 'name))

-        (class (slot-value slotd 'class))
-        (old-slotd (find-slot-definition class name))
-        (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
+         (class (slot-value slotd '%class))
+         (old-slotd (find-slot-definition class name))
+         (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))

     (multiple-value-bind (function std-p)
     (multiple-value-bind (function std-p)

-       (if (eq *boot-state* 'complete)
-           (get-accessor-method-function gf type class slotd)
-           (get-optimized-std-accessor-method-function class slotd type))
+        (if (eq *boot-state* 'complete)
+            (get-accessor-method-function gf type class slotd)
+            (get-optimized-std-accessor-method-function class slotd type))

       (setf (slot-accessor-std-p slotd type) std-p)
       (setf (slot-accessor-function slotd type) function))
     (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
       (setf (slot-accessor-std-p slotd type) std-p)
       (setf (slot-accessor-function slotd type) function))
     (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))

@@ -104,68 +113,24 @@
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
 \f
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
 \f

-(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))
-\f

 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 
 ;;;; 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)))))
-
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype wrapper defstruct-constructor) class
-    (or prototype
-       (setq prototype
-             (if defstruct-constructor
-                 (allocate-instance class)
-                 (allocate-standard-instance wrapper))))))
+(defmethod class-prototype :before (class)
+  (unless (class-finalized-p class)
+    (error "~@<~S is not finalized.~:@>" class)))
+
+;;; KLUDGE: For some reason factoring the common body into a function
+;;; breaks PCL bootstrapping, so just generate it with a macrolet for
+;;; all.
+(macrolet ((def (class)
+             `(defmethod class-prototype ((class ,class))
+                (with-slots (prototype) class
+                  (or prototype
+                      (setf prototype (allocate-instance class)))))))
+  (def std-class)
+  (def condition-class)
+  (def structure-class))

 
 (defmethod class-direct-default-initargs ((class slot-class))
   (plist-value class 'direct-default-initargs))
 
 (defmethod class-direct-default-initargs ((class slot-class))
   (plist-value class 'direct-default-initargs))

@@ -175,6 +140,8 @@
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
 
 (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))

 \f
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that
 \f
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that

@@ -208,13 +175,13 @@
 ;;; computed lazily.
 (defmethod add-direct-method ((specializer class) (method method))
   (with-slots (direct-methods) specializer
 ;;; computed lazily.
 (defmethod add-direct-method ((specializer class) (method method))
   (with-slots (direct-methods) specializer

-    (setf (car direct-methods) (adjoin method (car direct-methods))    ;PUSH
-         (cdr direct-methods) ()))
+    (setf (car direct-methods) (adjoin method (car direct-methods))     ;PUSH
+          (cdr direct-methods) ()))

   method)
 (defmethod remove-direct-method ((specializer class) (method method))
   (with-slots (direct-methods) specializer
     (setf (car direct-methods) (remove method (car direct-methods))
   method)
 (defmethod remove-direct-method ((specializer class) (method method))
   (with-slots (direct-methods) specializer
     (setf (car direct-methods) (remove method (car direct-methods))

-         (cdr direct-methods) ()))
+          (cdr direct-methods) ()))

   method)
 
 (defmethod specializer-direct-methods ((specializer class))
   method)
 
 (defmethod specializer-direct-methods ((specializer class))

@@ -224,12 +191,12 @@
 (defmethod specializer-direct-generic-functions ((specializer class))
   (with-slots (direct-methods) specializer
     (or (cdr direct-methods)
 (defmethod specializer-direct-generic-functions ((specializer class))
   (with-slots (direct-methods) specializer
     (or (cdr direct-methods)

-       (setf (cdr direct-methods)
-             (let (collect)
-               (dolist (m (car direct-methods))
+        (setf (cdr direct-methods)
+              (let (collect)
+                (dolist (m (car direct-methods))

                   ;; the old PCL code used COLLECTING-ONCE which used
                   ;; #'EQ to check for newness
                   ;; the old PCL code used COLLECTING-ONCE which used
                   ;; #'EQ to check for newness

-                 (pushnew (method-generic-function m) collect :test #'eq))
+                  (pushnew (method-generic-function m) collect :test #'eq))

                 (nreverse collect))))))
 \f
 ;;; This hash table is used to store the direct methods and direct generic
                 (nreverse collect))))))
 \f
 ;;; This hash table is used to store the direct methods and direct generic

@@ -244,248 +211,389 @@
   *class-eq-specializer-methods*)
 
 (defmethod add-direct-method ((specializer specializer-with-object)
   *class-eq-specializer-methods*)
 
 (defmethod add-direct-method ((specializer specializer-with-object)

-                             (method method))
+                              (method method))

   (let* ((object (specializer-object specializer))
   (let* ((object (specializer-object specializer))

-        (table (specializer-method-table specializer))
-        (entry (gethash object table)))
+         (table (specializer-method-table specializer))
+         (entry (gethash object table)))

     (unless entry
       (setq entry
     (unless entry
       (setq entry

-           (setf (gethash object table)
-                 (cons nil nil))))
+            (setf (gethash object table)
+                  (cons nil nil))))

     (setf (car entry) (adjoin method (car entry))
     (setf (car entry) (adjoin method (car entry))

-         (cdr entry) ())
+          (cdr entry) ())

     method))
 
 (defmethod remove-direct-method ((specializer specializer-with-object)
     method))
 
 (defmethod remove-direct-method ((specializer specializer-with-object)

-                                (method method))
+                                 (method method))

   (let* ((object (specializer-object specializer))
   (let* ((object (specializer-object specializer))

-        (entry (gethash object (specializer-method-table specializer))))
+         (entry (gethash object (specializer-method-table specializer))))

     (when entry
       (setf (car entry) (remove method (car entry))
     (when entry
       (setf (car entry) (remove method (car entry))

-           (cdr entry) ()))
+            (cdr entry) ()))

     method))
 
 (defmethod specializer-direct-methods ((specializer specializer-with-object))
   (car (gethash (specializer-object specializer)
     method))
 
 (defmethod specializer-direct-methods ((specializer specializer-with-object))
   (car (gethash (specializer-object specializer)

-               (specializer-method-table specializer))))
+                (specializer-method-table specializer))))

 
 (defmethod specializer-direct-generic-functions ((specializer
 
 (defmethod specializer-direct-generic-functions ((specializer

-                                                 specializer-with-object))
+                                                  specializer-with-object))

   (let* ((object (specializer-object specializer))
   (let* ((object (specializer-object specializer))

-        (entry (gethash object (specializer-method-table specializer))))
+         (entry (gethash object (specializer-method-table specializer))))

     (when entry
       (or (cdr entry)
     (when entry
       (or (cdr entry)

-         (setf (cdr entry)
-               (let (collect)
-                 (dolist (m (car entry))
-                   (pushnew (method-generic-function m) collect :test #'eq))
+          (setf (cdr entry)
+                (let (collect)
+                  (dolist (m (car entry))
+                    (pushnew (method-generic-function m) collect :test #'eq))

                   (nreverse collect)))))))
 
 (defun map-specializers (function)
   (map-all-classes (lambda (class)
                   (nreverse collect)))))))
 
 (defun map-specializers (function)
   (map-all-classes (lambda (class)

-                    (funcall function (class-eq-specializer class))
-                    (funcall function class)))
+                     (funcall function (class-eq-specializer class))
+                     (funcall function class)))

   (maphash (lambda (object methods)
   (maphash (lambda (object methods)

-            (declare (ignore methods))
-            (intern-eql-specializer object))
-          *eql-specializer-methods*)
+             (declare (ignore methods))
+             (intern-eql-specializer object))
+           *eql-specializer-methods*)

   (maphash (lambda (object specl)
   (maphash (lambda (object specl)

-            (declare (ignore object))
-            (funcall function specl))
-          *eql-specializer-table*)
+             (declare (ignore object))
+             (funcall function specl))
+           *eql-specializer-table*)

   nil)
 
 (defun map-all-generic-functions (function)
   (let ((all-generic-functions (make-hash-table :test 'eq)))
     (map-specializers (lambda (specl)
   nil)
 
 (defun map-all-generic-functions (function)
   (let ((all-generic-functions (make-hash-table :test 'eq)))
     (map-specializers (lambda (specl)

-                       (dolist (gf (specializer-direct-generic-functions
-                                    specl))
-                         (unless (gethash gf all-generic-functions)
-                           (setf (gethash gf all-generic-functions) t)
-                           (funcall function gf))))))
+                        (dolist (gf (specializer-direct-generic-functions
+                                     specl))
+                          (unless (gethash gf all-generic-functions)
+                            (setf (gethash gf all-generic-functions) t)
+                            (funcall function gf))))))

   nil)
 
 (defmethod shared-initialize :after ((specl class-eq-specializer)
   nil)
 
 (defmethod shared-initialize :after ((specl class-eq-specializer)

-                                    slot-names
-                                    &key)
+                                     slot-names
+                                     &key)

   (declare (ignore slot-names))
   (declare (ignore slot-names))

-  (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
+  (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl))))

 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))

-  (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
-\f
-(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-truename*)
-                   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)))))
+  (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
+                           readers writers slot-names source-location)
+  (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 source-location
+                      other)))
+      res)))

 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 
 (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)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)

-    (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))
 
     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)
   (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)
     (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))
 
     class))
 

-(defmethod class-predicate-name ((class t))
-  'constantly-nil)
-

 (defun fix-super (s)
   (cond ((classp s) s)
         ((not (legal-class-name-p s))
 (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
         (t

-          (or (find-class s nil)
-              (setf (find-class s)
-                      (make-instance 'forward-referenced-class
-                                     :name s))))))
-
-(defun ensure-class-values (class args)
-  (let* ((initargs (copy-list args))
-        (unsupplied (list 1))
-        (supplied-meta   (getf initargs :metaclass unsupplied))
-        (supplied-supers (getf initargs :direct-superclasses unsupplied))
-        (supplied-slots  (getf initargs :direct-slots unsupplied))
-        (meta
-          (cond ((neq supplied-meta unsupplied)
-                 (find-class supplied-meta))
-                ((or (null class)
-                     (forward-referenced-class-p class))
-                 *the-class-standard-class*)
-                (t
-                 (class-of class)))))
-    (loop (unless (remf initargs :metaclass) (return)))
-    (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))))
-\f
+         (or (find-class s nil)
+             (ensure-class s :metaclass 'forward-referenced-class)))))
+
+(defun ensure-class-values (class initargs)
+  (let (metaclass metaclassp reversed-plist)
+    (doplist (key val) initargs
+      (cond ((eq key :metaclass)
+             (setf metaclass val
+                   metaclassp key))
+            (t
+             (when (eq key :direct-superclasses)
+               (setf val (mapcar #'fix-super val)))
+             (setf reversed-plist (list* val key reversed-plist)))))
+    (values (cond (metaclassp
+                   (if (classp metaclass)
+                       metaclass
+                       (find-class metaclass)))
+                  ((or (null class) (forward-referenced-class-p class))
+                   *the-class-standard-class*)
+                  (t
+                   (class-of class)))
+            (nreverse reversed-plist))))

 
 

+\f

 (defmethod shared-initialize :after
 (defmethod shared-initialize :after

-          ((class std-class)
-           slot-names
-           &key (direct-superclasses nil direct-superclasses-p)
-                (direct-slots nil direct-slots-p)
-                (direct-default-initargs nil direct-default-initargs-p)
-                (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names))
+    ((class std-class) slot-names &key
+     (direct-superclasses nil direct-superclasses-p)
+     (direct-slots nil direct-slots-p)
+     (direct-default-initargs nil direct-default-initargs-p))

   (cond (direct-superclasses-p
   (cond (direct-superclasses-p

-        (setq direct-superclasses
-              (or direct-superclasses
-                  (list (if (funcallable-standard-class-p class)
-                            *the-class-funcallable-standard-object*
-                            *the-class-standard-object*))))
-        (dolist (superclass direct-superclasses)
-          (unless (validate-superclass class superclass)
-            (error "The class ~S was specified as a~%
-                    super-class of the class ~S;~%~
-                    but the meta-classes ~S and~%~S are incompatible.~@
-                    Define a method for ~S to avoid this error."
-                    superclass class (class-of superclass) (class-of class)
-                    'validate-superclass)))
-        (setf (slot-value class 'direct-superclasses) direct-superclasses))
-       (t
-        (setq direct-superclasses (slot-value class 'direct-superclasses))))
+         (setq direct-superclasses
+               (or direct-superclasses
+                   (list (if (funcallable-standard-class-p class)
+                             *the-class-funcallable-standard-object*
+                             *the-class-standard-object*))))
+         (dolist (superclass direct-superclasses)
+           (unless (validate-superclass class superclass)
+             (error "~@<The class ~S was specified as a ~
+                     super-class of the class ~S, ~
+                     but the meta-classes ~S and ~S are incompatible.  ~
+                     Define a method for ~S to avoid this error.~@:>"
+                     superclass class (class-of superclass) (class-of class)
+                     'validate-superclass)))
+         (setf (slot-value class 'direct-superclasses) direct-superclasses))
+        (t
+         (setq direct-superclasses (slot-value class 'direct-superclasses))))

   (setq direct-slots
   (setq direct-slots

-       (if direct-slots-p
-           (setf (slot-value class 'direct-slots)
-                 (mapcar (lambda (pl) (make-direct-slotd class pl))
-                         direct-slots))
-           (slot-value class 'direct-slots)))
+        (if direct-slots-p
+            (setf (slot-value class 'direct-slots)
+                  (mapcar (lambda (pl) (make-direct-slotd class pl))
+                          direct-slots))
+            (slot-value class 'direct-slots)))

   (if direct-default-initargs-p
       (setf (plist-value class 'direct-default-initargs)
   (if direct-default-initargs-p
       (setf (plist-value class 'direct-default-initargs)

-           direct-default-initargs)
+            direct-default-initargs)

       (setq direct-default-initargs
       (setq direct-default-initargs

-           (plist-value class 'direct-default-initargs)))
+            (plist-value class 'direct-default-initargs)))

   (setf (plist-value class 'class-slot-cells)
   (setf (plist-value class 'class-slot-cells)

-       (let (collect)
-         (dolist (dslotd direct-slots)
-           (when (eq (slot-definition-allocation dslotd) class)
-             (let ((initfunction (slot-definition-initfunction dslotd)))
-               (push (cons (slot-definition-name dslotd)
-                              (if initfunction
-                                  (funcall initfunction)
-                                  +slot-unbound+))
-                      collect))))
+        (let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+              (collect '()))
+          (dolist (dslotd direct-slots)
+            (when (eq :class (slot-definition-allocation dslotd))
+              ;; 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)))
           (nreverse collect)))

-  (setq predicate-name (if predicate-name-p
-                          (setf (slot-value class 'predicate-name)
-                                (car predicate-name))
-                          (or (slot-value class 'predicate-name)
-                              (setf (slot-value class 'predicate-name)
-                                    (make-class-predicate-name (class-name
-                                                                class))))))

   (add-direct-subclasses class direct-superclasses)
   (update-class class nil)
   (add-direct-subclasses class direct-superclasses)
   (update-class class nil)

-  (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
+  (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))))
+    (without-package-locks
+     (unless (class-finalized-p class)
+       (let ((name (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.
+         (let ((layout (make-wrapper 0 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)
+           (set-class-type-translation class (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))
   ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
   ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
   (declare (ignore slot-names name))
   ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
   ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)

-  (setf (slot-value class 'type) `(class ,class))
+  (setf (slot-value class '%type) `(class ,class))

   (setf (slot-value class 'class-eq-specializer)
   (setf (slot-value class 'class-eq-specializer)

-       (make-instance 'class-eq-specializer :class class)))
+        (make-instance 'class-eq-specializer :class class)))

 
 

-(defmethod reinitialize-instance :before ((class slot-class) &key)
-  (remove-direct-subclasses class (class-direct-superclasses class))
+(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
+  (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
+    (remove-direct-subclass old-super class))

   (remove-slot-accessors    class (class-direct-slots class)))
 
 (defmethod reinitialize-instance :after ((class slot-class)
   (remove-slot-accessors    class (class-direct-slots class)))
 
 (defmethod reinitialize-instance :after ((class slot-class)

-                                        &rest initargs
-                                        &key)
+                                         &rest initargs
+                                         &key)

   (map-dependents class
   (map-dependents class

-                 (lambda (dependent)
-                   (apply #'update-dependent class dependent initargs))))
+                  (lambda (dependent)
+                    (apply #'update-dependent class dependent initargs))))

 
 

-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-                                    slot-names &key)
+(defmethod reinitialize-instance :after ((class condition-class) &key)
+  (let* ((name (class-name class))
+         (classoid (find-classoid name))
+         (slots (condition-classoid-slots classoid)))
+    ;; to balance the REMOVE-SLOT-ACCESSORS call in
+    ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
+    (dolist (slot slots)
+      (let ((slot-name (condition-slot-name slot)))
+        (dolist (reader (condition-slot-readers slot))
+          ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
+          ;; (CONDITION-CLASS T), below.  -- CSR, 2005-11-18
+          (sb-kernel::install-condition-slot-reader reader name slot-name))
+        (dolist (writer (condition-slot-writers slot))
+          (sb-kernel::install-condition-slot-writer writer name slot-name))))))
+
+(defmethod shared-initialize :after ((class condition-class) slot-names
+                                     &key direct-slots direct-superclasses)

   (declare (ignore slot-names))
   (declare (ignore slot-names))

-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
+  (let ((classoid (find-classoid (class-name class))))
+    (with-slots (wrapper %class-precedence-list cpl-available-p
+                         prototype (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 cpl-available-p t)
+      (add-direct-subclasses class direct-superclasses)
+      (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.
+  ;;
+  ;; ??? What does the above comment mean and why is it a good idea?
+  ;; CMUCL (which still as of 2005-11-18 uses this code and has this
+  ;; comment) loses slot information in its condition classes:
+  ;; DIRECT-SLOTS is always NIL.  We have the right information, so we
+  ;; remove slot accessors but never put them back.  I've added a
+  ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
+  ;; was meant to happen?  -- CSR, 2005-11-18
+  (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 shared-initialize :after ((slotd structure-slot-definition)
-                                    slot-names
-                                    &key (allocation :instance))
-  (declare (ignore slot-names))
+(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.")))
 
 (defun make-structure-class-defstruct-form (name direct-slots include)
   (unless (eq allocation :instance)
     (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 "~A constructor" 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))))
          (defstruct `(defstruct (,name
                                  ,@(when include
                                          `((:include ,(class-name include))))

-                                 (:print-function print-std-instance)

                                  (:predicate nil)
                                  (:conc-name ,conc-name)
                                  (:constructor ,constructor ())
                                  (:predicate nil)
                                  (:conc-name ,conc-name)
                                  (:constructor ,constructor ())

@@ -495,18 +603,14 @@
                                     +slot-unbound+))
                                 direct-slots)))
          (reader-names (mapcar (lambda (slotd)
                                     +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)
                                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)
                                direct-slots))
          (readers-init
            (mapcar (lambda (slotd reader-name)

@@ -533,75 +637,74 @@
                (cons nil nil))))
     (values defstruct-form constructor reader-names writer-names)))
 
                (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 ()
+      (sb-kernel::%make-instance-with-layout
+       (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
+

 (defmethod shared-initialize :after
 (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)

   (declare (ignore slot-names direct-default-initargs))
   (if direct-superclasses-p
       (setf (slot-value class 'direct-superclasses)
   (declare (ignore slot-names direct-default-initargs))
   (if direct-superclasses-p
       (setf (slot-value class 'direct-superclasses)

-           (or direct-superclasses
-               (setq direct-superclasses
-                     (and (not (eq (class-name class) 'structure-object))
-                          (list *the-class-structure-object*)))))
+            (or direct-superclasses
+                (setq direct-superclasses
+                      (and (not (eq (class-name class) 'structure-object))
+                           (list *the-class-structure-object*)))))

       (setq direct-superclasses (slot-value class 'direct-superclasses)))
   (let* ((name (class-name class))
       (setq direct-superclasses (slot-value class 'direct-superclasses)))
   (let* ((name (class-name class))

-        (from-defclass-p (slot-value class 'from-defclass-p))
-        (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
+         (from-defclass-p (slot-value class 'from-defclass-p))
+         (defstruct-p (or from-defclass-p (not (structure-type-p name)))))

     (if direct-slots-p
     (if direct-slots-p

-       (setf (slot-value class 'direct-slots)
-             (setq direct-slots
-                   (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)))
-                                 (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))))
+        (setf (slot-value class 'direct-slots)
+              (setq direct-slots
+                    (mapcar (lambda (pl)
+                              (when defstruct-p
+                                (let* ((slot-name (getf pl :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)))
+    (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 (fboundp 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)
     (add-direct-subclasses class direct-superclasses)

-    (setf (slot-value class 'class-precedence-list)
-            (compute-class-precedence-list class))
+    (setf (slot-value class '%class-precedence-list)
+          (compute-class-precedence-list class))
+    (setf (slot-value class 'cpl-available-p) t)

     (setf (slot-value class 'slots) (compute-slots 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)
     (update-pv-table-cache-info class)

-    (setq predicate-name (if predicate-name-p
-                          (setf (slot-value class 'predicate-name)
-                                   (car predicate-name))
-                          (or (slot-value class 'predicate-name)
-                              (setf (slot-value class 'predicate-name)
-                                       (make-class-predicate-name
-                                        (class-name class))))))
-    (make-class-predicate class predicate-name)

     (add-slot-accessors class direct-slots)))
     (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))
 
   (declare (ignore initargs))
   (find-class 'structure-direct-slot-definition))
 

@@ -616,66 +719,117 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
 
 (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 (cond ((eq add/remove 'add)
+                            (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))))))
+                           ((generic-function-p (and (fboundp gfspec)
+                                                     (fdefinition gfspec)))
+                            (without-package-locks
+                              (ensure-generic-function gfspec))))))
+             (when gf
+               (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 (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))))))

 \f
 (defun add-direct-subclasses (class supers)
   (dolist (super supers)
     (unless (memq class (class-direct-subclasses class))
       (add-direct-subclass super class))))
 
 \f
 (defun add-direct-subclasses (class supers)
   (dolist (super supers)
     (unless (memq class (class-direct-subclasses class))
       (add-direct-subclass super class))))
 

-(defun remove-direct-subclasses (class supers)
-  (let ((old (class-direct-superclasses class)))
-    (dolist (o (set-difference old supers))
-      (remove-direct-subclass o class))))
-\f

 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
 (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))
+

 \f
 (defun class-has-a-forward-referenced-superclass-p (class)
   (or (forward-referenced-class-p class)
       (some #'class-has-a-forward-referenced-superclass-p
 \f
 (defun class-has-a-forward-referenced-superclass-p (class)
   (or (forward-referenced-class-p class)
       (some #'class-has-a-forward-referenced-superclass-p

-           (class-direct-superclasses class))))
+            (class-direct-superclasses class))))

 
 ;;; 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)
 
 ;;; 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)

-  (when (or finalizep (class-finalized-p class)
-           (not (class-has-a-forward-referenced-superclass-p class)))
-    (update-cpl class (compute-class-precedence-list class))
-    (update-slots class (compute-slots class))
-    (update-gfs-of-class class)
-    (update-inits class (compute-default-initargs class))
-    (update-make-instance-function-table class))
-  (unless finalizep
-    (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
+  (without-package-locks
+   (when (or finalizep (class-finalized-p class))
+     (update-cpl class (compute-class-precedence-list class))
+     ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
+     ;; class.
+     (update-slots class (compute-slots class))
+     (update-gfs-of-class class)
+     (update-initargs class (compute-default-initargs class))
+     (update-ctors 'finalize-inheritance :class class))
+   (dolist (sub (class-direct-subclasses class))
+     (update-class sub nil))))
+
+(define-condition cpl-protocol-violation (reference-condition error)
+  ((class :initarg :class :reader cpl-protocol-violation-class)
+   (cpl :initarg :cpl :reader cpl-protocol-violation-cpl))
+  (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol")))
+  (:report
+   (lambda (c s)
+     (format s "~@<Protocol violation: the ~S class ~S ~
+                ~:[has~;does not have~] the class ~S in its ~
+                class precedence list: ~S.~@:>"
+             (class-name (class-of (cpl-protocol-violation-class c)))
+             (cpl-protocol-violation-class c)
+             (eq (class-of (cpl-protocol-violation-class c))
+                 *the-class-funcallable-standard-class*)
+             (find-class 'function)
+             (cpl-protocol-violation-cpl c)))))

 
 (defun update-cpl (class cpl)
 
 (defun update-cpl (class cpl)

+  (when (eq (class-of class) *the-class-standard-class*)
+    (when (find (find-class 'function) cpl)
+      (error 'cpl-protocol-violation :class class :cpl cpl)))
+  (when (eq (class-of class) *the-class-funcallable-standard-class*)
+    (unless (find (find-class 'function) cpl)
+      (error 'cpl-protocol-violation :class class :cpl cpl)))

   (if (class-finalized-p class)
   (if (class-finalized-p class)

-      (unless (equal (class-precedence-list class) cpl)
-       ;; 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)
-       (force-cache-flushes class))
-      (setf (slot-value class 'class-precedence-list) 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))
+      (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)
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr cpl))
   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr cpl))

-       (pushnew c (slot-value first 'can-precede-list))))
+        (pushnew c (slot-value first 'can-precede-list))))

     (update-class-can-precede-p (cdr cpl))))
 
 (defun class-can-precede-p (class1 class2)
     (update-class-can-precede-p (cdr cpl))))
 
 (defun class-can-precede-p (class1 class2)

@@ -683,239 +837,267 @@
 
 (defun update-slots (class eslotds)
   (let ((instance-slots ())
 
 (defun update-slots (class eslotds)
   (let ((instance-slots ())

-       (class-slots    ()))
+        (class-slots    ()))

     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
     (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.
     (let* ((nlayout (mapcar #'slot-definition-name
 
     ;; If there is a change in the shape of the instances then the
     ;; old class is now obsolete.
     (let* ((nlayout (mapcar #'slot-definition-name

-                           (sort instance-slots #'<
-                                 :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-class-slots (and owrapper (wrapper-class-slots owrapper)))
-          (nwrapper
-           (cond ((null owrapper)
-                  (make-wrapper nslots class))
-                 ((and (equal nlayout olayout)
-                       (not
+                            (sort instance-slots #'<
+                                  :key #'slot-definition-location)))
+           (nslots (length nlayout))
+           (nwrapper-class-slots (compute-class-slots class-slots))
+           (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)
+                   (make-wrapper nslots class))
+                  ((and (equal nlayout olayout)
+                        (not

                          (loop for o in owrapper-class-slots
                                for n in nwrapper-class-slots
                                do (unless (eq (car o) (car n)) (return t)))))
                          (loop for o in owrapper-class-slots
                                for n in nwrapper-class-slots
                                do (unless (eq (car o) (car n)) (return t)))))

-                  owrapper)
-                 (t
-                  ;; This will initialize the new wrapper to have the
-                  ;; same state as the old wrapper. We will then have
-                  ;; to change that. This may seem like wasted work
-                  ;; (and it is), but the spec requires that we call
-                  ;; MAKE-INSTANCES-OBSOLETE.
-                  (make-instances-obsolete class)
-                  (class-wrapper class)))))
+                   owrapper)
+                  (t
+                   ;; This will initialize the new wrapper to have the
+                   ;; same state as the old wrapper. We will then have
+                   ;; to change that. This may seem like wasted work
+                   ;; (and it is), but the spec requires that we call
+                   ;; MAKE-INSTANCES-OBSOLETE.
+                   (make-instances-obsolete class)
+                   (class-wrapper class)))))

 
       (with-slots (wrapper slots) class
 
       (with-slots (wrapper slots) class

-       (update-lisp-class-layout class nwrapper)
-       (setf slots eslotds
-             (wrapper-instance-slots-layout nwrapper) nlayout
-             (wrapper-class-slots nwrapper) nwrapper-class-slots
-             (wrapper-no-of-instance-slots nwrapper) nslots
-             wrapper nwrapper))
-
+        (update-lisp-class-layout class nwrapper)
+        (setf slots eslotds
+              (wrapper-instance-slots-layout nwrapper) nlayout
+              (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)
       (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)
 
 (defun compute-class-slots (eslotds)
   (let (collect)

-    (dolist (eslotd eslotds)
-      (push (assoc (slot-definition-name eslotd)
-                   (class-slot-cells (slot-definition-allocation eslotd)))
-            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)))))
+    (dolist (eslotd eslotds (nreverse collect))
+      (let ((cell (assoc (slot-definition-name eslotd)
+                         (class-slot-cells
+                          (slot-definition-allocation-class eslotd)))))
+        (aver cell)
+        (push cell collect)))))

 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)

-            (let ((cpl (class-precedence-list class)))
-              (or (member *the-class-slot-class* cpl)
-                  (member *the-class-standard-effective-slot-definition*
-                          cpl))))
+             (let ((cpl (class-precedence-list class)))
+               (or (member *the-class-slot-class* cpl)
+                   (member *the-class-standard-effective-slot-definition*
+                           cpl))))

     (let ((gf-table (make-hash-table :test 'eq)))
       (labels ((collect-gfs (class)
     (let ((gf-table (make-hash-table :test 'eq)))
       (labels ((collect-gfs (class)

-                (dolist (gf (specializer-direct-generic-functions class))
-                  (setf (gethash gf gf-table) t))
-                (mapc #'collect-gfs (class-direct-superclasses class))))
-       (collect-gfs class)
-       (maphash (lambda (gf ignore)
-                  (declare (ignore ignore))
-                  (update-gf-dfun class gf))
-                gf-table)))))
-
-(defun update-inits (class inits)
+                 (dolist (gf (specializer-direct-generic-functions class))
+                   (setf (gethash gf gf-table) t))
+                 (mapc #'collect-gfs (class-direct-superclasses class))))
+        (collect-gfs class)
+        (maphash (lambda (gf ignore)
+                   (declare (ignore ignore))
+                   (update-gf-dfun class gf))
+                 gf-table)))))
+
+(defun update-initargs (class inits)

   (setf (plist-value class 'default-initargs) inits))
 \f
 (defmethod compute-default-initargs ((class slot-class))
   (setf (plist-value class 'default-initargs) inits))
 \f
 (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)))

 \f
 ;;;; protocols for constructing direct and effective slot definitions
 
 \f
 ;;;; 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)
   (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)
-          initargs)))
-
-(defmethod compute-slots ((class std-class))
+  (apply #'make-instance
+         (apply #'direct-slot-definition-class class initargs)
+         :class class
+         initargs))
+
+;;; I (CSR) am not sure, but I believe that the particular order of
+;;; slots is quite important: it is ideal to attempt to have a
+;;; constant slot location for the same notional slots as much as
+;;; possible, so that clever discriminating functions (ONE-INDEX et
+;;; al.) have a chance of working.  The below at least walks through
+;;; the slots predictably, but maybe it would be good to compute some
+;;; kind of optimal slot layout by looking at locations of slots in
+;;; superclasses?
+(defun std-compute-slots (class)

   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
   ;; for each different slot name we find in our superclasses. Each
   ;; call receives the class and a list of the dslotds with that name.
   ;; The list is in most-specific-first order.
   (let ((name-dslotds-alist ()))
   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
   ;; for each different slot name we find in our superclasses. Each
   ;; call receives the class and a list of the dslotds with that name.
   ;; 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 (c (reverse (class-precedence-list class)))
+      (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)
     (mapcar (lambda (direct)

-             (compute-effective-slot-definition class
-                                                (nreverse (cdr direct))))
-           name-dslotds-alist)))
-
-(defmethod compute-slots :around ((class std-class))
-  (let ((eslotds (call-next-method))
-       (cpl (class-precedence-list class))
-       (instance-slots ())
-       (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)))))
-    (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)
+              (compute-effective-slot-definition class
+                                                 (car direct)
+                                                 (cdr direct)))
+            (nreverse name-dslotds-alist))))
+
+(defmethod compute-slots ((class standard-class))
+  (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
+  (std-compute-slots class))
+
+(defun std-compute-slots-around (class eslotds)
+  (let ((location -1))
+    (dolist (eslotd eslotds eslotds)

       (setf (slot-definition-location eslotd)
       (setf (slot-definition-location eslotd)

-           (assoc (slot-definition-name eslotd)
-                  (class-slot-cells (slot-definition-allocation eslotd)))))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
+            (case (slot-definition-allocation eslotd)
+              (:instance
+               (incf location))
+              (:class
+               (let* ((name (slot-definition-name eslotd))
+                      (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))
+                                (let ((c (cons name +slot-unbound+)))
+                                  (push c (class-slot-cells from-class))
+                                  c))))
+                 (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)))))
+      (unless (slot-definition-class eslotd)
+        (setf (slot-definition-class eslotd) class))
+      (initialize-internal-slot-functions eslotd))))
+
+(defmethod compute-slots :around ((class standard-class))
+  (let ((eslotds (call-next-method)))
+    (std-compute-slots-around class eslotds)))
+(defmethod compute-slots :around ((class funcallable-standard-class))
+  (let ((eslotds (call-next-method)))
+    (std-compute-slots-around class eslotds)))

 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)

-           (mapcar (lambda (dslotd)
-                     (compute-effective-slot-definition class
-                                                        (list dslotd)))
-                   (class-direct-slots superclass)))
-         (reverse (slot-value class 'class-precedence-list))))
+            (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 structure-class))
   (let ((eslotds (call-next-method)))
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
 
 (defmethod compute-slots :around ((class structure-class))
   (let ((eslotds (call-next-method)))
     (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))
   (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)))
 
     (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))
 
   (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))
 
 (defmethod compute-effective-slot-definition-initargs
     ((class slot-class) direct-slotds)
   (let* ((name nil)
   (declare (ignore initargs))
   (find-class 'structure-effective-slot-definition))
 
 (defmethod compute-effective-slot-definition-initargs
     ((class slot-class) direct-slotds)
   (let* ((name nil)

-        (initfunction nil)
-        (initform nil)
-        (initargs nil)
-        (allocation nil)
-        (type t)
-        (namep  nil)
-        (initp  nil)
-        (allocp nil))
+         (initfunction nil)
+         (initform nil)
+         (initargs nil)
+         (allocation nil)
+         (allocation-class nil)
+         (type t)
+         (documentation nil)
+         (documentationp nil)
+         (namep  nil)
+         (initp  nil)
+         (allocp nil))

 
     (dolist (slotd direct-slotds)
       (when slotd
 
     (dolist (slotd direct-slotds)
       (when slotd

-       (unless namep
-         (setq name (slot-definition-name slotd)
-               namep t))
-       (unless initp
-         (when (slot-definition-initfunction slotd)
-           (setq initform (slot-definition-initform slotd)
-                 initfunction (slot-definition-initfunction slotd)
-                 initp t)))
-       (unless allocp
-         (setq allocation (slot-definition-allocation slotd)
-               allocp t))
-       (setq initargs (append (slot-definition-initargs slotd) initargs))
-       (let ((slotd-type (slot-definition-type slotd)))
-         (setq type (cond ((eq type t) slotd-type)
-                          ((*subtypep type slotd-type) type)
-                          (t `(and ,type ,slotd-type)))))))
+        (unless namep
+          (setq name (slot-definition-name slotd)
+                namep t))
+        (unless initp
+          (when (slot-definition-initfunction slotd)
+            (setq initform (slot-definition-initform slotd)
+                  initfunction (slot-definition-initfunction slotd)
+                  initp t)))
+        (unless documentationp
+          (when (%slot-definition-documentation slotd)
+            (setq documentation (%slot-definition-documentation slotd)
+                  documentationp 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)))
+          (setq type (cond
+                       ((eq type t) slotd-type)
+                       ;; This pairwise type intersection is perhaps a
+                       ;; little inefficient and inelegant, but it's
+                       ;; unlikely to lie on the critical path.  Shout
+                       ;; if I'm wrong.  -- CSR, 2005-11-24
+                       (t (type-specifier
+                           (specifier-type `(and ,type ,slotd-type)))))))))

     (list :name name
     (list :name name

-         :initform initform
-         :initfunction initfunction
-         :initargs initargs
-         :allocation allocation
-         :type type
-         :class class)))
+          :initform initform
+          :initfunction initfunction
+          :initargs initargs
+          :allocation allocation
+          :allocation-class allocation-class
+          :type type
+          :class class
+          :documentation documentation)))

 
 (defmethod compute-effective-slot-definition-initargs :around
     ((class structure-class) direct-slotds)
   (let ((slotd (car direct-slotds)))
     (list* :defstruct-accessor-symbol
 
 (defmethod compute-effective-slot-definition-initargs :around
     ((class structure-class) direct-slotds)
   (let ((slotd (car direct-slotds)))
     (list* :defstruct-accessor-symbol

-          (slot-definition-defstruct-accessor-symbol slotd)
-          :internal-reader-function
-          (slot-definition-internal-reader-function slotd)
-          :internal-writer-function
-          (slot-definition-internal-writer-function slotd)
-          (call-next-method))))
+           (slot-definition-defstruct-accessor-symbol slotd)
+           :internal-reader-function
+           (slot-definition-internal-reader-function slotd)
+           :internal-writer-function
+           (slot-definition-internal-writer-function slotd)
+           (call-next-method))))

 \f
 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
 ;;;       to make the method object. They have to use make-a-method which
 \f
 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
 ;;;       to make the method object. They have to use make-a-method which

@@ -926,13 +1108,13 @@
 
 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
   (add-method generic-function
 
 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
   (add-method generic-function

-             (make-a-method 'standard-reader-method
-                            ()
-                            (list (or (class-name class) 'object))
-                            (list class)
-                            (make-reader-method-function class slot-name)
-                            "automatically generated reader method"
-                            slot-name)))
+              (make-a-method 'standard-reader-method
+                             ()
+                             (list (or (class-name class) 'object))
+                             (list class)
+                             (make-reader-method-function class slot-name)
+                             "automatically generated reader method"
+                             slot-name)))

 
 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
   (declare (ignore direct-slot initargs))
 
 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
   (declare (ignore direct-slot initargs))

@@ -940,23 +1122,23 @@
 
 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
   (add-method generic-function
 
 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
   (add-method generic-function

-             (make-a-method 'standard-writer-method
-                            ()
-                            (list 'new-value (or (class-name class) 'object))
-                            (list *the-class-t* class)
-                            (make-writer-method-function class slot-name)
-                            "automatically generated writer method"
-                            slot-name)))
+              (make-a-method 'standard-writer-method
+                             ()
+                             (list 'new-value (or (class-name class) 'object))
+                             (list *the-class-t* class)
+                             (make-writer-method-function class slot-name)
+                             "automatically generated writer method"
+                             slot-name)))

 
 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
   (add-method generic-function
 
 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
   (add-method generic-function

-             (make-a-method 'standard-boundp-method
-                            ()
-                            (list (or (class-name class) 'object))
-                            (list class)
-                            (make-boundp-method-function class slot-name)
-                            "automatically generated boundp method"
-                            slot-name)))
+              (make-a-method 'standard-boundp-method
+                             ()
+                             (list (or (class-name class) 'object))
+                             (list class)
+                             (make-boundp-method-function class slot-name)
+                             "automatically generated boundp method"
+                             slot-name)))

 
 (defmethod remove-reader-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))
 
 (defmethod remove-reader-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))

@@ -964,16 +1146,16 @@
 
 (defmethod remove-writer-method ((class slot-class) generic-function)
   (let ((method
 
 (defmethod remove-writer-method ((class slot-class) generic-function)
   (let ((method

-         (get-method generic-function () (list *the-class-t* class) nil)))
+          (get-method generic-function () (list *the-class-t* class) nil)))

     (when method (remove-method generic-function method))))
 
 (defmethod remove-boundp-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
 \f
     (when method (remove-method generic-function method))))
 
 (defmethod remove-boundp-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
 \f

-;;; make-reader-method-function and make-write-method function are NOT part of
-;;; the standard protocol. They are however useful, PCL makes uses makes use
-;;; of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
+;;; part of the standard protocol. They are however useful, PCL makes
+;;; use of them internally and documents them for PCL users.

 ;;;
 ;;; *** This needs work to make type testing by the writer functions which
 ;;; *** do type testing faster. The idea would be to have one constructor
 ;;;
 ;;; *** This needs work to make type testing by the writer functions which
 ;;; *** do type testing faster. The idea would be to have one constructor

@@ -981,7 +1163,7 @@
 ;;;
 ;;; *** There is a subtle bug here which is going to have to be fixed.
 ;;; *** Namely, the simplistic use of the template has to be fixed. We
 ;;;
 ;;; *** There is a subtle bug here which is going to have to be fixed.
 ;;; *** Namely, the simplistic use of the template has to be fixed. We

-;;; *** have to give the optimize-slot-value method the user might have
+;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have

 ;;; *** defined for this metaclass a chance to run.
 
 (defmethod make-reader-method-function ((class slot-class) slot-name)
 ;;; *** defined for this metaclass a chance to run.
 
 (defmethod make-reader-method-function ((class slot-class) slot-name)

@@ -996,33 +1178,63 @@
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 

-(defmethod validate-superclass ((class class) (new-super class))
-  (or (eq new-super *the-class-t*)
-      (eq (class-of class) (class-of new-super))))
-
-(defmethod validate-superclass ((class standard-class) (new-super std-class))
-  (let ((new-super-meta-class (class-of new-super)))
-    (or (eq new-super-meta-class *the-class-std-class*)
-       (eq (class-of class) new-super-meta-class))))
+(defmethod validate-superclass ((class class) (superclass class))
+  (or (eq superclass *the-class-t*)
+      (eq (class-of class) (class-of superclass))
+      (and (eq (class-of superclass) *the-class-standard-class*)
+           (eq (class-of class) *the-class-funcallable-standard-class*))
+      (and (eq (class-of superclass) *the-class-funcallable-standard-class*)
+           (eq (class-of class) *the-class-standard-class*))))

 \f
 \f

+;;; 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 (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)))
 (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 (layout-invalid owrapper) t))

       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
       (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
-         (update-lisp-class-layout class nwrapper)
-         (setf (slot-value class 'wrapper) nwrapper)
-         (invalidate-wrapper owrapper :flush nwrapper))))))
+                                    class)))
+        (setf (wrapper-instance-slots-layout nwrapper)
+              (wrapper-instance-slots-layout owrapper))
+        (setf (wrapper-class-slots nwrapper)
+              (wrapper-class-slots owrapper))
+        (with-pcl-lock
+          (update-lisp-class-layout class nwrapper)
+          (setf (slot-value class 'wrapper) 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))
 
 (defun flush-cache-trap (owrapper nwrapper instance)
   (declare (ignore owrapper))

@@ -1033,20 +1245,26 @@
 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
 (defmethod make-instances-obsolete ((class std-class))
   (let* ((owrapper (class-wrapper class))
 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
 (defmethod make-instances-obsolete ((class std-class))
   (let* ((owrapper (class-wrapper class))

-        (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
-       (update-lisp-class-layout class nwrapper)
-       (setf (slot-value class 'wrapper) nwrapper)
-       (invalidate-wrapper owrapper :obsolete nwrapper)
-       class)))
+         (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+                                 class)))
+    (unless (class-finalized-p class)
+      (if (class-has-a-forward-referenced-superclass-p class)
+          (return-from make-instances-obsolete class)
+          (update-cpl class (compute-class-precedence-list class))))
+    (setf (wrapper-instance-slots-layout nwrapper)
+          (wrapper-instance-slots-layout owrapper))
+    (setf (wrapper-class-slots nwrapper)
+          (wrapper-class-slots owrapper))
+    (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))
 
 (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:
 
 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
 ;;; see an obsolete instance. The times when it is called are:

@@ -1085,35 +1303,36 @@
    (lambda (condition stream)
      ;; Don't try to print the structure, since it probably won't work.
      (format stream
    (lambda (condition stream)
      ;; Don't try to print the structure, since it probably won't work.
      (format stream

-            "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
-            (type-of (obsolete-structure-datum condition))))))
+             "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
+             (type-of (obsolete-structure-datum condition))))))

 
 (defun obsolete-instance-trap (owrapper nwrapper instance)
   (if (not (pcl-instance-p instance))
       (if *in-obsolete-instance-trap*
 
 (defun obsolete-instance-trap (owrapper nwrapper instance)
   (if (not (pcl-instance-p instance))
       (if *in-obsolete-instance-trap*

-         *the-wrapper-of-structure-object*
-          (let ((*in-obsolete-instance-trap* t))
-            (error 'obsolete-structure :datum instance)))
+          *the-wrapper-of-structure-object*
+           (let ((*in-obsolete-instance-trap* t))
+             (error 'obsolete-structure :datum instance)))

       (let* ((class (wrapper-class* nwrapper))
       (let* ((class (wrapper-class* nwrapper))

-            (copy (allocate-instance class)) ;??? allocate-instance ???
-            (olayout (wrapper-instance-slots-layout owrapper))
-            (nlayout (wrapper-instance-slots-layout nwrapper))
-            (oslots (get-slots instance))
-            (nslots (get-slots copy))
-            (oclass-slots (wrapper-class-slots owrapper))
-            (added ())
-            (discarded ())
-            (plist ()))
-       ;; local  --> local     transfer
-       ;; local  --> shared       discard
-       ;; local  -->  --         discard
-       ;; shared --> local     transfer
-       ;; shared --> shared       discard
-       ;; shared -->  --         discard
-       ;;  --    --> local     add
-       ;;  --    --> shared    --
-
-       ;; Go through all the old local slots.
+             (copy (allocate-instance class)) ;??? allocate-instance ???
+             (olayout (wrapper-instance-slots-layout owrapper))
+             (nlayout (wrapper-instance-slots-layout nwrapper))
+             (oslots (get-slots instance))
+             (nslots (get-slots copy))
+             (oclass-slots (wrapper-class-slots owrapper))
+             (added ())
+             (discarded ())
+             (plist ()))
+
+        ;; 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    --
+
+        ;; Go through all the old local slots.

         (let ((opos 0))
           (dolist (name olayout)
             (let ((npos (posq name nlayout)))
         (let ((opos 0))
           (dolist (name olayout)
             (let ((npos (posq name nlayout)))

@@ -1126,41 +1345,38 @@
                       (setf (getf plist name) (clos-slots-ref oslots opos))))))
             (incf opos)))
 
                       (setf (getf plist name) (clos-slots-ref oslots opos))))))
             (incf opos)))
 

-       ;; Go through all the old shared slots.
+        ;; Go through all the old shared slots.

         (dolist (oclass-slot-and-val oclass-slots)
         (dolist (oclass-slot-and-val oclass-slots)

-         (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)))))))
-
-       ;; Go through all the new local slots to compute the added slots.
-       (dolist (nlocal nlayout)
-         (unless (or (memq nlocal olayout)
-                     (assq nlocal oclass-slots))
-           (push nlocal added)))
-
-       (swap-wrappers-and-slots instance copy)
-
-       (update-instance-for-redefined-class instance
-                                            added
-                                            discarded
-                                            plist)
-       nwrapper)))
+          (let ((name (car oclass-slot-and-val))
+                (val (cdr oclass-slot-and-val)))
+            (let ((npos (posq name nlayout)))
+              (when npos
+                (setf (clos-slots-ref nslots npos) val)))))
+
+        ;; Go through all the new local slots to compute the added slots.
+        (dolist (nlocal nlayout)
+          (unless (or (memq nlocal olayout)
+                      (assq nlocal oclass-slots))
+            (push nlocal added)))
+
+        (swap-wrappers-and-slots instance copy)
+
+        (update-instance-for-redefined-class instance
+                                             added
+                                             discarded
+                                             plist)
+        nwrapper)))

 \f
 \f

-(defun change-class-internal (instance new-class)
+(defun change-class-internal (instance new-class initargs)

   (let* ((old-class (class-of instance))
   (let* ((old-class (class-of instance))

-        (copy (allocate-instance new-class))
-        (new-wrapper (get-wrapper copy))
-        (old-wrapper (class-wrapper old-class))
-        (old-layout (wrapper-instance-slots-layout old-wrapper))
-        (new-layout (wrapper-instance-slots-layout new-wrapper))
-        (old-slots (get-slots instance))
-        (new-slots (get-slots copy))
-        (old-class-slots (wrapper-class-slots old-wrapper)))
+         (copy (allocate-instance new-class))
+         (new-wrapper (get-wrapper copy))
+         (old-wrapper (class-wrapper old-class))
+         (old-layout (wrapper-instance-slots-layout old-wrapper))
+         (new-layout (wrapper-instance-slots-layout new-wrapper))
+         (old-slots (get-slots instance))
+         (new-slots (get-slots copy))
+         (old-class-slots (wrapper-class-slots old-wrapper)))

 
     ;; "The values of local slots specified by both the class CTO and
     ;; CFROM are retained. If such a local slot was unbound, it
 
     ;; "The values of local slots specified by both the class CTO and
     ;; CFROM are retained. If such a local slot was unbound, it

@@ -1171,44 +1387,93 @@
           (when old-position
             (setf (clos-slots-ref new-slots new-position)
                   (clos-slots-ref old-slots old-position))))
           (when old-position
             (setf (clos-slots-ref new-slots new-position)
                   (clos-slots-ref old-slots old-position))))

-       (incf new-position)))
+        (incf new-position)))

 
     ;; "The values of slots specified as shared in the class CFROM and
     ;; as local in the class CTO are retained."
     (dolist (slot-and-val old-class-slots)
       (let ((position (posq (car slot-and-val) new-layout)))
 
     ;; "The values of slots specified as shared in the class CFROM and
     ;; as local in the class CTO are retained."
     (dolist (slot-and-val old-class-slots)
       (let ((position (posq (car slot-and-val) new-layout)))

-       (when position
-         (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
+        (when position
+          (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))

 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
     (swap-wrappers-and-slots instance copy)
 
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
     (swap-wrappers-and-slots instance copy)
 

-    (update-instance-for-different-class copy instance)
+    (apply #'update-instance-for-different-class copy instance initargs)

     instance))
 
     instance))
 

-(defmethod change-class ((instance standard-object)
-                        (new-class standard-class))
-  (change-class-internal instance new-class))
+(defmethod change-class ((instance standard-object) (new-class standard-class)
+                         &rest initargs)
+  (unless (class-finalized-p new-class)
+    (finalize-inheritance new-class))
+  (let ((cpl (class-precedence-list new-class)))
+    (dolist (class cpl)
+      (macrolet
+          ((frob (class-name)
+             `(when (eq class (find-class ',class-name))
+               (error 'metaobject-initialization-violation
+                :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+                :format-arguments (list 'change-class ',class-name)
+                :references (list '(:amop :initialization ,class-name))))))
+        (frob class)
+        (frob generic-function)
+        (frob method)
+        (frob slot-definition))))
+  (change-class-internal instance new-class initargs))
+
+(defmethod change-class ((instance forward-referenced-class)
+                         (new-class standard-class) &rest initargs)
+  (let ((cpl (class-precedence-list new-class)))
+    (dolist (class cpl
+             (error 'metaobject-initialization-violation
+                    :format-control
+                    "~@<Cannot ~S ~S objects into non-~S objects.~@:>"
+                    :format-arguments
+                    (list 'change-class 'forward-referenced-class 'class)
+                    :references
+                    (list '(:amop :generic-function ensure-class-using-class)
+                          '(:amop :initialization class))))
+      (when (eq class (find-class 'class))
+        (return nil))))
+  (change-class-internal instance new-class initargs))

 
 (defmethod change-class ((instance funcallable-standard-object)
 
 (defmethod change-class ((instance funcallable-standard-object)

-                        (new-class funcallable-standard-class))
-  (change-class-internal instance new-class))
+                         (new-class funcallable-standard-class)
+                         &rest initargs)
+  (let ((cpl (class-precedence-list new-class)))
+    (dolist (class cpl)
+      (macrolet
+          ((frob (class-name)
+             `(when (eq class (find-class ',class-name))
+               (error 'metaobject-initialization-violation
+                :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+                :format-arguments (list 'change-class ',class-name)
+                :references (list '(:amop :initialization ,class-name))))))
+        (frob class)
+        (frob generic-function)
+        (frob method)
+        (frob slot-definition))))
+  (change-class-internal instance new-class initargs))

 
 (defmethod change-class ((instance standard-object)
 
 (defmethod change-class ((instance standard-object)

-                        (new-class funcallable-standard-class))
+                         (new-class funcallable-standard-class)
+                         &rest initargs)
+  (declare (ignore initargs))

   (error "You can't change the class of ~S to ~S~@
   (error "You can't change the class of ~S to ~S~@

-         because it isn't already an instance with metaclass ~S."
-        instance new-class 'standard-class))
+          because it isn't already an instance with metaclass ~S."
+         instance new-class 'standard-class))

 
 (defmethod change-class ((instance funcallable-standard-object)
 
 (defmethod change-class ((instance funcallable-standard-object)

-                        (new-class standard-class))
+                         (new-class standard-class)
+                         &rest initargs)
+  (declare (ignore initargs))

   (error "You can't change the class of ~S to ~S~@
   (error "You can't change the class of ~S to ~S~@

-         because it isn't already an instance with metaclass ~S."
-        instance new-class 'funcallable-standard-class))
+          because it isn't already an instance with metaclass ~S."
+         instance new-class 'funcallable-standard-class))

 
 

-(defmethod change-class ((instance t) (new-class-name symbol))
-  (change-class instance (find-class new-class-name)))
+(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
+  (apply #'change-class instance (find-class new-class-name) initargs))

 \f
 ;;;; The metaclass BUILT-IN-CLASS
 ;;;;
 \f
 ;;;; The metaclass BUILT-IN-CLASS
 ;;;;

@@ -1219,22 +1484,46 @@
 ;;;; But, there are other parts of the protocol we must follow and those
 ;;;; definitions appear here.
 
 ;;;; But, there are other parts of the protocol we must follow and those
 ;;;; definitions appear here.
 

-(defmethod shared-initialize :before
-          ((class built-in-class) slot-names &rest initargs)
-  (declare (ignore slot-names initargs))
-  (error "attempt to initialize or reinitialize a built in class"))
-
-(defmethod class-direct-slots      ((class built-in-class)) ())
-(defmethod class-slots            ((class built-in-class)) ())
-(defmethod class-direct-default-initargs ((class built-in-class)) ())
-(defmethod class-default-initargs      ((class built-in-class)) ())
+(macrolet ((def (name args control)
+               `(defmethod ,name ,args
+                 (declare (ignore initargs))
+                 (error 'metaobject-initialization-violation
+                  :format-control ,(format nil "~@<~A~@:>" control)
+                  :format-arguments (list ',name)
+                  :references (list '(:amop :initialization "Class"))))))
+  (def initialize-instance ((class built-in-class) &rest initargs)
+    "Cannot ~S an instance of BUILT-IN-CLASS.")
+  (def reinitialize-instance ((class built-in-class) &rest initargs)
+    "Cannot ~S an instance of BUILT-IN-CLASS."))
+
+(macrolet ((def (name)
+               `(defmethod ,name ((class built-in-class)) nil)))
+  (def class-direct-slots)
+  (def class-slots)
+  (def class-direct-default-initargs)
+  (def class-default-initargs))

 
 (defmethod validate-superclass ((c class) (s built-in-class))
 
 (defmethod validate-superclass ((c class) (s built-in-class))

-  (or (eq s *the-class-t*)
-      (eq s *the-class-stream*)))
+  (or (eq s *the-class-t*) (eq s *the-class-stream*)
+      ;; FIXME: bad things happen if someone tries to mix in both
+      ;; FILE-STREAM and STRING-STREAM (as they have the same
+      ;; layout-depthoid).  Is there any way we can provide a useful
+      ;; error message?  -- CSR, 2005-05-03
+      (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)))

 \f
 \f

+;;; 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)
 (defmethod validate-superclass ((c slot-class)

-                               (f forward-referenced-class))
+                                (f forward-referenced-class))

   t)
 \f
 (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
   t)
 \f
 (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)

@@ -1242,7 +1531,7 @@
 
 (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
   (setf (plist-value metaobject 'dependents)
 
 (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
   (setf (plist-value metaobject 'dependents)

-       (delete dependent (plist-value metaobject 'dependents))))
+        (delete dependent (plist-value metaobject 'dependents))))

 
 (defmethod map-dependents ((metaobject dependent-update-mixin) function)
   (dolist (dependent (plist-value metaobject 'dependents))
 
 (defmethod map-dependents ((metaobject dependent-update-mixin) function)
   (dolist (dependent (plist-value metaobject 'dependents))