0.9.14.12:
[sbcl.git] / src / pcl / std-class.lisp
index f7ee4f1..80f7719 100644 (file)
 (defmethod initialize-internal-slot-functions ((slotd
                                                 effective-slot-definition))
   (let* ((name (slot-value slotd 'name))
-         (class (slot-value slotd 'class)))
-    (let ((table (or (gethash name *name->class->slotd-table*)
-                     (setf (gethash name *name->class->slotd-table*)
-                           (make-hash-table :test 'eq :size 5)))))
-      (setf (gethash class table) slotd))
+         (class (slot-value slotd '%class)))
     (dolist (type '(reader writer boundp))
       (let* ((gf-name (ecase type
                               (reader 'slot-value-using-class)
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
                                        type gf)
   (let* ((name (slot-value slotd 'name))
-         (class (slot-value slotd 'class))
+         (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)
                                      slot-names
                                      &key)
   (declare (ignore slot-names))
-  (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
+  (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl))))
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))
-  (setf (slot-value specl 'type)
+  (setf (slot-value specl '%type)
         `(eql ,(specializer-object specl)))
   (setf (info :type :translator specl)
         (constantly (make-member-type :members (list (specializer-object specl))))))
   (declare (ignore slot-names name))
   ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
   ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
-  (setf (slot-value class 'type) `(class ,class))
+  (setf (slot-value class '%type) `(class ,class))
   (setf (slot-value class 'class-eq-specializer)
         (make-instance 'class-eq-specializer :class class)))
 
                                      &key direct-slots direct-superclasses)
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (class-name class))))
-    (with-slots (wrapper class-precedence-list cpl-available-p
+    (with-slots (wrapper %class-precedence-list cpl-available-p
                          prototype (direct-supers direct-superclasses))
         class
       (setf (slot-value class 'direct-slots)
       (setf (classoid-pcl-class classoid) class)
       (setq direct-supers direct-superclasses)
       (setq wrapper (classoid-layout classoid))
-      (setq class-precedence-list (compute-class-precedence-list class))
+      (setq %class-precedence-list (compute-class-precedence-list class))
       (setq cpl-available-p t)
       (add-direct-subclasses class direct-superclasses)
       (setf (slot-value class 'slots) (compute-slots class))))
                       (compute-effective-slot-definition
                        class (slot-definition-name dslotd) (list dslotd)))
                     (class-direct-slots superclass)))
-          (reverse (slot-value class 'class-precedence-list))))
+          (reverse (slot-value class '%class-precedence-list))))
 
 (defmethod compute-slots :around ((class condition-class))
   (let ((eslotds (call-next-method)))
         (setf (slot-value class 'defstruct-constructor)
               (make-defstruct-allocation-function class)))
     (add-direct-subclasses class direct-superclasses)
-    (setf (slot-value class 'class-precedence-list)
+    (setf (slot-value class '%class-precedence-list)
           (compute-class-precedence-list class))
     (setf (slot-value class 'cpl-available-p) t)
     (setf (slot-value class 'slots) (compute-slots class))
               (not (class-finalized-p class))
               (not (class-has-a-forward-referenced-superclass-p class)))
      (finalize-inheritance class)
+     (dolist (sub (class-direct-subclasses class))
+       (update-class sub nil))
      (return-from update-class))
    (when (or finalizep (class-finalized-p class)
              (not (class-has-a-forward-referenced-superclass-p class)))
         ;; 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 '%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 '%class-precedence-list) cpl)
         (setf (slot-value class 'cpl-available-p) t)))
   (update-class-can-precede-p cpl))
 
 
 (defun compute-class-slots (eslotds)
   (let (collect)
-    (dolist (eslotd eslotds)
-      (push (assoc (slot-definition-name eslotd)
-                   (class-slot-cells (slot-definition-class eslotd)))
-            collect))
-    (nreverse collect)))
+    (dolist (eslotd eslotds (nreverse collect))
+      (let ((cell (assoc (slot-definition-name eslotd)
+                         (class-slot-cells
+                          (slot-definition-allocation-class eslotd)))))
+        (aver cell)
+        (push cell collect)))))
 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
                        (slot-definition-name dslotd)
                        (list dslotd)))
                     (class-direct-slots superclass)))
-          (reverse (slot-value class 'class-precedence-list))))
+          (reverse (slot-value class '%class-precedence-list))))
 
 (defmethod compute-slots :around ((class structure-class))
   (let ((eslotds (call-next-method)))
         ;;  --    --> 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)