mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-13 00:10:35 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-572' into 'develop'

Browse source 
Fix 572

Closes #572

See merge request embeddable-common-lisp/ecl!196
This commit is contained in:
Marius Gerbershagen 2020-04-12 08:29:55 +00:00
commit 3e4c253a7d
2 changed files with 50 additions and 26 deletions
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.

23
src/tests/normal-tests/metaobject-protocol.lsp
View file

@ -695,3 +695,26 @@ the metaclass")
(defgeneric bar (arg1 &key arg2))
(finishes (defmethod bar ((arg1 string) &key arg3 &allow-other-keys)))
(signals error (defmethod bar ((arg1 integer) &key arg3)))))
;;; Date 2020-04-10
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/572
;;; Fixed: 6ea255fe
;;; Description
;;;
;;; Fix in 557541f3 (see the test mop.0025.xxx) introduced a
;;; regression for custom compute-class-precedence-list methods.
;;; This issue is triggered only by a non-conforming code which
;;; defines the method which returns a sequence which first
;;; element *is not* the class passes as the argument. See:
;;;
;;; http://metamodular.com/CLOS-MOP/compute-class-precedence-list.html
(ext:with-clean-symbols (meta hack test-class)
(test mop.0027.finalize-inheritance
(finishes
(progn (defclass meta (standard-class) ())
(defclass hack () ())
(defmethod clos:validate-superclass ((class meta) (super standard-class)) t)
(defmethod clos:validate-superclass ((class standard-class) (super meta)) t)
(defmethod clos:compute-class-precedence-list ((class meta))
(cons (find-class 'hack) (call-next-method)))
(defclass test-class () () (:metaclass meta))))))