X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=ca020b4e7dcebc05eea290858c48a174e6a838d2;hb=3a618201c9f2370bb8784217a866d000371769e5;hp=50fd53a2f643bbadd133b239276609d4c6e8b248;hpb=7f13323739a0d2b474bfd5c740942db5a78349d6;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 50fd53a..ca020b4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -118,50 +118,6 @@ (defmethod slot-definition-allocation ((slotd structure-slot-definition)) :instance) -(defmethod shared-initialize :after ((object documentation-mixin) - slot-names - &key (documentation nil documentation-p)) - (declare (ignore slot-names)) - (when documentation-p - (setf (plist-value object 'documentation) documentation))) - -;;; default if DOC-TYPE doesn't match one of the specified types -(defmethod documentation (object doc-type) - (warn "unsupported DOCUMENTATION: type ~S for object ~S" - doc-type - (type-of object)) - nil) - -;;; default if DOC-TYPE doesn't match one of the specified types -(defmethod (setf documentation) (new-value object doc-type) - ;; CMU CL made this an error, but since ANSI says that even for supported - ;; doc types an implementation is permitted to discard docs at any time - ;; for any reason, this feels to me more like a warning. -- WHN 19991214 - (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S" - doc-type - (type-of object)) - new-value) - -(defmethod documentation ((object documentation-mixin) doc-type) - (declare (ignore doc-type)) - (plist-value object 'documentation)) - -(defmethod (setf documentation) (new-value - (object documentation-mixin) - doc-type) - (declare (ignore doc-type)) - (setf (plist-value object 'documentation) new-value)) - -(defmethod documentation ((slotd standard-slot-definition) doc-type) - (declare (ignore doc-type)) - (slot-value slotd 'documentation)) - -(defmethod (setf documentation) (new-value - (slotd standard-slot-definition) - doc-type) - (declare (ignore doc-type)) - (setf (slot-value slotd 'documentation) new-value)) - ;;;; various class accessors that are a little more complicated than can be ;;;; done with automatically generated reader methods @@ -475,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 @@ -505,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) @@ -542,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)) @@ -661,7 +620,7 @@ ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot ;; is unbound; maybe it should be a CELL-ERROR of some ;; sort? - (error () (slot-unbound class x slot-name))))) + (error () (values (slot-unbound class x slot-name)))))) (setf (slot-definition-writer-function slotd) (lambda (v x) (condition-writer-function x v slot-name))) @@ -841,7 +800,10 @@ (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) - (let ((gf (ensure-generic-function gfspec))) + (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) @@ -907,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) @@ -1023,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)) @@ -1078,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)) @@ -1339,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)) @@ -1363,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: @@ -1421,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) @@ -1448,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)