+(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))))))))
+