+;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
+;;;
+;;; In addition to slot locations (implicit in the ordering of the slots), we
+;;; must check classes: SLOT-INFO structures from old slotds may have been
+;;; cached in permutation vectors, but new slotds have had new ones allocated
+;;; to them. This is non-problematic for standard slotds, because we know the
+;;; structure is compatible, but if a slot definition class changes, this can
+;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
+;;;
+;;; Also, if the slot has a non-standard allocation, we need to check that it
+;;; doesn't change.
+(defun slot-layouts-compatible-p
+ (oslotds new-instance-slotds new-class-slotds new-custom-slotds)
+ (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds)
+ (classify-slotds oslotds)
+ (and
+ ;; Instance slots: name, type, and class.
+ (dolist (o old-instance-slotds (not new-instance-slotds))
+ (let ((n (pop new-instance-slotds)))
+ (unless (and n
+ (eq (slot-definition-name o) (slot-definition-name n))
+ (eq (slot-definition-type o) (slot-definition-type n))
+ (eq (class-of o) (class-of n)))
+ (return nil))))
+ ;; Class slots: name and class. (FIXME: class slots not typechecked?)
+ (dolist (o old-class-slotds (not new-class-slotds))
+ (let ((n (pop new-class-slotds)))
+ (unless (and n
+ (eq (slot-definition-name o) (slot-definition-name n))
+ (eq (class-of n) (class-of o)))
+ (return nil))))
+ ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
+ (dolist (o old-custom-slotds (not new-custom-slotds))
+ (let ((n (pop new-custom-slotds)))
+ (unless (and n
+ (eq (slot-definition-name o) (slot-definition-name n))
+ (eq (slot-definition-type o) (slot-definition-type n))
+ (eq (slot-definition-allocation o) (slot-definition-allocation n))
+ (eq (class-of o) (class-of n)))
+ (return nil)))))))
+
+(defun %update-slots (class eslotds)
+ (multiple-value-bind (instance-slots class-slots custom-slots)
+ (classify-slotds eslotds)
+ (let* ((nslots (length instance-slots))
+ (owrapper (when (class-finalized-p class) (class-wrapper class)))
+ (nwrapper
+ (cond ((null owrapper)
+ (make-wrapper nslots class))
+ ((slot-layouts-compatible-p (wrapper-slots owrapper)
+ instance-slots class-slots custom-slots)
+ owrapper)
+ (t
+ ;; This will initialize the new wrapper to have the
+ ;; same state as the old wrapper. We will then have
+ ;; to change that. This may seem like wasted work
+ ;; (and it is), but the spec requires that we call
+ ;; MAKE-INSTANCES-OBSOLETE.
+ (make-instances-obsolete class)
+ (class-wrapper class)))))
+ (%update-lisp-class-layout class nwrapper)
+ (setf (slot-value class 'slots) eslotds
+ (wrapper-slots nwrapper) eslotds
+ (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
+ (wrapper-length nwrapper) nslots
+ (slot-value class 'wrapper) nwrapper)
+ (do* ((slots (slot-value class 'slots) (cdr slots))
+ (dupes nil))
+ ((null slots)
+ (when dupes
+ (style-warn
+ "~@<slot names with the same SYMBOL-NAME but ~
+ different SYMBOL-PACKAGE (possible package problem) ~
+ for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
+ class dupes)))
+ (let* ((slot (car slots))
+ (oslots (remove (slot-definition-name slot) (cdr slots)
+ :test #'string/=
+ :key #'slot-definition-name)))
+ (when oslots
+ (pushnew (cons (slot-definition-name slot)
+ (mapcar #'slot-definition-name oslots))
+ dupes
+ :test #'string= :key #'car))))
+ (setf (slot-value class 'finalized-p) t)