From 047d97334d1124ffecb36eba80904dd87403c33c Mon Sep 17 00:00:00 2001 From: Lucien Pullen Date: Fri, 6 Feb 2015 02:15:04 -0700 Subject: [PATCH] Circular class definitions are abortable. Add a check to class initialization to ensure that the class does not appear as one of its superclasses. This fixes a non-ABORTable call stack exhaustion error. --- src/pcl/std-class.lisp | 30 ++++++++++++++++++------------ tests/clos.impure.lisp | 10 ++++++++++ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 1b637bf..f3da15b 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -864,18 +864,24 @@ (defun class-has-a-forward-referenced-superclass-p (class) ;;; 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))))) + (let ((been-there (make-hash-table :test 'eq))) + (labels ((%update-class (class finalizep) + (without-package-locks + (with-world-lock () + (setf (gethash class been-there) class) + (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)) + (when (gethash sub been-there) (error "Circular class definition for ~S" class)) + (%update-class sub nil)) + (remhash class been-there))))) + (%update-class 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 f6bf919..11d09da 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -2366,5 +2366,15 @@ (defgeneric g (x y) (:method (x y) (* x y))) (count2 (hash-table-count sb-pcl::*fgens*))) (declare (ignore foo bar)) (assert (= count0 count1 count2)))) + +;;; Classes shouldn't be their own direct superclass. +(with-test (:name (sb-mop:ensure-class :class-is-direct-superclass) :fails-on :sbcl) + (assert (null (ignore-errors (defclass class-with-self-parent (class-with-self-parent) ()))))) + +;;; Circular class definitions can be aborted from. +(with-test (:name (sb-pcl::update-class :circular-class-definition)) + (defclass class-with-recursive-parent1 (class-with-recursive-parent2) ()) + (assert (null (ignore-errors (defclass class-with-recursive-parent2 (class-with-recursive-parent1) ()))))) + ;;;; success -- 2.1.3