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

finalize-inheritance: guard against treating class as its own parent

Browse source 
Fix 49b244db78 assumed, that the class
itself is first in the CPL list, and this assumption while correct in
light of MOP specification may be broken by a non-conforming code.

Bringing back the check whether (eq x class) when we try to finalize
the "top-most class which is not yet finalized" does not break
conforming code whiel still enabling slihgtly broken code to work.

Fixes #572.
This commit is contained in:
Daniel Kochmański 2020-04-10 20:23:12 +02:00
parent abe2a2811f
commit 322eaddfa2
1 changed files with 27 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
src/clos/standard.lsp
View file

@ -282,19 +282,19 @@ argument was supplied for metaclass ~S." (class-of class))))))))
;; a not yet defined class or it has not yet been finalized.
;; In the first case we can just signal an error...
;;
(let ((x (find-if #'forward-referenced-class-p (rest cpl))))
(when x
(error "Cannot finish building the class~% ~A~%~
(when-let ((x (find-if #'forward-referenced-class-p (rest cpl))))
(error "Cannot finish building the class~% ~A~%~
because it contains a reference to the undefined class~% ~A"
(class-name class) (class-name x))))
(class-name class) (class-name x)))
;;
;; ... and in the second case we just finalize the top-most class
;; which is not yet finalized and rely on the fact that this
;; class will also try to finalize all of its children.
;;
(when-let ((x (find-if-not #'class-finalized-p (rest cpl) :from-end t)))
(return-from finalize-inheritance
(finalize-inheritance x)))
(when-let ((x (find-if-not #'class-finalized-p cpl :from-end t)))
(unless (eq x class)
(return-from finalize-inheritance
(finalize-inheritance x))))
;; Don't try to finalize a class that is already finalized.
(when (class-finalized-p class)
@ -311,48 +311,49 @@ because it contains a reference to the undefined class~% ~A"
;; their locations. This may imply adding _new_ direct slots.
;;
(when (class-sealedp class)
(let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class))))
(let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name
(class-slots class))))
(all-slots (class-slots class)))
;;
;; We first search all slots that belonged to unsealed classes and which
;; therefore have no fixed position.
;;
(loop for c in cpl
do (loop for slotd in (class-direct-slots c)
when (safe-slot-definition-location slotd)
do (setf free-slots (delete (slot-definition-name slotd) free-slots))))
do (loop for slotd in (class-direct-slots c)
when (safe-slot-definition-location slotd)
do (setf free-slots (delete (slot-definition-name slotd)
free-slots))))
;;
;; We now copy the locations of the effective slots in this class to
;; the class direct slots.
;;
(loop for slotd in (class-direct-slots class)
do (let* ((name (slot-definition-name slotd))
(other-slotd (find name all-slots :key #'slot-definition-name)))
(setf (slot-definition-location slotd)
(slot-definition-location other-slotd)
free-slots (delete name free-slots))))
do (let* ((name (slot-definition-name slotd))
(other-slotd (find name all-slots :key #'slot-definition-name)))
(setf (slot-definition-location slotd)
(slot-definition-location other-slotd)
free-slots (delete name free-slots))))
;;
;; And finally we add one direct slot for each inherited slot that did
;; not have a fixed location.
;;
(loop for name in free-slots
with direct-slots = (class-direct-slots class)
do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
(def (direct-slot-to-canonical-slot effective-slotd)))
(push (apply #'make-instance (direct-slot-definition-class class def)
def)
direct-slots))
finally (setf (class-direct-slots class) direct-slots))))
with direct-slots = (class-direct-slots class)
do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
(def (direct-slot-to-canonical-slot effective-slotd)))
(push (apply #'make-instance (direct-slot-definition-class class def)
def)
direct-slots))
finally (setf (class-direct-slots class) direct-slots))))
;;
;; This is not really needed, because when we modify the list of slots
;; all instances automatically become obsolete (See change.lsp)
;(make-instances-obsolete class)
#+ (or) (make-instances-obsolete class)
;;
;; But this is really needed: we have to clear the different type caches
;; for type comparisons and so on.
;;
(si::subtypep-clear-cache)
)
(si::subtypep-clear-cache))
;; As mentioned above, when a parent is finalized, it is responsible for
;; invoking FINALIZE-INHERITANCE on all of its children. Obviously,
;; this only makes sense when the class has been defined.