Make sure quantifiers don't cons

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 261dbbd..975acc4 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -567,18 +567,22 @@
                                      &key direct-slots direct-superclasses)
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (slot-value class 'name))))
-    (with-slots (wrapper %class-precedence-list cpl-available-p
-                         prototype (direct-supers direct-superclasses))
+    (with-slots (wrapper
+                 %class-precedence-list cpl-available-p finalized-p
+                 prototype (direct-supers direct-superclasses)
+                 plist)
         class
       (setf (slot-value class 'direct-slots)
             (mapcar (lambda (pl) (make-direct-slotd class pl))
-                    direct-slots))
-      (setf (slot-value class 'finalized-p) t)
-      (setf (classoid-pcl-class classoid) class)
-      (setq direct-supers direct-superclasses)
-      (setq wrapper (classoid-layout classoid))
-      (setq %class-precedence-list (compute-class-precedence-list class))
-      (setq cpl-available-p t)
+                    direct-slots)
+            finalized-p t
+            (classoid-pcl-class classoid) class
+            direct-supers direct-superclasses
+            wrapper (classoid-layout classoid)
+            %class-precedence-list (compute-class-precedence-list class)
+            cpl-available-p t
+            (getf plist 'direct-default-initargs)
+            (sb-kernel::condition-classoid-direct-default-initargs classoid))
       (add-direct-subclasses class direct-superclasses)
       (let ((slots (compute-slots class)))
         (setf (slot-value class 'slots) slots)
@@ -845,7 +849,8 @@
 
 \f
 (defun class-has-a-forward-referenced-superclass-p (class)
-  (or (forward-referenced-class-p class)
+  (or (when (forward-referenced-class-p class)
+        class)
       (some #'class-has-a-forward-referenced-superclass-p
             (class-direct-superclasses class))))
 
@@ -881,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)
@@ -956,6 +974,32 @@
                       (eq (class-of o) (class-of n)))
            (return nil)))))))
 
+(defun style-warn-about-duplicate-slots (class)
+  (do* ((slots (slot-value class 'slots) (cdr slots))
+        (dupes nil))
+       ((null slots)
+        (when dupes
+          (style-warn
+           "~@<slot names with the same SYMBOL-NAME but ~
+                  different SYMBOL-PACKAGE (possible package problem) ~
+                  for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
+           class dupes)))
+    (let* ((slot-name (slot-definition-name (car slots)))
+           (oslots (and (not (eq (symbol-package slot-name)
+                                 *pcl-package*))
+                        (remove-if
+                         (lambda (slot-name-2)
+                           (or (eq (symbol-package slot-name-2)
+                                   *pcl-package*)
+                               (string/= slot-name slot-name-2)))
+                         (cdr slots)
+                         :key #'slot-definition-name))))
+      (when oslots
+        (pushnew (cons slot-name
+                       (mapcar #'slot-definition-name oslots))
+                 dupes
+                 :test #'string= :key #'car)))))
+
 (defun %update-slots (class eslotds)
   (multiple-value-bind (instance-slots class-slots custom-slots)
       (classify-slotds eslotds)
@@ -981,24 +1025,7 @@
             (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
             (wrapper-length nwrapper) nslots
             (slot-value class 'wrapper) nwrapper)
-      (do* ((slots (slot-value class 'slots) (cdr slots))
-            (dupes nil))
-           ((null slots)
-            (when dupes
-              (style-warn
-               "~@<slot names with the same SYMBOL-NAME but ~
-                  different SYMBOL-PACKAGE (possible package problem) ~
-                  for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
-               class dupes)))
-        (let* ((slot (car slots))
-               (oslots (remove (slot-definition-name slot) (cdr slots)
-                               :test #'string/=
-                               :key #'slot-definition-name)))
-          (when oslots
-            (pushnew (cons (slot-definition-name slot)
-                           (mapcar #'slot-definition-name oslots))
-                     dupes
-                     :test #'string= :key #'car))))
+      (style-warn-about-duplicate-slots class)
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
         (maybe-update-standard-slot-locations class)))))