-
- ;; Go through all the old local slots.
- (let ((opos 0))
- (dolist (name olayout)
- (let ((npos (posq name nlayout)))
- (if npos
- (setf (clos-slots-ref nslots npos)
- (clos-slots-ref oslots opos))
- (progn
- (push name discarded)
- (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (clos-slots-ref oslots opos))))))
- (incf opos)))
-
- ;; Go through all the old shared slots.
- (dolist (oclass-slot-and-val oclass-slots)
- (let ((name (car oclass-slot-and-val))
- (val (cdr oclass-slot-and-val)))
- (let ((npos (posq name nlayout)))
- (when npos
- (setf (clos-slots-ref nslots npos) val)))))
-
- ;; Go through all the new local slots to compute the added slots.
- (dolist (nlocal nlayout)
- (unless (or (memq nlocal olayout)
- (assq nlocal oclass-slots))
- (push nlocal added)))
+ ;; -- --> custom XXX
+
+ (multiple-value-bind (new-instance-slots new-class-slots new-custom-slots)
+ (classify-slotds (wrapper-slots nwrapper))
+ (declare (ignore new-class-slots))
+ (multiple-value-bind (old-instance-slots old-class-slots old-custom-slots)
+ (classify-slotds (wrapper-slots owrapper))
+
+ (let ((layout (mapcar (lambda (slotd)
+ ;; Get the names only once.
+ (cons (slot-definition-name slotd) slotd))
+ new-instance-slots)))
+
+ (flet ((set-value (value cell)
+ (let ((name (car cell))
+ (slotd (cdr cell)))
+ (when (and safe (neq value +slot-unbound+))
+ (let ((type (slot-definition-type slotd)))
+ (assert
+ (typep value type) (value)
+ "~@<Error updating obsolete instance. Current value in slot ~
+ ~S of an instance of ~S is ~S, which does not match the new ~
+ slot type ~S.~:@>"
+ name class value type)))
+ (setf (clos-slots-ref nslots (slot-definition-location slotd)) value
+ ;; Prune from the list now that it's been dealt with.
+ layout (remove cell layout)))))
+
+ ;; Go through all the old local slots.
+ (dolist (old old-instance-slots)
+ (let* ((name (slot-definition-name old))
+ (value (clos-slots-ref oslots (slot-definition-location old))))
+ (unless (eq value +slot-unbound+)
+ (let ((new (assq name layout)))
+ (cond (new
+ (set-value value new))
+ (t
+ (push name discarded)
+ (setf (getf plist name) value)))))))
+
+ ;; Go through all the old shared slots.
+ (dolist (old old-class-slots)
+ (let* ((cell (slot-definition-location old))
+ (name (car cell))
+ (new (assq name layout)))
+ (when new
+ (set-value (cdr cell) new))))
+
+ ;; Go through all custom slots to find added ones. CLHS
+ ;; doesn't specify what to do about them, and neither does
+ ;; AMOP. We do want them to get initialized, though, so we
+ ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
+ (dolist (new new-custom-slots)
+ (let* ((name (slot-definition-name new))
+ (old (find name old-custom-slots :key #'slot-definition-name)))
+ (unless old
+ (push name added))))
+
+ ;; Go through all the remaining new local slots to compute the added slots.
+ (dolist (cell layout)
+ (push (car cell) added))))))