sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

clos: finalize-inheritance: don't always change the class-slots identity

Browse source 
Specification of M-I-O explicitly says that instances are not made
when "local slots" are compatible. This change is necessary to prevent
infinite recursion as reported in #568 without breaking the
finalization protocol, because currently class-slots are used as a
signature for its instances (and that's how being obsolete is
determined).
This commit is contained in:
Daniel Kochmański 2020-04-14 11:06:22 +02:00
parent bee9e8db55
commit 5c02111bfc
2 changed files with 27 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
src/clos/change.lsp
View file

@ -215,6 +215,25 @@
class)
(defun slot-definitions-compatible-p (old-slotds new-slotds)
(loop for o = (pop old-slotds)
for n = (pop new-slotds)
while (and o n)
do (let ((old-alloc (slot-definition-allocation o))
(new-alloc (slot-definition-allocation n)))
(unless (and (eq old-alloc new-alloc)
(eq (slot-definition-name o)
(slot-definition-name n))
(or (not (eq old-alloc :instance))
(= (slot-definition-location o)
(slot-definition-location n))))
(return-from slot-definitions-compatible-p nil)))
finally
(return (and (null o)
(null n)
(null old-slotds)
(null new-slotds)))))
(defmethod make-instances-obsolete ((class class))
(setf (class-slots class) (copy-list (class-slots class)))
class)

10
src/clos/standard.lsp
View file

@ -303,8 +303,14 @@ because it contains a reference to the undefined class~% ~A"
(setf (class-precedence-list class) cpl)
(let ((slots (compute-slots class)))
(setf (class-slots class) slots
(class-size class) (compute-instance-size slots)
;; We don't change identity of class-slots when slot definitions
;; are compatible to avoid making instances obsolete. This is
;; allowed by the standard (see MAKE-INSTANCES-OBSOLETE).
(if (and (slot-boundp class 'slots)
(slot-definitions-compatible-p (class-slots class) slots))
(map-into (class-slots class) #'identity slots)
(setf (class-slots class) slots))
(setf (class-size class) (compute-instance-size slots)
(class-default-initargs class) (compute-default-initargs class)
(class-finalized-p class) t))
;;