diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index be80e443d..c9caa682c 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -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. diff --git a/src/tests/normal-tests/metaobject-protocol.lsp b/src/tests/normal-tests/metaobject-protocol.lsp index 0d9980b2b..e04320081 100644 --- a/src/tests/normal-tests/metaobject-protocol.lsp +++ b/src/tests/normal-tests/metaobject-protocol.lsp @@ -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))))))