Reduce consing during SUBTYPEP on classes.

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 1ac4eb4..37e3c75 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -852,7 +852,8 @@
   (or (when (forward-referenced-class-p class)
         class)
       (some #'class-has-a-forward-referenced-superclass-p
-            (class-direct-superclasses class))))
+            ;; KLUDGE: SOME conses without knowing the type
+            (the list (class-direct-superclasses class)))))
 
 ;;; This is called by :after shared-initialize whenever a class is initialized
 ;;; or reinitialized. The class may or may not be finalized.
@@ -886,6 +887,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)