1.0.17.32: faster ADD-METHOD to PRINT-OBJECT

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 89815b9..675d115 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,45 +46,40 @@
   (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:
 ;;;
 
 ;;; CMUCL (Gerd PCL 2003-04-25) comment:
 ;;;

@@ -101,19 +96,18 @@
 ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
 ;;; or some such.
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
 ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
 ;;; or some such.
 (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 (when (class-finalized-p class)
+                      (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-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))))
-      (push (cons class name) *pv-table-cache-update-info*))))
+      (setf (slot-accessor-function slotd type) function))))

 
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
 
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)

@@ -123,7 +117,7 @@
 
 (defmethod class-prototype :before (class)
   (unless (class-finalized-p class)
 
 (defmethod class-prototype :before (class)
   (unless (class-finalized-p class)

-    (error "~S not yet finalized, cannot allocate a prototype." 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
 
 ;;; KLUDGE: For some reason factoring the common body into a function
 ;;; breaks PCL bootstrapping, so just generate it with a macrolet for

@@ -131,7 +125,7 @@
 (macrolet ((def (class)
              `(defmethod class-prototype ((class ,class))
                 (with-slots (prototype) class
 (macrolet ((def (class)
              `(defmethod class-prototype ((class ,class))
                 (with-slots (prototype) class

-                  (or prototype 
+                  (or prototype

                       (setf prototype (allocate-instance class)))))))
   (def std-class)
   (def condition-class)
                       (setf prototype (allocate-instance class)))))))
   (def std-class)
   (def condition-class)

@@ -156,7 +150,7 @@
 ;;; here, the values are read by an automatically generated reader method.
 (defmethod add-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class
 ;;; here, the values are read by an automatically generated reader method.
 (defmethod add-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class

-    (pushnew subclass direct-subclasses)
+    (pushnew subclass direct-subclasses :test #'eq)

     subclass))
 (defmethod remove-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class
     subclass))
 (defmethod remove-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class

@@ -178,15 +172,40 @@
 ;;; In each case, we maintain one value which is a cons. The car is the list
 ;;; methods. The cdr is a list of the generic functions. The cdr is always
 ;;; computed lazily.
 ;;; In each case, we maintain one value which is a cons. The car is the list
 ;;; methods. The cdr is a list of the generic functions. The cdr is always
 ;;; computed lazily.

+
+;;; This needs to be used recursively, in case a non-trivial user
+;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
+;;; function using the same lock.
+(defvar *specializer-lock* (sb-thread::make-spinlock :name "Specializer lock"))
+
+(defmethod add-direct-method :around ((specializer specializer) method)
+  ;; All the actions done under this lock are done in an order
+  ;; that is safe to unwind at any point.
+  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+    (call-next-method)))
+
+(defmethod remove-direct-method :around ((specializer specializer) method)
+  ;; All the actions done under this lock are done in an order
+  ;; that is safe to unwind at any point.
+  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+    (call-next-method)))
+

 (defmethod add-direct-method ((specializer class) (method method))
 (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) ()))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr cell) ()
+          (car cell) (adjoin method (car cell) :test #'eq)))

   method)
   method)

+

 (defmethod remove-direct-method ((specializer class) (method 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) ()))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr cell) ()
+          (car cell) (remove method (car cell))))

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

@@ -194,20 +213,26 @@
     (car direct-methods)))
 
 (defmethod specializer-direct-generic-functions ((specializer class))
     (car 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))
-                  ;; the old PCL code used COLLECTING-ONCE which used
-                  ;; #'EQ to check for newness
-                 (pushnew (method-generic-function m) collect :test #'eq))
-                (nreverse collect))))))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; If an ADD/REMOVE-METHOD is in progress, no matter: either
+    ;; we behave as if we got just first or just after -- it's just
+    ;; for update that we need to lock.
+    (or (cdr cell)
+        (sb-thread::with-spinlock (*specializer-lock*)
+          (setf (cdr cell)
+                (let (collect)
+                  (dolist (m (car cell))
+                    ;; the old PCL code used COLLECTING-ONCE which used
+                    ;; #'EQ to check for newness
+                    (pushnew (method-generic-function m) collect :test #'eq))
+                  (nreverse collect)))))))

 \f
 ;;; This hash table is used to store the direct methods and direct generic
 ;;; functions of EQL specializers. Each value in the table is the cons.
 \f
 ;;; This hash table is used to store the direct methods and direct generic
 ;;; functions of EQL specializers. Each value in the table is the cons.

-(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
-(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
+;;;
+;;; These tables are shared between threads, so they need to be synchronized.
+(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t))
+(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t))

 
 (defmethod specializer-method-table ((specializer eql-specializer))
   *eql-specializer-methods*)
 
 (defmethod specializer-method-table ((specializer eql-specializer))
   *eql-specializer-methods*)

@@ -216,89 +241,95 @@
   *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
     (unless entry

-      (setq entry
-           (setf (gethash object table)
-                 (cons nil nil))))
-    (setf (car entry) (adjoin method (car entry))
-         (cdr entry) ())
+      (setf entry
+            (setf (gethash object table) (cons nil nil))))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr entry) ()
+          (car entry) (adjoin method (car entry) :test #'eq))

     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
     (when entry

-      (setf (car entry) (remove method (car entry))
-           (cdr entry) ()))
+      ;; We need to first smash the CDR, because a parallel read may
+      ;; be in progress, and because if an interrupt catches us we
+      ;; need to have a consistent state.
+      (setf (cdr entry) ()
+            (car entry) (remove method (car 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))
-                  (nreverse collect)))))))
+          (sb-thread::with-spinlock (*specializer-lock*)
+            (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)
 
 (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)
+  (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
         `(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)
+                           readers writers slot-names source-location safe-p)

   (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
   (with-single-package-locked-error (:symbol name "defining ~S as a class")
     (%compiler-defclass name readers writers slot-names)
     (let ((res (apply #'ensure-class name :metaclass metaclass-name
                       :direct-superclasses supers
                       :direct-slots slots

-                      :definition-source `((defclass ,name)
-                                           ,*load-pathname*)
+                      :definition-source source-location
+                      'safe-p safe-p

                       other)))
       res)))
 
                       other)))
       res)))
 

@@ -306,17 +337,16 @@
 
 (defun ensure-class (name &rest args)
   (apply #'ensure-class-using-class
 
 (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))
+         (let ((class (find-class name nil)))
+           (when (and class (eq name (class-name class)))
+             ;; NAME is the proper name of CLASS, so redefine it
+             class))
+         name
+         args))

 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)

-      (ensure-class-values class args)
-    (set-class-type-translation (class-prototype meta) name)
+      (frob-ensure-class-args args)

     (setf class (apply #'make-instance meta :name name initargs))
     (without-package-locks
       (setf (find-class name) class))
     (setf class (apply #'make-instance meta :name name initargs))
     (without-package-locks
       (setf (find-class name) class))

@@ -325,7 +355,7 @@
 
 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
   (multiple-value-bind (meta initargs)
 
 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
   (multiple-value-bind (meta initargs)

-      (ensure-class-values class args)
+      (frob-ensure-class-args args)

     (unless (eq (class-of class) meta)
       (apply #'change-class class meta initargs))
     (apply #'reinitialize-instance class initargs)
     (unless (eq (class-of class) meta)
       (apply #'change-class class meta initargs))
     (apply #'reinitialize-instance class initargs)

@@ -334,125 +364,92 @@
     (set-class-type-translation class name)
     class))
 
     (set-class-type-translation class name)
     class))
 

-(defmethod class-predicate-name ((class t))
-  'constantly-nil)
-
-(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))
-        (t
-        (or (find-class s nil)
-            (make-instance 'forward-referenced-class
-                           :name s)))))
-
-(defun ensure-class-values (class initargs)
+(defun frob-ensure-class-args (args)

   (let (metaclass metaclassp reversed-plist)
   (let (metaclass metaclassp reversed-plist)

-    (doplist (key val) initargs
+    (flet ((frob-superclass (s)
+             (cond
+               ((classp s) s)
+               ((legal-class-name-p s)
+                (or (find-class s nil)
+                    (ensure-class s :metaclass 'forward-referenced-class)))
+               (t (error "Not a class or a legal class name: ~S." s)))))
+      (doplist (key val) args

         (cond ((eq key :metaclass)
         (cond ((eq key :metaclass)

-               (setf metaclass val
-                     metaclassp key))
+               (unless metaclassp
+                 (setf metaclass val metaclassp key)))

               (t
                (when (eq key :direct-superclasses)
               (t
                (when (eq key :direct-superclasses)

-                 (setf val (mapcar #'fix-super val)))
+                 (setf val (mapcar #'frob-superclass val)))

                (setf reversed-plist (list* val key reversed-plist)))))
                (setf reversed-plist (list* val key reversed-plist)))))

-    (values (cond (metaclassp
-                   (find-class metaclass))
-                  ((or (null class) (forward-referenced-class-p class))
-                   *the-class-standard-class*)
-                  (t
-                   (class-of class)))
-            (nreverse reversed-plist))))
-
+      (values (cond (metaclassp
+                     (if (classp metaclass)
+                         metaclass
+                         (find-class metaclass)))
+                    (t *the-class-standard-class*))
+              (nreverse reversed-plist)))))

 \f
 (defmethod shared-initialize :after
 \f
 (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))
+    ((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)
+     definition-source)

   (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 ((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)))))
+        (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 :test #'eq))
+                    (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)
   (add-direct-subclasses class direct-superclasses)

-  (make-class-predicate class predicate-name)
-  (update-class class nil)
-  (do* ((slots (slot-value class 'slots) (cdr slots))
-       (dupes nil))
-       ((null slots) (when dupes
-                      (style-warn
-                       ;; FIXME: the indentation request ("~4I")
-                       ;; below appears not to do anything.  Finding
-                       ;; out why would be nice.  -- CSR, 2003-04-24
-                       "~@<slot names with the same SYMBOL-NAME but ~
-                         different SYMBOL-PACKAGE (possible package problem) ~
-                         for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
-                       class
-                       dupes)))
-    (let* ((slot (car slots))
-          (oslots (remove (slot-definition-name slot) (cdr slots)
-                          :test #'string/= :key #'slot-definition-name)))
-      (when oslots
-       (pushnew (cons (slot-definition-name slot)
-                      (mapcar #'slot-definition-name oslots))
-                dupes
-                :test #'string= :key #'car))))
-  (add-slot-accessors class direct-slots)
+  (if (class-finalized-p class)
+      ;; required by AMOP, "Reinitialization of Class Metaobjects"
+      (finalize-inheritance class)
+      (update-class class nil))
+  (add-slot-accessors class direct-slots definition-source)

   (make-preliminary-layout class))
 
 (defmethod shared-initialize :after ((class forward-referenced-class)
   (make-preliminary-layout class))
 
 (defmethod shared-initialize :after ((class forward-referenced-class)

-                                    slot-names &key &allow-other-keys)
+                                     slot-names &key &allow-other-keys)

   (declare (ignore slot-names))
   (make-preliminary-layout class))
 
   (declare (ignore slot-names))
   (make-preliminary-layout class))
 

@@ -462,44 +459,35 @@
 ;;; make it known to the type system.
 (defun make-preliminary-layout (class)
   (flet ((compute-preliminary-cpl (root)
 ;;; 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))))
+           (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)))
     (without-package-locks
      (unless (class-finalized-p class)
        (let ((name (class-name class)))

-        (setf (find-class name) class)
-        ;; KLUDGE: This is fairly horrible.  We need to make a
-        ;; full-fledged CLASSOID here, not just tell the compiler that
-        ;; some class is forthcoming, because there are legitimate
-        ;; questions one can ask of the type system, implemented in
-        ;; terms of CLASSOIDs, involving forward-referenced classes. So.
-        (when (and (eq *boot-state* 'complete)
-                   (null (find-classoid name nil)))
-          (setf (find-classoid name)
-                (make-standard-classoid :name name)))
-        (set-class-type-translation class name)
-        (let ((layout (make-wrapper 0 class))
-              (classoid (find-classoid name)))
-          (setf (layout-classoid layout) classoid)
-          (setf (classoid-pcl-class classoid) class)
-          (setf (slot-value class 'wrapper) layout)
-          (let ((cpl (compute-preliminary-cpl class)))
-            (setf (layout-inherits layout)
-                  (order-layout-inherits
-                   (map 'simple-vector #'class-wrapper
-                        (reverse (rest cpl))))))
-          (register-layout layout :invalidate t)
-          (setf (classoid-layout classoid) layout)
-          (mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
+         ;; 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 direct-superclasses)
   (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
 
 (defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
   (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))

@@ -507,47 +495,69 @@
   (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 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
 
 (defmethod shared-initialize :after ((class condition-class) slot-names

-                                    &key direct-slots direct-superclasses)
+                                     &key direct-slots direct-superclasses)

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

-  (let ((classoid (find-classoid (class-name class))))
-    (with-slots (wrapper class-precedence-list cpl-available-p
-                         prototype predicate-name
-                        (direct-supers direct-superclasses))
-       class
+  (let ((classoid (find-classoid (slot-value class 'name))))
+    (with-slots (wrapper %class-precedence-list cpl-available-p
+                         prototype (direct-supers direct-superclasses))
+        class

       (setf (slot-value class 'direct-slots)
       (setf (slot-value class 'direct-slots)

-           (mapcar (lambda (pl) (make-direct-slotd class pl))
-                   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))
       (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 %class-precedence-list (compute-class-precedence-list class))

       (setq cpl-available-p t)
       (add-direct-subclasses class direct-superclasses)
       (setq cpl-available-p t)
       (add-direct-subclasses class direct-superclasses)

-      (setq predicate-name (make-class-predicate-name (class-name class)))
-      (make-class-predicate class predicate-name)
-      (setf (slot-value class 'slots) (compute-slots class))))
+      (let ((slots (compute-slots class)))
+        (setf (slot-value class 'slots) slots)
+        (setf (layout-slot-table wrapper) (make-slot-table class slots)))))

   ;; 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.
   ;; Comment from Gerd's PCL, 2003-05-15:
   ;;
   ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
   ;; override condition accessors with generic functions.  We do this
   ;; differently.

-  (update-pv-table-cache-info class))
+  ;;
+  ;; ??? 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
+  )

 
 (defmethod direct-slot-definition-class ((class condition-class)
 
 (defmethod direct-slot-definition-class ((class condition-class)

-                                        &rest initargs)
+                                         &rest initargs)

   (declare (ignore initargs))
   (find-class 'condition-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class condition-class)
   (declare (ignore initargs))
   (find-class 'condition-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class condition-class)

-                                           &rest initargs)
+                                            &rest initargs)

   (declare (ignore initargs))
   (find-class 'condition-effective-slot-definition))
 
   (declare (ignore initargs))
   (find-class 'condition-effective-slot-definition))
 

@@ -559,30 +569,30 @@
     ((class condition-class) slot-name dslotds)
   (let ((slotd (call-next-method)))
     (setf (slot-definition-reader-function slotd)
     ((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))))))
+          (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)
     (setf (slot-definition-writer-function slotd)

-         (lambda (v x)
-           (condition-writer-function x v slot-name)))
+          (lambda (v x)
+            (condition-writer-function x v slot-name)))

     (setf (slot-definition-boundp-function slotd)
     (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))))
+          (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)
     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))))
+            (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)))
 
 (defmethod compute-slots :around ((class condition-class))
   (let ((eslotds (call-next-method)))

@@ -612,13 +622,13 @@
                                 direct-slots)))
          (reader-names (mapcar (lambda (slotd)
                                  (list 'slot-accessor name
                                 direct-slots)))
          (reader-names (mapcar (lambda (slotd)
                                  (list 'slot-accessor name

-                                      (slot-definition-name slotd)
-                                      'reader))
+                                       (slot-definition-name slotd)
+                                       'reader))

                                direct-slots))
          (writer-names (mapcar (lambda (slotd)
                                  (list 'slot-accessor name
                                direct-slots))
          (writer-names (mapcar (lambda (slotd)
                                  (list 'slot-accessor name

-                                      (slot-definition-name slotd)
-                                      'writer))
+                                       (slot-definition-name slotd)
+                                       'writer))

                                direct-slots))
          (readers-init
            (mapcar (lambda (slotd reader-name)
                                direct-slots))
          (readers-init
            (mapcar (lambda (slotd reader-name)

@@ -645,89 +655,76 @@
                (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 ()
-      (let ((instance (%make-instance (dd-length dd)))
-           (raw-index (dd-raw-index dd)))
-       (setf (%instance-layout instance)
-             (sb-kernel::compiler-layout-or-lose (dd-name dd)))
-       (when raw-index
-         (setf (%instance-ref instance raw-index)
-               (make-array (dd-raw-length dd)
-                           :element-type '(unsigned-byte 32))))
-       instance))))
+(defun make-defstruct-allocation-function (name)
+  ;; FIXME: Why don't we go class->layout->info == dd
+  (let ((dd (find-defstruct-description name)))
+    (%make-structure-instance-allocator dd nil)))

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

-    ((class structure-class)
-     slot-names
-     &key (direct-superclasses nil direct-superclasses-p)
+    ((class structure-class) slot-names &key
+     (direct-superclasses nil direct-superclasses-p)

      (direct-slots nil direct-slots-p)
      direct-default-initargs
      (direct-slots nil direct-slots-p)
      direct-default-initargs

-     (predicate-name nil predicate-name-p))
+     definition-source)

   (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 (slot-value class 'name) 'structure-object))
+                           (list *the-class-structure-object*)))))

       (setq direct-superclasses (slot-value class 'direct-superclasses)))
       (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)))))
+  (let* ((name (slot-value class '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))
-                                      (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)))
+        (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
     (if defstruct-p

-       (let ((include (car (slot-value class 'direct-superclasses))))
-         (multiple-value-bind (defstruct-form constructor reader-names writer-names)
-             (make-structure-class-defstruct-form name direct-slots include)
-           (unless (structure-type-p name) (eval defstruct-form))
-           (mapc (lambda (dslotd reader-name writer-name)
-                   (let* ((reader (gdefinition reader-name))
-                          (writer (when (gboundp writer-name)
-                                    (gdefinition writer-name))))
-                     (setf (slot-value dslotd 'internal-reader-function)
-                           reader)
-                     (setf (slot-value dslotd 'internal-writer-function)
-                           writer)))
-                 direct-slots reader-names writer-names)
-           (setf (slot-value class 'defstruct-form) defstruct-form)
-           (setf (slot-value class 'defstruct-constructor) constructor)))
-       (setf (slot-value class 'defstruct-constructor)
-             (make-defstruct-allocation-function class)))
+        (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)
+              ;; KLUDGE: not class; in fixup.lisp, can't access slots
+              ;; outside methods yet.
+              (make-defstruct-allocation-function name)))

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

-    (setf (slot-value class 'class-precedence-list)
+    (setf (slot-value class '%class-precedence-list)

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

-    (setf (slot-value class 'slots) (compute-slots class))
-    (let ((lclass (find-classoid (class-name class))))
-      (setf (classoid-pcl-class lclass) class)
-      (setf (slot-value class 'wrapper) (classoid-layout lclass)))
+    (let ((slots (compute-slots class)))
+      (setf (slot-value class 'slots) slots)
+      (let* ((lclass (find-classoid (slot-value class 'name)))
+             (layout (classoid-layout lclass)))
+        (setf (classoid-pcl-class lclass) class)
+        (setf (slot-value class 'wrapper) layout)
+        (setf (layout-slot-table layout) (make-slot-table class slots))))

     (setf (slot-value class 'finalized-p) t)
     (setf (slot-value class 'finalized-p) t)

-    (update-pv-table-cache-info class)
-    (setq predicate-name (if predicate-name-p
-                          (setf (slot-value class 'predicate-name)
-                                   (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 definition-source)))

 
 (defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))
 
 (defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))

@@ -736,40 +733,37 @@
 (defmethod finalize-inheritance ((class structure-class))
   nil) ; always finalized
 \f
 (defmethod finalize-inheritance ((class structure-class))
   nil) ; always finalized
 \f

-(defun add-slot-accessors (class dslotds)
-  (fix-slot-accessors class dslotds 'add))
+(defun add-slot-accessors (class dslotds &optional source-location)
+  (fix-slot-accessors class dslotds 'add source-location))

 
 (defun remove-slot-accessors (class dslotds)
   (fix-slot-accessors class dslotds 'remove))
 
 
 (defun remove-slot-accessors (class dslotds)
   (fix-slot-accessors class dslotds 'remove))
 

-(defun fix-slot-accessors (class dslotds add/remove)
-  (flet ((fix (gfspec name r/w)
+(defun fix-slot-accessors (class dslotds add/remove &optional source-location)
+  (flet ((fix (gfspec name r/w doc)

            (let ((gf (cond ((eq add/remove 'add)
            (let ((gf (cond ((eq add/remove 'add)

-                            (if (fboundp gfspec)
-                                (without-package-locks 
-                                  (ensure-generic-function gfspec))
-                                (ensure-generic-function 
+                            (or (find-generic-function gfspec nil)
+                                (ensure-generic-function

                                  gfspec :lambda-list (case r/w
                                                        (r '(object))
                                                        (w '(new-value object))))))
                                  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))))))
+                           (t
+                            (find-generic-function gfspec nil)))))

              (when gf
                (case r/w
                  (r (if (eq add/remove 'add)
              (when gf
                (case r/w
                  (r (if (eq add/remove 'add)

-                        (add-reader-method class gf name)
+                        (add-reader-method class gf name doc source-location)

                         (remove-reader-method class gf)))
                  (w (if (eq add/remove 'add)
                         (remove-reader-method class gf)))
                  (w (if (eq add/remove 'add)

-                        (add-writer-method class gf name)
+                        (add-writer-method class gf name doc source-location)

                         (remove-writer-method class gf))))))))
     (dolist (dslotd dslotds)
                         (remove-writer-method class gf))))))))
     (dolist (dslotd dslotds)

-      (let ((slot-name (slot-definition-name dslotd)))
-        (dolist (r (slot-definition-readers dslotd)) 
-          (fix r slot-name 'r))
-        (dolist (w (slot-definition-writers dslotd)) 
-          (fix w slot-name 'w))))))
+      (let ((slot-name (slot-definition-name dslotd))
+            (slot-doc (%slot-definition-documentation dslotd)))
+        (dolist (r (slot-definition-readers dslotd))
+          (fix r slot-name 'r slot-doc))
+        (dolist (w (slot-definition-writers dslotd))
+          (fix w slot-name 'w slot-doc))))))

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

@@ -793,53 +787,60 @@
 (defun class-has-a-forward-referenced-superclass-p (class)
   (or (forward-referenced-class-p class)
       (some #'class-has-a-forward-referenced-superclass-p
 (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)

-  ;; Comment from Gerd Moellmann:
-  ;;
-  ;; Note that we can't simply delay the finalization when CLASS has
-  ;; no forward referenced superclasses because that causes bootstrap
-  ;; problems.

   (without-package-locks
   (without-package-locks

-   (when (and (not finalizep)
-             (not (class-finalized-p class))
-             (not (class-has-a-forward-referenced-superclass-p class)))
-     (finalize-inheritance class)
-     (return-from update-class))
-   (when (or finalizep (class-finalized-p class)
-            (not (class-has-a-forward-referenced-superclass-p class)))
-     (setf (find-class (class-name class)) class)
-     (update-cpl class (compute-class-precedence-list class))
-     ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
-     ;; class.  The hoops above are to ensure that FINALIZE-INHERITANCE
-     ;; is called at finalization, so that MOP programmers can hook
-     ;; into the system as described in "Class Finalization Protocol"
-     ;; (section 5.5.2 of AMOP).
-     (update-slots class (compute-slots class))
-     (update-gfs-of-class class)
-     (update-initargs class (compute-default-initargs class))
-     (update-ctors 'finalize-inheritance :class class))
-   (unless finalizep
-     (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))))
+    (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)
       (unless (and (equal (class-precedence-list class) cpl)
   (if (class-finalized-p class)
       (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)
+                   (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)
         (setf (slot-value class 'cpl-available-p) t)

-       (force-cache-flushes class))
+        (force-cache-flushes class))

       (progn
       (progn

-        (setf (slot-value class 'class-precedence-list) cpl)
+        (setf (slot-value class '%class-precedence-list) cpl)

         (setf (slot-value class 'cpl-available-p) t)))
   (update-class-can-precede-p cpl))
 
         (setf (slot-value class 'cpl-available-p) t)))
   (update-class-can-precede-p cpl))
 

@@ -847,94 +848,112 @@
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr 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) :test #'eq)))

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

-  (member class2 (class-can-precede-list class1)))
+  (member class2 (class-can-precede-list class1) :test #'eq))

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

-       (case alloc
+        (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
           (: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

-                           (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
+                            (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)))))
-
-      (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))
+                   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)))))
+
+      (update-lisp-class-layout class nwrapper)
+      (setf (slot-value class 'slots) eslotds
+            (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
+            (wrapper-instance-slots-layout nwrapper) nlayout
+            (wrapper-class-slots nwrapper) nwrapper-class-slots
+            (wrapper-length nwrapper) nslots
+            (slot-value class 'wrapper) nwrapper)
+      (do* ((slots (slot-value class 'slots) (cdr slots))
+            (dupes nil))
+           ((null slots)
+            (when dupes
+              (style-warn
+               "~@<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))))

       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)

-       (update-pv-table-cache-info class)
-       (maybe-update-standard-class-locations 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-class eslotd)))
-            collect))
-    (nreverse collect)))
+    (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 :test #'eq)
+                   (member *the-class-standard-effective-slot-definition*
+                           cpl :test #'eq))))

     (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)))))
+                 (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))
   (let ((initargs (loop for c in (class-precedence-list class)
 
 (defun update-initargs (class inits)
   (setf (plist-value class 'default-initargs) inits))
 \f
 (defmethod compute-default-initargs ((class slot-class))
   (let ((initargs (loop for c in (class-precedence-list class)

-                       append (class-direct-default-initargs c))))
+                        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
     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
 \f
 ;;;; protocols for constructing direct and effective slot definitions

@@ -957,7 +976,7 @@
 ;;; 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?
 ;;; 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?

-(defmethod compute-slots ((class std-class))
+(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.
   ;; 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.

@@ -965,113 +984,73 @@
   (let ((name-dslotds-alist ()))
     (dolist (c (reverse (class-precedence-list class)))
       (dolist (slot (class-direct-slots c))
   (let ((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)))))
+        (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
-                                                (car direct)
-                                                (cdr direct)))
-           (nreverse name-dslotds-alist))))
+              (compute-effective-slot-definition class
+                                                 (car direct)
+                                                 (cdr direct)))
+            (nreverse name-dslotds-alist))))

 
 (defmethod compute-slots ((class standard-class))
 
 (defmethod compute-slots ((class standard-class))

-  (call-next-method))
+  (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
+  (std-compute-slots class))

 
 

-(defmethod compute-slots :around ((class standard-class))
-  (let ((eslotds (call-next-method))
-       (location -1))
+(defun std-compute-slots-around (class eslotds)
+  (let ((location -1))

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

-           (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))
-                               (setf (class-slot-cells from-class)
-                                     (cons (cons name +slot-unbound+)
-                                           (class-slot-cells from-class))))))
-                (aver (consp cell))
-                (if (eq +slot-unbound+ (cdr cell))
-                    ;; We may have inherited an initfunction
-                    (let ((initfun (slot-definition-initfunction eslotd)))
-                      (if initfun
-                          (rplacd cell (funcall initfun))
-                          cell))
-                    cell)))))
+            (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)
       (unless (slot-definition-class eslotd)

-       (setf (slot-definition-class eslotd) class))
+        (setf (slot-definition-class eslotd) class))

       (initialize-internal-slot-functions eslotd))))
 
       (initialize-internal-slot-functions eslotd))))
 

-(defmethod compute-slots ((class funcallable-standard-class))
-  (call-next-method))
-
+(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))
 (defmethod compute-slots :around ((class funcallable-standard-class))

-  (labels ((instance-slot-names (slotds)
-            (let (collect)
-              (dolist (slotd slotds (nreverse collect))
-                (when (eq (slot-definition-allocation slotd) :instance)
-                  (push (slot-definition-name slotd) collect)))))
-          ;; This sorts slots so that slots of classes later in the CPL
-           ;; come before slots of other classes.  This is crucial for
-           ;; funcallable instances because it ensures that the slots of
-           ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
-           ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
-           ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
-           ;; a funcallable instance.
-          (compute-layout (eslotds)
-            (let ((first ())
-                  (names (instance-slot-names eslotds)))
-              (dolist (class
-                       (reverse (class-precedence-list class))
-                       (nreverse (nconc names first)))
-                (dolist (ss (class-slots class))
-                  (let ((name (slot-definition-name ss)))
-                    (when (member name names)
-                      (push name first)
-                      (setq names (delete name names)))))))))
-    (let ((all-slotds (call-next-method))
-         (instance-slots ())
-         (class-slots ()))
-      (dolist (slotd all-slotds)
-       (case (slot-definition-allocation slotd)
-         (:instance (push slotd instance-slots))
-         (:class (push slotd class-slots))))
-      (let ((layout (compute-layout instance-slots)))
-       (dolist (slotd instance-slots)
-         (setf (slot-definition-location slotd)
-               (position (slot-definition-name slotd) layout))
-         (initialize-internal-slot-functions slotd)))
-      (dolist (slotd class-slots)
-       (let ((name (slot-definition-name slotd))
-             (from-class (slot-definition-allocation-class slotd)))
-         (setf (slot-definition-location slotd)
-               (assoc name (class-slot-cells from-class)))
-         (aver (consp (slot-definition-location slotd)))
-         (initialize-internal-slot-functions slotd)))
-      all-slotds)))
+  (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
-                      (slot-definition-name dslotd)
-                      (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)))
 
 (defmethod compute-slots :around ((class structure-class))
   (let ((eslotds (call-next-method)))

@@ -1081,7 +1060,7 @@
 (defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
   (declare (ignore name))
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
 (defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
   (declare (ignore name))
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))

-        (class (apply #'effective-slot-definition-class class initargs)))
+         (class (apply #'effective-slot-definition-class class initargs)))

     (apply #'make-instance class initargs)))
 
 (defmethod effective-slot-definition-class ((class std-class) &rest initargs)
     (apply #'make-instance class initargs)))
 
 (defmethod effective-slot-definition-class ((class std-class) &rest initargs)

@@ -1095,54 +1074,77 @@
 (defmethod compute-effective-slot-definition-initargs
     ((class slot-class) direct-slotds)
   (let* ((name nil)
 (defmethod compute-effective-slot-definition-initargs
     ((class slot-class) direct-slotds)
   (let* ((name nil)

-        (initfunction nil)
-        (initform nil)
-        (initargs nil)
-        (allocation nil)
-        (allocation-class nil)
-        (type t)
-        (namep  nil)
-        (initp  nil)
-        (allocp nil))
+         (initfunction nil)
+         (initform nil)
+         (initargs nil)
+         (allocation nil)
+         (allocation-class nil)
+         (type t)
+         (type-check-function nil)
+         (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)
-               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)
-                          ((*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 ((fun (slot-definition-type-check-function slotd)))
+          (when fun
+            (setf type-check-function
+                  (if type-check-function
+                      (let ((old-function type-check-function))
+                        (lambda (value)
+                          (funcall old-function value)
+                          (funcall fun value)))
+                      fun))))
+        (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
-         :allocation-class allocation-class
-         :type type
-         :class class)))
+          :initform initform
+          :initfunction initfunction
+          :initargs initargs
+          :allocation allocation
+          :allocation-class allocation-class
+          :type type
+          'type-check-function type-check-function
+          :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

@@ -1151,39 +1153,47 @@
   (declare (ignore direct-slot initargs))
   (find-class 'standard-reader-method))
 
   (declare (ignore direct-slot initargs))
   (find-class 'standard-reader-method))
 

-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation source-location)

   (add-method generic-function
   (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)
+                             (or slot-documentation "automatically generated reader method")
+                             :slot-name slot-name
+                             :object-class class
+                             :method-class-function #'reader-method-class
+                             :definition-source source-location)))

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

-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation source-location)

   (add-method generic-function
   (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)))
-
-(defmethod add-boundp-method ((class slot-class) generic-function 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)
+                             (or slot-documentation "automatically generated writer method")
+                             :slot-name slot-name
+                             :object-class class
+                             :method-class-function #'writer-method-class
+                             :definition-source source-location)))
+
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location)

   (add-method generic-function
   (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 (constantly (find-class 'standard-boundp-method))
+                             class
+                             ()
+                             (list (or (class-name class) 'object))
+                             (list class)
+                             (make-boundp-method-function class slot-name)
+                             (or slot-documentation "automatically generated boundp method")
+                             :slot-name slot-name
+                             :definition-source source-location)))

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

@@ -1191,16 +1201,17 @@
 
 (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
-;;; use of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
+;;; function are NOT part of the standard protocol. They are however
+;;; useful; PCL makes use of them internally and documents them for
+;;; PCL users.  (FIXME: but SBCL certainly doesn't)

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

@@ -1212,25 +1223,24 @@
 ;;; *** 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)

-  (make-std-reader-method-function (class-name class) slot-name))
+  (make-std-reader-method-function class slot-name))

 
 (defmethod make-writer-method-function ((class slot-class) slot-name)
 
 (defmethod make-writer-method-function ((class slot-class) slot-name)

-  (make-std-writer-method-function (class-name class) slot-name))
+  (make-std-writer-method-function class slot-name))

 
 (defmethod make-boundp-method-function ((class slot-class) slot-name)
 
 (defmethod make-boundp-method-function ((class slot-class) slot-name)

-  (make-std-boundp-method-function (class-name class) slot-name))
+  (make-std-boundp-method-function class slot-name))

 \f
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 
 \f
 (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
 ;;; What this does depends on which of the four possible values of
 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
 \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

@@ -1259,28 +1269,30 @@
     ;; 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))
     ;; 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)
-                                   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)))))))
+              ;; 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 (layout-length owrapper)
+                                    class)))
+        (setf (wrapper-instance-slots-layout nwrapper)
+              (wrapper-instance-slots-layout owrapper))
+        (setf (wrapper-class-slots nwrapper)
+              (wrapper-class-slots owrapper))
+        (setf (wrapper-slot-table nwrapper)
+              (wrapper-slot-table 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))

@@ -1291,17 +1303,23 @@
 ;;; 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))
-      (with-pcl-lock
-       (update-lisp-class-layout class nwrapper)
-       (setf (slot-value class 'wrapper) nwrapper)
-       (invalidate-wrapper owrapper :obsolete nwrapper)
-       class)))
+         (nwrapper (make-wrapper (layout-length 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))
+    (setf (wrapper-slot-table nwrapper)
+          (wrapper-slot-table 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))
   (make-instances-obsolete (find-class class))
 
 (defmethod make-instances-obsolete ((class symbol))
   (make-instances-obsolete (find-class class))

@@ -1345,45 +1363,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)
 
 (defun obsolete-instance-trap (owrapper nwrapper instance)

-  (if (not (pcl-instance-p instance))
+  (if (not (layout-for-std-class-p owrapper))

       (if *in-obsolete-instance-trap*
       (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 value
-       ;; local  --> shared    discard value, discard slot
-       ;; local  -->  --       discard slot
-       ;; shared --> local     transfer value
-       ;; shared --> shared    -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
-       ;; shared -->  --       discard value
-       ;;  --    --> local     add slot
-       ;;  --    --> shared    --
-
-       ;; Collect class slots from inherited wrappers. Needed for
-       ;; shared -> local transfers of inherited slots.
-       (let ((inherited (layout-inherits owrapper)))
-         (loop for i from (1- (length inherited)) downto 0
-               for layout = (aref inherited i)
-               when (typep layout 'wrapper)
-               do (dolist (slot (wrapper-class-slots layout))
-                    (pushnew slot oclass-slots :key #'car))))
-
-       ;; Go through all the old local slots.
+             (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)))

@@ -1396,38 +1405,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)))
-             (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)))
+          (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
 (defun change-class-internal (instance new-class initargs)
   (let* ((old-class (class-of instance))
 \f
 (defun change-class-internal (instance new-class initargs)
   (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

@@ -1438,14 +1447,14 @@
           (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.
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.

@@ -1454,31 +1463,74 @@
     (apply #'update-instance-for-different-class copy instance initargs)
     instance))
 
     (apply #'update-instance-for-different-class copy instance initargs)
     instance))
 

-(defmethod change-class ((instance standard-object)
-                        (new-class standard-class)
-                        &rest initargs)
+(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)
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance funcallable-standard-object)

-                        (new-class funcallable-standard-class)
-                        &rest initargs)
+                         (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)
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance standard-object)

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

   (declare (ignore initargs))
   (error "You can't change the class of ~S to ~S~@
   (declare (ignore initargs))
   (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)
-                        &rest initargs)
+                         (new-class standard-class)
+                         &rest initargs)

   (declare (ignore initargs))
   (error "You can't change the class of ~S to ~S~@
   (declare (ignore initargs))
   (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) &rest initargs)
   (apply #'change-class instance (find-class new-class-name) initargs))
 
 (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
   (apply #'change-class instance (find-class new-class-name) initargs))

@@ -1492,15 +1544,24 @@
 ;;;; 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))
   (or (eq s *the-class-t*) (eq s *the-class-stream*)
 
 (defmethod validate-superclass ((c class) (s built-in-class))
   (or (eq s *the-class-t*) (eq s *the-class-stream*)

@@ -1508,7 +1569,11 @@
       ;; 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
       ;; 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*)))
+      (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)
+      ;; This probably shouldn't be mixed in with certain other
+      ;; classes, too, but it seems to work both with STANDARD-OBJECT
+      ;; and FUNCALLABLE-STANDARD-OBJECT
+      (eq s *the-class-sequence*)))

 \f
 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
 (defmethod class-direct-slots ((class forward-referenced-class)) ())
 \f
 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
 (defmethod class-direct-slots ((class forward-referenced-class)) ())

@@ -1522,15 +1587,15 @@
   (def class-slots))
 
 (defmethod validate-superclass ((c slot-class)
   (def class-slots))
 
 (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)

-  (pushnew dependent (plist-value metaobject 'dependents)))
+  (pushnew dependent (plist-value metaobject 'dependents) :test #'eq))

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