For LP 1418883

0001-ENSURE-CLASS-signals-an-error-on-cyclic-super-meta-c.patch

From cf4e1479b099e266f672280e2d90c52709472e0c Mon Sep 17 00:00:00 2001
From: Jan Moringen <[email protected]>
Date: Sun, 8 Feb 2015 12:54:41 +0100
Subject: [PATCH 1/2] ENSURE-CLASS signals an error on cyclic {super,meta}class
 relations

Partially based on patch by Lucien Pullen <[email protected]>.

Fixes lp#1418883
---
 NEWS                   |   2 +
 src/pcl/std-class.lisp | 114 ++++++++++++++++++++++++++++---------------------
 tests/clos.impure.lisp |  21 +++++++++
 3 files changed, 89 insertions(+), 48 deletions(-)

diff --git a/NEWS b/NEWS
index bdd431b..a0a339f 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-1.2.8:
     SB-INTROSPECT:FUNCTION-TYPE might notice that (MEMBER T NIL)
     and (MEMBER NIL T) are both internally collapsed to the former,
     so that the latter can never be obtained as part of an FTYPE.
+  * bug fix: DEFCLASS handles cyclic {super,meta}class relations better
+    (lp#1418883)
   * bug fix: compiler no longer signals an error when compiling certain nested
     local calls. (lp#1416704, lp#404441, lp#1417822)
   * bug fix: more robust debugger and backtraces. (lp#1413850, lp#1099500,
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 1b637bf..f54df78 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -364,58 +364,76 @@
              (when (and class (eq name (class-name class)))
                ;; NAME is the proper name of CLASS, so redefine it
                class))
-           name
-           args)))
+           name args)))
+
+(defun parse-ensure-class-args (class name args)
+  (let ((metaclass *the-class-standard-class*)
+        (metaclassp nil)
+        (reversed-plist '()))
+    (labels ((find-class* (which class-or-name)
+               (cond
+                 ((classp class-or-name)
+                  (cond
+                    ((eq class-or-name class)
+                     (error "~@<Class ~A specified as its own ~
+                             ~(~A~)class.~@:>"
+                            class-or-name which))
+                    (t
+                     class-or-name)))
+                 ((and class-or-name (legal-class-name-p class-or-name))
+                  (cond
+                    ((eq class-or-name name)
+                     (error "~@<Class named ~
+                             ~/sb-impl::print-symbol-with-prefix/ ~
+                             specified as its own ~(~A~)class.~@:>"
+                            class-or-name which))
+                    ((find-class class-or-name (eq which :meta)))
+                    ((ensure-class
+                      class-or-name :metaclass 'forward-referenced-class))))
+                 (t
+                  (error "~@<Not a class or a legal ~(~A~)class name: ~
+                          ~S.~@:>"
+                         which class-or-name))))
+             (find-superclass (class-or-name)
+               (find-class* :super class-or-name)))
+      (doplist (key value) args
+        (case key
+          (:metaclass
+           (unless metaclassp
+             (setf metaclass (find-class* :meta value)
+                   metaclassp key)))
+          (:direct-superclasses
+           (let ((superclasses (mapcar #'find-superclass value)))
+             (setf reversed-plist (list* superclasses key reversed-plist))))
+          (t
+           (setf reversed-plist (list* value key reversed-plist)))))
+      (values metaclass (nreverse reversed-plist)))))
+
+(defun call-with-ensure-class-context (class name args thunk)
+  (let ((class (with-world-lock ()
+                 (multiple-value-bind (metaclass initargs)
+                     (parse-ensure-class-args class name args)
+                   (let ((class (funcall thunk class name metaclass initargs)))
+                     (without-package-locks
+                       (setf (find-class name) class)))))))
+    ;; After boot (SETF FIND-CLASS) does this.
+    (unless (eq **boot-state** 'complete)
+      (%set-class-type-translation class name))
+    class))
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
-  (with-world-lock ()
-    (multiple-value-bind (meta initargs)
-        (frob-ensure-class-args args)
-      (setf class (apply #'make-instance meta :name name initargs))
-      (without-package-locks
-        (setf (find-class name) class))))
-  ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq **boot-state** 'complete)
-    (%set-class-type-translation class name))
-  class)
+  (call-with-ensure-class-context
+   class name args (lambda (class name metaclass initargs)
+                     (declare (ignore class))
+                     (apply #'make-instance metaclass :name name initargs))))
 
 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
-  (with-world-lock ()
-    (multiple-value-bind (meta initargs)
-        (frob-ensure-class-args args)
-      (unless (eq (class-of class) meta)
-        (apply #'change-class class meta initargs))
-      (apply #'reinitialize-instance class initargs)
-      (without-package-locks
-        (setf (find-class name) class))))
-  ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq **boot-state** 'complete)
-    (%set-class-type-translation class name))
-  class)
-
-(defun frob-ensure-class-args (args)
-  (let (metaclass metaclassp reversed-plist)
-    (flet ((frob-superclass (s)
-             (cond
-               ((classp s) s)
-               ((legal-class-name-p s)
-                (or (find-class s nil)
-                    (ensure-class s :metaclass 'forward-referenced-class)))
-               (t (error "Not a class or a legal class name: ~S." s)))))
-      (doplist (key val) args
-        (cond ((eq key :metaclass)
-               (unless metaclassp
-                 (setf metaclass val metaclassp key)))
-              (t
-               (when (eq key :direct-superclasses)
-                 (setf val (mapcar #'frob-superclass val)))
-               (setf reversed-plist (list* val key reversed-plist)))))
-      (values (cond (metaclassp
-                     (if (classp metaclass)
-                         metaclass
-                         (find-class metaclass)))
-                    (t *the-class-standard-class*))
-              (nreverse reversed-plist)))))
+  (call-with-ensure-class-context
+   class name args (lambda (class name metaclass initargs)
+                     (aver (eq name (class-name class)))
+                     (unless (eq (class-of class) metaclass)
+                       (apply #'change-class class metaclass initargs))
+                     (apply #'reinitialize-instance class initargs))))
 
 ;;; This is used to call initfunctions of :allocation :class slots.
 (defun call-initfun (fun slotd safe)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index f6bf919..b270c2b 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2367,4 +2367,25 @@
     (declare (ignore foo bar))
     (assert (= count0 count1 count2))))
 
+
+;;; Classes shouldn't be their own direct or indirect superclasses or
+;;; metaclasses.
+
+(with-test (:name (sb-mop:ensure-class :class-is-direct-superclass
+                   :bug-1418883))
+  (assert-error
+   (defclass class-with-self-as-superclass (class-with-self-as-superclass) ())))
+
+(with-test (:name (sb-mop:ensure-class :superclass-cycle :bug-1418883))
+  ;; These have a superclass cycle from the beginning.
+  (defclass class-with-superclass-cycle1 (class-with-superclass-cycle2) ())
+  (assert-error
+   (defclass class-with-superclass-cycle2 (class-with-superclass-cycle1) ())))
+
+(with-test (:name (sb-mop:ensure-class :self-metaclass))
+  ;; These have a superclass cycle from the beginning.
+  (assert-error
+   (defclass class-with-self-as-metaclass () ()
+     (:metaclass class-with-self-as-metaclass))))
+
 ;;;; success
-- 
2.1.4

0002-UPDATE-CLASS-signals-an-error-when-super-meta-class-.patch

From dcd4a21ffbbad6aee846b3d21f9055ae7115b6b5 Mon Sep 17 00:00:00 2001
From: Jan Moringen <[email protected]>
Date: Sun, 8 Feb 2015 12:57:51 +0100
Subject: [PATCH 2/2] UPDATE-CLASS signals an error when {super,meta}class
 relations become cyclic

Partially based on patch by Lucien Pullen <[email protected]>.

Fixes lp#1418883
---
 src/pcl/std-class.lisp | 31 +++++++++++++++++++------------
 tests/clos.impure.lisp | 26 ++++++++++++++++++++++++++
 2 files changed, 45 insertions(+), 12 deletions(-)

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f54df78..84820c4 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -882,18 +882,25 @@
 ;;; This is called by :after shared-initialize whenever a class is initialized
 ;;; or reinitialized. The class may or may not be finalized.
 (defun update-class (class finalizep)
-  (without-package-locks
-    (with-world-lock ()
-      (when (or finalizep (class-finalized-p class))
-        (%update-cpl class (compute-class-precedence-list class))
-        ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
-        ;; class.
-        (%update-slots class (compute-slots class))
-        (update-gfs-of-class class)
-        (setf (plist-value class 'default-initargs) (compute-default-initargs class))
-        (update-ctors 'finalize-inheritance :class class))
-      (dolist (sub (class-direct-subclasses class))
-        (update-class sub nil)))))
+  (labels ((rec (class finalizep &optional (seen '()))
+             (when (find class seen :test #'eq)
+               (error "~@<Specified class ~S as a superclass of ~
+                       itself.~@:>"
+                      class))
+             (without-package-locks
+               (with-world-lock ()
+                 (when (or finalizep (class-finalized-p class))
+                   (%update-cpl class (compute-class-precedence-list class))
+                   ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
+                   ;; class
+                   (%update-slots class (compute-slots class))
+                   (update-gfs-of-class class)
+                   (setf (plist-value class 'default-initargs) (compute-default-initargs class))
+                   (update-ctors 'finalize-inheritance :class class))
+                 (let ((seen (list* class seen)))
+                   (dolist (sub (class-direct-subclasses class))
+                     (rec sub nil seen)))))))
+    (rec class finalizep)))
 
 (define-condition cpl-protocol-violation (reference-condition error)
   ((class :initarg :class :reader cpl-protocol-violation-class)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b270c2b..81076a6 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2388,4 +2388,30 @@
    (defclass class-with-self-as-metaclass () ()
      (:metaclass class-with-self-as-metaclass))))
 
+(with-test (:name (sb-pcl::update-class :class-becomes-direct-superclass
+                   :bug-1418883))
+  (defclass class-with-eventual-self-as-superclass () ())
+  ;; Update class to introduce superclass.
+  (assert-error
+   (defclass class-with-eventual-self-as-superclass
+       (class-with-eventual-self-as-superclass) ())))
+
+(with-test (:name (sb-pcl::update-class :superclasses-become-cyclic
+                   :bug-1418883))
+  ;; Nothing wrong with these.
+  (defclass class-with-eventual-superclass-cycle1 () ())
+  (defclass class-with-eventual-superclass-cycle2
+      (class-with-eventual-superclass-cycle1) ())
+  ;; Update first class to introduce the superclass cycle.
+  (assert-error
+   (defclass class-with-eventual-superclass-cycle1
+       (class-with-eventual-superclass-cycle2) ())))
+
+(with-test (:name (sb-pcl::update-class :becomses-own-metaclass))
+  (defclass class-with-eventual-self-as-metaclass () ())
+  ;; Try to update metaclass to self.
+  (assert-error
+   (defclass class-with-eventual-self-as-metaclass () ()
+     (:metaclass class-with-eventual-self-as-metaclass))))
+
 ;;;; success
-- 
2.1.4