X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=c3216bae354ca52e557003eeec967c3c5801b673;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=f7ee4f1306db42c4206078a8b843b4686165dca3;hpb=fbde18e9b7d8e67e24f628638be4f293cb128101;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f7ee4f1..c3216ba 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -72,11 +72,7 @@
 (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)
@@ -102,7 +98,7 @@
 (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)
@@ -280,11 +276,11 @@
                                      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))))))
@@ -484,7 +480,7 @@
   (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)))
 
@@ -519,7 +515,7 @@
                                      &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)
@@ -529,7 +525,7 @@
       (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))))
@@ -589,7 +585,7 @@
                       (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)))
@@ -708,7 +704,7 @@
         (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))
@@ -798,6 +794,8 @@
               (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)))
@@ -848,11 +846,11 @@
         ;; 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))
 
@@ -1044,7 +1042,7 @@
                        (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)))