X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=ca020b4e7dcebc05eea290858c48a174e6a838d2;hb=3a618201c9f2370bb8784217a866d000371769e5;hp=5e0249a7f1a70e443c063d13ff362246d9a5d1d6;hpb=a53deb94a224bc903d00a5075acf562488cab06a;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 5e0249a..ca020b4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -431,7 +431,6 @@ (direct-slots nil direct-slots-p) (direct-default-initargs nil direct-default-initargs-p) (predicate-name nil predicate-name-p)) - (declare (ignore slot-names)) (cond (direct-superclasses-p (setq direct-superclasses (or direct-superclasses @@ -461,18 +460,22 @@ (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) - ;; The below initializes shared slots from direct initforms, - ;; but one might inherit initforms from superclasses - ;; (cf. UPDATE-SHARED-SLOT-VALUES). - (let (collect) + (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (collect '())) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) - (let ((initfunction (slot-definition-initfunction dslotd))) - (push (cons (slot-definition-name dslotd) - (if initfunction - (funcall initfunction) - +slot-unbound+)) - collect)))) + ;; 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 (setf (slot-value class 'predicate-name) @@ -498,7 +501,7 @@ dupes))) (let* ((slot (car slots)) (oslots (remove (slot-definition-name slot) (cdr slots) - :test-not #'string= :key #'slot-definition-name))) + :test #'string/= :key #'slot-definition-name))) (when oslots (pushnew (cons (slot-definition-name slot) (mapcar #'slot-definition-name oslots)) @@ -866,21 +869,11 @@ ;; (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-shared-slot-values 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)))) -(defun update-shared-slot-values (class) - (dolist (slot (class-slots class)) - (when (eq (slot-definition-allocation slot) :class) - (let ((cell (assq (slot-definition-name slot) (class-slot-cells class)))) - (when cell - (let ((initfn (slot-definition-initfunction slot))) - (when initfn - (setf (cdr cell) (funcall initfn))))))))) - (defun update-cpl (class cpl) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) @@ -982,7 +975,7 @@ (update-gf-dfun class gf)) gf-table))))) -(defun update-inits (class inits) +(defun update-initargs (class inits) (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) @@ -1037,7 +1030,13 @@ (from-class (slot-definition-allocation-class eslotd)) (cell (assq name (class-slot-cells from-class)))) (aver (consp cell)) - 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))))) (initialize-internal-slot-functions eslotd)))) (defmethod compute-slots ((class funcallable-standard-class)) @@ -1298,7 +1297,14 @@ (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :flush 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)) @@ -1322,7 +1328,9 @@ class))) (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: @@ -1380,15 +1388,25 @@ (added ()) (discarded ()) (plist ())) - ;; local --> local transfer - ;; local --> shared discard - ;; local --> -- discard - ;; shared --> local transfer - ;; shared --> shared discard - ;; shared --> -- discard - ;; -- --> local add + + ;; 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) @@ -1407,11 +1425,8 @@ (let ((name (car oclass-slot-and-val)) (val (cdr oclass-slot-and-val))) (let ((npos (posq name nlayout))) - (if npos - (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val)) - (progn (push name discarded) - (unless (eq val +slot-unbound+) - (setf (getf plist name) val))))))) + (when npos + (setf (clos-slots-ref nslots npos) val))))) ;; Go through all the new local slots to compute the added slots. (dolist (nlocal nlayout)