Merge branch 'fix-568' into 'develop'

Fix 568

Closes #568

See merge request embeddable-common-lisp/ecl!193

src/clos/print.lsp

@@ -193,7 +193,7 @@ printer and we should rather use MAKE-LOAD-FORM."
   instance)
 
 (defmethod print-object ((instance standard-object) stream)
-  (print-unreadable-object (instance stream)
+  (print-unreadable-object (instance stream :identity t)
     (let ((*package* (find-package "CL")))
       (format stream "a ~S"
               (class-name (si:instance-class instance)))))

src/clos/standard.lsp

@@ -292,10 +292,14 @@ because it contains a reference to the undefined class~%  ~A"
     ;; which is not yet finalized and rely on the fact that this
     ;; class will also try to finalize all of its children.
     ;;
-    (let ((x (find-if-not #'class-finalized-p cpl :from-end t)))
-      (unless (or (null x) (eq x class))
-        (return-from finalize-inheritance
-          (finalize-inheritance x))))
+    (when-let ((x (find-if-not #'class-finalized-p (rest cpl) :from-end t)))
+      (return-from finalize-inheritance
+        (finalize-inheritance x)))
+
+    ;; Don't try to finalize a class that is already finalized.
+    (when (class-finalized-p class)
+      (return-from finalize-inheritance))
+
     (setf (class-precedence-list class) cpl)
     (let ((slots (compute-slots class)))
       (setf (class-slots class) slots
@@ -352,13 +356,15 @@ because it contains a reference to the undefined class~%  ~A"
   ;; 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.
-  (dolist (subclass (reverse (class-direct-subclasses class)))
-    (finalize-unless-forward subclass))
+  (let ((subclasses (reverse (class-direct-subclasses class))))
+    (dolist (subclass subclasses)
+      (setf (class-finalized-p subclass) nil))
+    (dolist (subclass subclasses)
+      (finalize-unless-forward subclass)))
   ;;
   ;; We create various caches to more rapidly find the slot locations and
   ;; slot definitions.
-  (std-create-slots-table class)
-  )
+  (std-create-slots-table class))
 
 (defmethod finalize-inheritance ((class std-class))
   (call-next-method)

src/tests/normal-tests/compiler.lsp

@@ -692,7 +692,9 @@
     (load file)
     (delete-file "make-load-form.lsp")
     (delete-file file))
-  (is-equal "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS> #1#)" (foo.0030))
+  (let ((str (foo.0030)))
+    (is (and (search "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS" str)
+             (search "> #1#)" str))))
   (is (eq (compiler-test-parent a.0030) b.0030))
   (is (eq (first (compiler-test-children b.0030)) a.0030)))
 

src/tests/normal-tests/metaobject-protocol.lsp

@@ -664,3 +664,15 @@ the metaclass")
     (signals error (make-instance 'foo1))
     (finishes (defclass foo2 () ()))
     (finishes (make-instance 'foo1))))
+
+;;; Date 2020-04-05
+;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/568
+;;; Fixed: 557541f3
+;;; Description
+;;;
+;;;     Finalizing inheritance of a standard-effective-slot-definition
+;;;     lead to the infinite recursion by making all its instances
+;;;     obsolete (including its own slots!).
+(test mop.0025.xxx
+  (clos:finalize-inheritance
+   (find-class 'clos:standard-effective-slot-definition)))