From: Christophe Rhodes <csr21@cantab.net>
Date: Tue, 10 Sep 2013 22:24:46 +0000 (+0100)
Subject: detect cpl-protocol-violations early
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3641e3c73615bffcdd9c014e6663d80935e985ef;p=sbcl.git

detect cpl-protocol-violations early

Don't try to eagerly finalize classes which will cause
cpl-protocol-violations to be signalled.  (lp#309076)
---

diff --git a/NEWS b/NEWS
index fa9a742..c099edc 100644
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,8 @@ changes relative to sbcl-1.1.11:
     constructors handles non-KEYWORD initialization arguments more correctly.
   * bug fix: loading the SB-SIMPLE-STREAMS contributed module no longer
     clobbers FILE-NAMESTRING.  (thanks to Anton Kovalenko, lp#884603)
+  * bug fix: class definitions with CPLs inconsistent with their metaclasses
+    are less likely to destroy the object system's integrity.  (lp#309076)
   
 changes in sbcl-1.1.11 relative to sbcl-1.1.10:
   * enhancement: support building the manual under texinfo version 5.
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 35e9fba..05aace9 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1441,7 +1441,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
         ;; if we can finalize an unfinalized class, then do so
         (when (and (not (class-finalized-p class))
-                   (not (class-has-a-forward-referenced-superclass-p class)))
+                   (not (class-has-a-forward-referenced-superclass-p class))
+                   (not (class-has-a-cpl-protocol-violation-p class)))
           (finalize-inheritance class)
           (class-precedence-list class)))
 
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 1ac4eb4..975acc4 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -886,6 +886,19 @@
              (find-class 'function)
              (cpl-protocol-violation-cpl c)))))
 
+(defun class-has-a-cpl-protocol-violation-p (class)
+  (labels ((find-in-superclasses (class classes)
+             (cond
+               ((null classes) nil)
+               ((eql class (car classes)) t)
+               (t (find-in-superclasses class (append (class-direct-superclasses (car classes)) (cdr classes)))))))
+    (let ((metaclass (class-of class)))
+      (cond
+        ((eql metaclass *the-class-standard-class*)
+         (find-in-superclasses (find-class 'function) (list class)))
+        ((eql metaclass *the-class-funcallable-standard-class*)
+         (not (find-in-superclasses (find-class 'function) (list class))))))))
+
 (defun %update-cpl (class cpl)
   (when (eq (class-of class) *the-class-standard-class*)
     (when (find (find-class 'function) cpl)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 0838bd6..4484eb7 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2066,4 +2066,16 @@
     (assert
      (foo= 15 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b 'foo 15))))))))
 
+(with-test (:name (cpl-violation-setup :bug-309076))
+  (assert (raises-error?
+           (progn
+             (defclass bug-309076-broken-class (standard-class) ()
+               (:metaclass sb-mop:funcallable-standard-class))
+             (sb-mop:finalize-inheritance (find-class 'bug-309076-broken-class))))))
+
+(with-test (:name (cpl-violation-irrelevant-class :bug-309076))
+  (defclass bug-309076-class (standard-class) ())
+  (defmethod sb-mop:validate-superclass ((x bug-309076-class) (y standard-class)) t)
+  (assert (typep (make-instance 'bug-309076-class) 'bug-309076-class)))
+
 ;;;; success