X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=80f77195a94ca82f0fcd3f098ac0a2d11b470f6c;hb=a7e7d0b213aa1133cc419421d611e7e2ad36808c;hp=f7ee4f1306db42c4206078a8b843b4686165dca3;hpb=fbde18e9b7d8e67e24f628638be4f293cb128101;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f7ee4f1..80f7719 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)) @@ -919,11 +917,12 @@ (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) @@ -1044,7 +1043,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))) @@ -1358,15 +1357,6 @@ ;; -- --> 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)