0.9.4.56:

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index b9c034e..ef7c7c2 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,44 +46,44 @@
   (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)))
+         (class (slot-value slotd 'class)))

     (let ((table (or (gethash name *name->class->slotd-table*)
     (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 name *name->class->slotd-table*)
+                           (make-hash-table :test 'eq :size 5)))))

       (setf (gethash class table) slotd))
     (dolist (type '(reader writer boundp))
       (let* ((gf-name (ecase type
       (setf (gethash class table) slotd))
     (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)))
+                              (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)))
 
 ;;; CMUCL (Gerd PCL 2003-04-25) comment:
     (initialize-internal-slot-gfs name)))
 
 ;;; CMUCL (Gerd PCL 2003-04-25) comment:

@@ -101,15 +101,15 @@
 ;;; 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 (find-slot-definition class name))
+         (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))

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

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

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

@@ -121,17 +121,21 @@
 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 
 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 

-(defmethod class-prototype ((class std-class))
-  (with-slots (prototype) class
-    (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype wrapper defstruct-constructor) class
-    (or prototype
-       (setq prototype
-             (if defstruct-constructor
-                 (allocate-instance class)
-                 (allocate-standard-instance wrapper))))))
+(defmethod class-prototype :before (class)
+  (unless (class-finalized-p class)
+    (error "~@<~S is not finalized.~:@>" class)))
+
+;;; KLUDGE: For some reason factoring the common body into a function
+;;; breaks PCL bootstrapping, so just generate it with a macrolet for
+;;; all.
+(macrolet ((def (class)
+             `(defmethod class-prototype ((class ,class))
+                (with-slots (prototype) class
+                  (or prototype
+                      (setf prototype (allocate-instance class)))))))
+  (def std-class)
+  (def condition-class)
+  (def structure-class))

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

@@ -141,6 +145,8 @@
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))

+(defmethod (setf class-slot-cells) (new-value (class std-class))
+  (setf (plist-value class 'class-slot-cells) new-value))

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

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

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

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

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

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

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

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

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

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

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

@@ -210,103 +216,110 @@
   *class-eq-specializer-methods*)
 
 (defmethod add-direct-method ((specializer specializer-with-object)
   *class-eq-specializer-methods*)
 
 (defmethod add-direct-method ((specializer specializer-with-object)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   (declare (ignore slot-names))
   (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))
   (declare (ignore slot-names))
   (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))

-  (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
-\f
-(defun real-load-defclass (name metaclass-name supers slots other)
-  (let ((res (apply #'ensure-class name :metaclass metaclass-name
-                   :direct-superclasses supers
-                   :direct-slots slots
-                   :definition-source `((defclass ,name)
-                                        ,*load-pathname*)
-                   other)))
-    res))
+  (setf (slot-value specl 'type)
+        `(eql ,(specializer-object specl)))
+  (setf (info :type :translator specl)
+        (constantly (make-member-type :members (list (specializer-object specl))))))
+
+(defun real-load-defclass (name metaclass-name supers slots other
+                           readers writers slot-names)
+  (with-single-package-locked-error (:symbol name "defining ~S as a class")
+    (%compiler-defclass name readers writers slot-names)
+    (let ((res (apply #'ensure-class name :metaclass metaclass-name
+                      :direct-superclasses supers
+                      :direct-slots slots
+                      :definition-source `((defclass ,name)
+                                           ,*load-pathname*)
+                      other)))
+      res)))

 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 (defun ensure-class (name &rest args)
   (apply #'ensure-class-using-class
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 (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)
       (ensure-class-values class args)
     (set-class-type-translation (class-prototype meta) name)
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
     (set-class-type-translation (class-prototype meta) name)

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

     (set-class-type-translation class name)
     class))
 
     (set-class-type-translation class name)
     class))
 

@@ -316,7 +329,8 @@
     (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)

-    (setf (find-class name) class)
+    (without-package-locks
+      (setf (find-class name) class))

     (set-class-type-translation class name)
     class))
 
     (set-class-type-translation class name)
     class))
 

@@ -326,192 +340,121 @@
 (defun fix-super (s)
   (cond ((classp s) s)
         ((not (legal-class-name-p s))
 (defun fix-super (s)
   (cond ((classp s) s)
         ((not (legal-class-name-p s))

-        (error "~S is not a class or a legal class name." s))
+         (error "~S is not a class or a legal class name." s))

         (t
         (t

-        (or (find-class s nil)
-            (make-instance 'forward-referenced-class
-                           :name s)))))
-
-(defun ensure-class-values (class args)
-  (let* ((initargs (copy-list args))
-        (unsupplied (list 1))
-        (supplied-meta   (getf initargs :metaclass unsupplied))
-        (supplied-supers (getf initargs :direct-superclasses unsupplied))
-        (supplied-slots  (getf initargs :direct-slots unsupplied))
-        (meta
-          (cond ((neq supplied-meta unsupplied)
-                 (find-class supplied-meta))
-                ((or (null class)
-                     (forward-referenced-class-p class))
-                 *the-class-standard-class*)
-                (t
-                 (class-of class)))))
-    ;; KLUDGE: It seemed to me initially that there ought to be a way
-    ;; of collecting all the erroneous problems in one go, rather than
-    ;; this way of solving the problem of signalling the errors that
-    ;; we are required to, which stops at the first bogus input.
-    ;; However, after playing around a little, I couldn't find that
-    ;; way, so I've left it as is, but if someone does come up with a
-    ;; better way... -- CSR, 2002-09-08
-    (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots)))
-       ((endp direct-slots) nil)
-      (destructuring-bind (slot &rest more) direct-slots
-       (let ((slot-name (getf slot :name)))
-         (when (some (lambda (s) (eq slot-name (getf s :name))) more)
-           ;; FIXME: It's quite possible that we ought to define an
-           ;; SB-INT:PROGRAM-ERROR function to signal these and other
-           ;; errors throughout the codebase that are required to be
-           ;; of type PROGRAM-ERROR.
-           (error 'simple-program-error
-                  :format-control "~@<There is more than one direct slot ~
-                                   with name ~S.~:>"
-                  :format-arguments (list slot-name)))
-         (do ((stuff slot (cddr stuff)))
-             ((endp stuff) nil)
-           (destructuring-bind (option value &rest more) stuff
-             (cond
-               ((and (member option '(:allocation :type
-                                      :initform :documentation))
-                     (not (eq unsupplied
-                              (getf more option unsupplied))))
-                (error 'simple-program-error
-                       :format-control "~@<Duplicate slot option ~S for ~
-                                        slot named ~S.~:>"
-                       :format-arguments (list option slot-name)))
-               ((and (eq option :readers)
-                     (notevery #'symbolp value))
-                (error 'simple-program-error
-                       :format-control "~@<Slot reader names for slot ~
-                                        named ~S must be symbols.~:>"
-                       :format-arguments (list slot-name)))
-               ((and (eq option :initargs)
-                     (notevery #'symbolp value))
-                (error 'simple-program-error
-                       :format-control "~@<Slot initarg names for slot ~
-                                        named ~S must be symbols.~:>"
-                       :format-arguments (list slot-name)))))))))
-    (loop for (initarg . more) on (getf initargs :direct-default-initargs)
-         for name = (car initarg) 
-         when (some (lambda (a) (eq (car a) name)) more) 
-         do (error 'simple-program-error 
-                   :format-control "~@<Duplicate initialization argument ~
-                                    name ~S in :DEFAULT-INITARGS.~:>"
-                   :format-arguments (list name class)))
-    (let ((metaclass 0)
-         (default-initargs 0))
-      (do ((args initargs (cddr args)))
-         ((endp args) nil)
-       (case (car args)
-         (:metaclass
-          (when (> (incf metaclass) 1)
-            (error 'simple-program-error
-                   :format-control "~@<More than one :METACLASS ~
-                                    option specified.~:>")))
-         (:direct-default-initargs
-          (when (> (incf default-initargs) 1)
-            (error 'simple-program-error
-                   :format-control "~@<More than one :DEFAULT-INITARGS ~
-                                    option specified.~:>"))))))
-    (remf initargs :metaclass)
-    (loop (unless (remf initargs :direct-superclasses) (return)))
-    (loop (unless (remf initargs :direct-slots) (return)))
-    (values
-     meta
-     (nconc
-      (when (neq supplied-supers unsupplied)
-       (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
-      (when (neq supplied-slots unsupplied)
-       (list :direct-slots supplied-slots))
-      initargs))))
+         (or (find-class s nil)
+             (make-instance 'forward-referenced-class
+                            :name s)))))
+
+(defun ensure-class-values (class initargs)
+  (let (metaclass metaclassp reversed-plist)
+    (doplist (key val) initargs
+      (cond ((eq key :metaclass)
+             (setf metaclass val
+                   metaclassp key))
+            (t
+             (when (eq key :direct-superclasses)
+               (setf val (mapcar #'fix-super val)))
+             (setf reversed-plist (list* val key reversed-plist)))))
+    (values (cond (metaclassp
+                   (if (classp metaclass)
+                       metaclass
+                       (find-class metaclass)))
+                  ((or (null class) (forward-referenced-class-p class))
+                   *the-class-standard-class*)
+                  (t
+                   (class-of class)))
+            (nreverse reversed-plist))))
+

 \f
 (defmethod shared-initialize :after
 \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)
+                 (predicate-name nil predicate-name-p))

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

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

   (setq direct-slots
   (setq direct-slots

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

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

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

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

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

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

-       (let ((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))
+                    (let* ((initfunction (slot-definition-initfunction dslotd))
+                           (value (if initfunction
+                                      (funcall initfunction)
+                                      +slot-unbound+)))
+                      (push (cons name value) collect))
+                    (push old collect)))))

           (nreverse collect)))
   (setq predicate-name (if predicate-name-p
           (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))))))
+                           (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)
   (make-class-predicate class predicate-name)
   (update-class class nil)
   (do* ((slots (slot-value class 'slots) (cdr slots))
   (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))
+        (dupes nil))

        ((null slots) (when dupes
        ((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 ~
+                       (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~^~:@_~}~:>~@:>"
                          different SYMBOL-PACKAGE (possible package problem) ~
                          for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"

-                       class
-                       dupes)))
+                        class
+                        dupes)))

     (let* ((slot (car slots))
     (let* ((slot (car slots))

-          (oslots (remove (slot-definition-name slot) (cdr slots)
-                          :test #'string/= :key #'slot-definition-name)))
+           (oslots (remove (slot-definition-name slot) (cdr slots)
+                           :test #'string/= :key #'slot-definition-name)))

       (when oslots
       (when oslots

-       (pushnew (cons (slot-definition-name slot)
-                      (mapcar #'slot-definition-name oslots))
-                dupes
-                :test #'string= :key #'car))))
+        (pushnew (cons (slot-definition-name slot)
+                       (mapcar #'slot-definition-name oslots))
+                 dupes
+                 :test #'string= :key #'car))))

   (add-slot-accessors class direct-slots)
   (make-preliminary-layout class))
 
 (defmethod shared-initialize :after ((class forward-referenced-class)
   (add-slot-accessors class direct-slots)
   (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))
 

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

 
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
 
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)

@@ -557,35 +501,37 @@
   ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
   (setf (slot-value class 'type) `(class ,class))
   (setf (slot-value class 'class-eq-specializer)
   ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
   (setf (slot-value class 'type) `(class ,class))
   (setf (slot-value class 'class-eq-specializer)

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

 
 

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

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

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

   (map-dependents class
   (map-dependents class

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

 
 (defmethod shared-initialize :after ((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))
   (let ((classoid (find-classoid (class-name class))))
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (class-name class))))

-    (with-slots (wrapper class-precedence-list prototype predicate-name
-                        (direct-supers direct-superclasses))
-       class
+    (with-slots (wrapper class-precedence-list cpl-available-p
+                         prototype predicate-name
+                         (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))
       (setq class-precedence-list (compute-class-precedence-list class))
       (setf (slot-value class 'finalized-p) t)
       (setf (classoid-pcl-class classoid) class)
       (setq direct-supers direct-superclasses)
       (setq wrapper (classoid-layout classoid))
       (setq class-precedence-list (compute-class-precedence-list class))

-      (setq prototype (make-condition (class-name class)))
+      (setq cpl-available-p t)

       (add-direct-subclasses class direct-superclasses)
       (setq predicate-name (make-class-predicate-name (class-name class)))
       (make-class-predicate class predicate-name)
       (add-direct-subclasses class direct-superclasses)
       (setq predicate-name (make-class-predicate-name (class-name class)))
       (make-class-predicate class predicate-name)

@@ -598,12 +544,12 @@
   (update-pv-table-cache-info class))
 
 (defmethod direct-slot-definition-class ((class condition-class)
   (update-pv-table-cache-info 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))
 

@@ -615,30 +561,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)))

@@ -653,8 +599,8 @@
     (error "Structure slots must have :INSTANCE allocation.")))
 
 (defun make-structure-class-defstruct-form (name direct-slots include)
     (error "Structure slots must have :INSTANCE allocation.")))
 
 (defun make-structure-class-defstruct-form (name direct-slots include)

-  (let* ((conc-name (intern (format nil "~S structure class " name)))
-         (constructor (intern (format nil "~Aconstructor" conc-name)))
+  (let* ((conc-name (format-symbol *package* "~S structure class " name))
+         (constructor (format-symbol *package* "~Aconstructor" conc-name))

          (defstruct `(defstruct (,name
                                  ,@(when include
                                          `((:include ,(class-name include))))
          (defstruct `(defstruct (,name
                                  ,@(when include
                                          `((:include ,(class-name include))))

@@ -668,13 +614,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)

@@ -704,71 +650,64 @@
 (defun make-defstruct-allocation-function (class)
   (let ((dd (get-structure-dd (class-name class))))
     (lambda ()
 (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))))
+      (sb-kernel::%make-instance-with-layout
+       (sb-kernel::compiler-layout-or-lose (dd-name dd))))))

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

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

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

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

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

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

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

-       (setf (slot-value class 'direct-slots)
-             (setq direct-slots
-                   (mapcar (lambda (pl)
-                             (when defstruct-p
-                               (let* ((slot-name (getf pl :name))
-                                      (acc-name
-                                       (format nil
-                                               "~S structure class ~A"
-                                               name slot-name))
-                                      (accessor (intern acc-name)))
-                                 (setq pl (list* :defstruct-accessor-symbol
-                                                 accessor pl))))
-                             (make-direct-slotd class pl))
-                           direct-slots)))
-       (setq direct-slots (slot-value class 'direct-slots)))
+        (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 (gboundp writer-name)
+                                     (gdefinition writer-name))))
+                      (setf (slot-value dslotd 'internal-reader-function)
+                            reader)
+                      (setf (slot-value dslotd 'internal-writer-function)
+                            writer)))
+                  direct-slots reader-names writer-names)
+            (setf (slot-value class 'defstruct-form) defstruct-form)
+            (setf (slot-value class 'defstruct-constructor) constructor)))
+        (setf (slot-value class 'defstruct-constructor)
+              (make-defstruct-allocation-function class)))

     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)
     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)

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

     (setf (slot-value class 'slots) (compute-slots class))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
     (setf (slot-value class 'slots) (compute-slots class))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)

@@ -776,10 +715,10 @@
     (setf (slot-value class 'finalized-p) t)
     (update-pv-table-cache-info class)
     (setq predicate-name (if predicate-name-p
     (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)
+                           (setf (slot-value class 'predicate-name)

                                    (car predicate-name))
                                    (car predicate-name))

-                          (or (slot-value class 'predicate-name)
-                              (setf (slot-value class '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)
                                        (make-class-predicate-name
                                         (class-name class))))))
     (make-class-predicate class predicate-name)

@@ -800,32 +739,38 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)

-          (let* ((ll (case r/w (r '(object)) (w '(new-value object))))
-                 (gf (if (fboundp gfspec)
-                         (ensure-generic-function gfspec)
-                         (ensure-generic-function gfspec :lambda-list ll))))
-            (case r/w
-              (r (if (eq add/remove 'add)
-                     (add-reader-method class gf name)
-                     (remove-reader-method class gf)))
-              (w (if (eq add/remove 'add)
-                     (add-writer-method class gf name)
-                     (remove-writer-method class gf)))))))
+           (let ((gf (cond ((eq add/remove 'add)
+                            (if (fboundp gfspec)
+                                (without-package-locks
+                                  (ensure-generic-function gfspec))
+                                (ensure-generic-function
+                                 gfspec :lambda-list (case r/w
+                                                       (r '(object))
+                                                       (w '(new-value object))))))
+                           ((generic-function-p (and (fboundp gfspec)
+                                                     (fdefinition gfspec)))
+                            (without-package-locks
+                              (ensure-generic-function gfspec))))))
+             (when gf
+               (case r/w
+                 (r (if (eq add/remove 'add)
+                        (add-reader-method class gf name)
+                        (remove-reader-method class gf)))
+                 (w (if (eq add/remove 'add)
+                        (add-writer-method class gf name)
+                        (remove-writer-method class gf))))))))

     (dolist (dslotd dslotds)
       (let ((slot-name (slot-definition-name dslotd)))
     (dolist (dslotd dslotds)
       (let ((slot-name (slot-definition-name dslotd)))

-       (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
-       (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
+        (dolist (r (slot-definition-readers dslotd))
+          (fix r slot-name 'r))
+        (dolist (w (slot-definition-writers dslotd))
+          (fix w slot-name 'w))))))

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

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

 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
 
 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
 

@@ -843,7 +788,7 @@
 (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.
 
 ;;; This is called by :after shared-initialize whenever a class is initialized
 ;;; or reinitialized. The class may or may not be finalized.

@@ -853,47 +798,74 @@
   ;; Note that we can't simply delay the finalization when CLASS has
   ;; no forward referenced superclasses because that causes bootstrap
   ;; problems.
   ;; Note that we can't simply delay the finalization when CLASS has
   ;; no forward referenced superclasses because that causes bootstrap
   ;; problems.

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

   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr cpl))
   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr cpl))

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

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

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

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

-       (update-lisp-class-layout class nwrapper)
-       (setf slots eslotds
-             (wrapper-instance-slots-layout nwrapper) nlayout
-             (wrapper-class-slots nwrapper) nwrapper-class-slots
-             (wrapper-no-of-instance-slots nwrapper) nslots
-             wrapper nwrapper))
+        (update-lisp-class-layout class nwrapper)
+        (setf slots eslotds
+              (wrapper-instance-slots-layout nwrapper) nlayout
+              (wrapper-class-slots nwrapper) nwrapper-class-slots
+              (wrapper-no-of-instance-slots nwrapper) nslots
+              wrapper nwrapper))

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

-       (update-pv-table-cache-info class)
-       (maybe-update-standard-class-locations class)))))
+        (update-pv-table-cache-info class)
+        (maybe-update-standard-class-locations class)))))

 
 (defun compute-class-slots (eslotds)
   (let (collect)
 
 (defun compute-class-slots (eslotds)
   (let (collect)

@@ -960,27 +932,27 @@
 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)

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

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

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

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

@@ -990,47 +962,75 @@
   (find-class 'standard-direct-slot-definition))
 
 (defun make-direct-slotd (class initargs)
   (find-class 'standard-direct-slot-definition))
 
 (defun make-direct-slotd (class initargs)

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

 (defmethod compute-slots ((class std-class))
   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
   ;; for each different slot name we find in our superclasses. Each
   ;; call receives the class and a list of the dslotds with that name.
   ;; The list is in most-specific-first order.
   (let ((name-dslotds-alist ()))
 (defmethod compute-slots ((class std-class))
   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
   ;; for each different slot name we find in our superclasses. Each
   ;; call receives the class and a list of the dslotds with that name.
   ;; The list is in most-specific-first order.
   (let ((name-dslotds-alist ()))

-    (dolist (c (class-precedence-list class))
+    (dolist (c (reverse (class-precedence-list class)))

       (dolist (slot (class-direct-slots c))
       (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)
-                                                (nreverse (cdr direct))))
-           name-dslotds-alist)))
+              (compute-effective-slot-definition class
+                                                 (car direct)
+                                                 (cdr direct)))
+            (nreverse name-dslotds-alist))))

 
 (defmethod compute-slots ((class standard-class))
   (call-next-method))
 
 (defmethod compute-slots :around ((class standard-class))
   (let ((eslotds (call-next-method))
 
 (defmethod compute-slots ((class standard-class))
   (call-next-method))
 
 (defmethod compute-slots :around ((class standard-class))
   (let ((eslotds (call-next-method))

-       (location -1))
+        (location -1))

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

-           (ecase (slot-definition-allocation eslotd)
-             (:instance
-              (incf location))
-             (:class
-              (let* ((name (slot-definition-name eslotd))
-                     (from-class (slot-definition-allocation-class eslotd))
-                     (cell (assq name (class-slot-cells from-class))))
-                (aver (consp cell))
-                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))
+                                (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)))))
+      (unless (slot-definition-class eslotd)
+        (setf (slot-definition-class eslotd) class))

       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))
       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))

@@ -1038,58 +1038,58 @@
 
 (defmethod compute-slots :around ((class funcallable-standard-class))
   (labels ((instance-slot-names (slotds)
 
 (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
+             (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.
            ;; 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)))))))))
+           (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))
     (let ((all-slotds (call-next-method))

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

       (dolist (slotd all-slotds)
       (dolist (slotd all-slotds)

-       (ecase (slot-definition-allocation slotd)
-         (:instance (push slotd instance-slots))
-         (:class (push slotd class-slots))))
+        (case (slot-definition-allocation slotd)
+          (:instance (push slotd instance-slots))
+          (:class (push slotd class-slots))))

       (let ((layout (compute-layout instance-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 instance-slots)
+          (setf (slot-definition-location slotd)
+                (position (slot-definition-name slotd) layout))
+          (initialize-internal-slot-functions slotd)))

       (dolist (slotd class-slots)
       (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)))
+        (let ((name (slot-definition-name slotd))
+              (from-class (slot-definition-allocation-class slotd)))
+          (setf (slot-definition-location slotd)
+                (assoc name (class-slot-cells from-class)))
+          (aver (consp (slot-definition-location slotd)))
+          (initialize-internal-slot-functions slotd)))

       all-slotds)))
 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
       all-slotds)))
 
 (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)))

@@ -1099,7 +1099,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)

@@ -1113,54 +1113,54 @@
 (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)
+         (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 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)))))))

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

 
 (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

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

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

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

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

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

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

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

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

@@ -1209,7 +1209,7 @@
 
 (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)
     (when method (remove-method generic-function method))))
 
 (defmethod remove-boundp-method ((class slot-class) generic-function)

@@ -1241,14 +1241,13 @@
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))
 

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

 \f
 ;;; 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

@@ -1277,21 +1276,28 @@
     ;; 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))
+              ;; KLUDGE: despite the observations above, this remains
+              ;; a violation of locality or what might be considered
+              ;; good style.  There has to be a better way!  -- CSR,
+              ;; 2002-10-29
+              (eq (layout-invalid owrapper) t))

       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)

-                                   class)))
-       (setf (wrapper-instance-slots-layout nwrapper)
-             (wrapper-instance-slots-layout owrapper))
-       (setf (wrapper-class-slots nwrapper)
-             (wrapper-class-slots owrapper))
-       (with-pcl-lock
-         (update-lisp-class-layout class nwrapper)
-         (setf (slot-value class 'wrapper) nwrapper)
-         (invalidate-wrapper owrapper :flush nwrapper))))))
+                                    class)))
+        (setf (wrapper-instance-slots-layout nwrapper)
+              (wrapper-instance-slots-layout owrapper))
+        (setf (wrapper-class-slots nwrapper)
+              (wrapper-class-slots owrapper))
+        (with-pcl-lock
+          (update-lisp-class-layout class nwrapper)
+          (setf (slot-value class 'wrapper) nwrapper)
+          ;; Use :OBSOLETE instead of :FLUSH if any superclass has
+          ;; been obsoleted.
+          (if (find-if (lambda (x)
+                         (and (consp x) (eq :obsolete (car x))))
+                       (layout-inherits owrapper)
+                       :key #'layout-invalid)
+              (invalidate-wrapper owrapper :obsolete nwrapper)
+              (invalidate-wrapper owrapper :flush nwrapper)))))))

 
 (defun flush-cache-trap (owrapper nwrapper instance)
   (declare (ignore owrapper))
 
 (defun flush-cache-trap (owrapper nwrapper instance)
   (declare (ignore owrapper))

@@ -1302,20 +1308,22 @@
 ;;; 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)))
+         (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+                                 class)))

       (setf (wrapper-instance-slots-layout nwrapper)
       (setf (wrapper-instance-slots-layout nwrapper)

-           (wrapper-instance-slots-layout owrapper))
+            (wrapper-instance-slots-layout owrapper))

       (setf (wrapper-class-slots nwrapper)
       (setf (wrapper-class-slots nwrapper)

-           (wrapper-class-slots owrapper))
+            (wrapper-class-slots owrapper))

       (with-pcl-lock
       (with-pcl-lock

-       (update-lisp-class-layout class nwrapper)
-       (setf (slot-value class 'wrapper) nwrapper)
-       (invalidate-wrapper owrapper :obsolete nwrapper)
-       class)))
+        (update-lisp-class-layout class nwrapper)
+        (setf (slot-value class 'wrapper) nwrapper)
+        (invalidate-wrapper owrapper :obsolete nwrapper)
+        class)))

 
 (defmethod make-instances-obsolete ((class symbol))
 
 (defmethod make-instances-obsolete ((class symbol))

-  (make-instances-obsolete (find-class class)))
+  (make-instances-obsolete (find-class class))
+  ;; ANSI wants the class name when called with a symbol.
+  class)

 
 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
 ;;; see an obsolete instance. The times when it is called are:
 
 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
 ;;; see an obsolete instance. The times when it is called are:

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

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

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

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

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

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

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

@@ -1395,38 +1413,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

@@ -1437,14 +1455,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,30 +1472,30 @@
     instance))
 
 (defmethod change-class ((instance standard-object)
     instance))
 
 (defmethod change-class ((instance standard-object)

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

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

   (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,18 +1510,22 @@
 ;;;; definitions appear here.
 
 (defmethod shared-initialize :before
 ;;;; definitions appear here.
 
 (defmethod shared-initialize :before

-          ((class built-in-class) slot-names &rest initargs)
+           ((class built-in-class) slot-names &rest initargs)

   (declare (ignore slot-names initargs))
   (error "attempt to initialize or reinitialize a built in class"))
 
   (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-slots       ((class built-in-class)) ())
+(defmethod class-slots             ((class built-in-class)) ())

 (defmethod class-direct-default-initargs ((class built-in-class)) ())
 (defmethod class-direct-default-initargs ((class built-in-class)) ())

-(defmethod class-default-initargs      ((class built-in-class)) ())
+(defmethod class-default-initargs       ((class built-in-class)) ())

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

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

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

@@ -1517,7 +1539,7 @@
   (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)

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

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

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