(defmethod slot-definition-allocation ((slotd structure-slot-definition))
:instance)
\f
-(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))
-\f
;;;; various class accessors that are a little more complicated than can be
;;;; done with automatically generated reader methods
(setf (gdefinition 'load-defclass) #'real-load-defclass)
-(defun ensure-class (name &rest all)
- (apply #'ensure-class-using-class (find-class name nil) name all))
+(defun ensure-class (name &rest args)
+ (apply #'ensure-class-using-class
+ (let ((class (find-class name nil)))
+ (when (and class (eq name (class-name class)))
+ ;; NAME is the proper name of CLASS, so redefine it
+ class))
+ name
+ args))
(defmethod ensure-class-using-class ((class null) name &rest args &key)
(multiple-value-bind (meta initargs)
(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
(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)
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))
;; 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)))
(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)
;; (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)
(update-gf-dfun class gf))
gf-table)))))
-(defun update-inits (class inits)
+(defun update-initargs (class inits)
(setf (plist-value class 'default-initargs) inits))
\f
(defmethod compute-default-initargs ((class slot-class))
(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))
(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))
(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)
(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)
projects / sbcl.git / blobdiff