0.8.0.2:

[sbcl.git] / src / pcl / dfun.lisp

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 4d81f4b..106708d 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -686,38 +686,58 @@ And so, we are saved.
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
 
+(defun finalize-specializers (gf)
+  (let ((all-finalized t))
+    (dolist (method (generic-function-methods gf))
+      (dolist (specializer (method-specializers method))
+       (when (and (classp specializer)
+                  (not (class-finalized-p specializer)))
+         (if (class-has-a-forward-referenced-superclass-p specializer)
+             (setq all-finalized nil)
+             (finalize-inheritance specializer)))))
+    all-finalized))
+
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
         #'(instance-lambda (&rest args)
             (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
-       (if (and (eq *boot-state* 'complete)
-                (compute-applicable-methods-emf-std-p gf))
-           (let* ((caching-p (use-caching-dfun-p gf))
-                  (classes-list (precompute-effective-methods
-                                 gf caching-p
-                                 (not *lazy-dfun-compute-p*))))
-             (if *lazy-dfun-compute-p*
-                 (cond ((use-dispatch-dfun-p gf caching-p)
-                        (values initial-dfun
-                                nil
-                                (initial-dispatch-dfun-info)))
-                       (caching-p
-                        (insure-caching-dfun gf)
-                        (values initial-dfun nil (initial-dfun-info)))
-                       (t
-                        (values initial-dfun nil (initial-dfun-info))))
-                 (make-final-dfun-internal gf classes-list)))
-           (let ((arg-info (if (early-gf-p gf)
-                               (early-gf-arg-info gf)
-                               (gf-arg-info gf)))
-                 (type nil))
-             (if (and (gf-precompute-dfun-and-emf-p arg-info)
-                      (setq type (final-accessor-dfun-type gf)))
-                 (if *early-p*
-                     (values (make-early-accessor gf type) nil nil)
-                     (make-final-accessor-dfun gf type))
-                 (values initial-dfun nil (initial-dfun-info)))))
+       (cond
+         ((and (eq *boot-state* 'complete)
+               (not (finalize-specializers gf)))
+          (values initial-dfun nil (initial-dfun-info)))
+         ((and (eq *boot-state* 'complete)
+               (compute-applicable-methods-emf-std-p gf))
+          (let* ((caching-p (use-caching-dfun-p gf))
+                 ;; KLUDGE: the only effect of this (when
+                 ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is)
+                 ;; is to signal an error when we try to add methods
+                 ;; with the wrong qualifiers to a generic function.
+                 (classes-list (precompute-effective-methods
+                                gf caching-p
+                                (not *lazy-dfun-compute-p*))))
+            (if *lazy-dfun-compute-p*
+                (cond ((use-dispatch-dfun-p gf caching-p)
+                       (values initial-dfun
+                               nil
+                               (initial-dispatch-dfun-info)))
+                      (caching-p
+                       (insure-caching-dfun gf)
+                       (values initial-dfun nil (initial-dfun-info)))
+                      (t
+                       (values initial-dfun nil (initial-dfun-info))))
+                (make-final-dfun-internal gf classes-list))))
+         (t
+          (let ((arg-info (if (early-gf-p gf)
+                              (early-gf-arg-info gf)
+                              (gf-arg-info gf)))
+                (type nil))
+            (if (and (gf-precompute-dfun-and-emf-p arg-info)
+                     (setq type (final-accessor-dfun-type gf)))
+                (if *early-p*
+                    (values (make-early-accessor gf type) nil nil)
+                    (make-final-accessor-dfun gf type))
+                (values initial-dfun nil (initial-dfun-info))))))
       (set-dfun gf dfun cache info))))
 
 (defun make-early-accessor (gf type)
@@ -1306,6 +1326,12 @@ And so, we are saved.
       (mapcar (lambda (x) (position x lambda-list))
              argument-precedence-order)))
 
+(defun cpl-or-nil (class)
+  (if (eq *boot-state* 'complete)
+      (when (class-finalized-p class)
+        (class-precedence-list class))
+      (early-class-precedence-list class)))
+
 (defun saut-and (specl type)
   (let ((applicable nil)
        (possibly-applicable t))
@@ -1329,8 +1355,8 @@ And so, we are saved.
 
 (defun saut-not-class (specl ntype)
   (let* ((class (type-class specl))
-        (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+        (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-prototype (specl ntype)
   (let* ((class (case (car specl)
@@ -1338,8 +1364,8 @@ And so, we are saved.
                  (class-eq  (cadr specl))
                  (prototype (cadr specl))
                  (class     (cadr specl))))
-        (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+        (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-class-eq (specl ntype)
   (let ((class (case (car specl)
@@ -1353,9 +1379,7 @@ And so, we are saved.
     (t   t)))
 
 (defun class-applicable-using-class-p (specl type)
-  (let ((pred (memq specl (if (eq *boot-state* 'complete)
-                             (class-precedence-list type)
-                             (early-class-precedence-list type)))))
+  (let ((pred (memq specl (cpl-or-nil type))))
     (values pred
            (or pred
                (if (not *in-precompute-effective-methods-p*)
@@ -1377,7 +1401,7 @@ And so, we are saved.
     (class (class-applicable-using-class-p (cadr specl) (cadr type)))
     (t     (values nil (let ((class (type-class specl)))
                         (memq (cadr type)
-                              (class-precedence-list class)))))))
+                              (cpl-or-nil class)))))))
 
 (defun saut-class-eq (specl type)
   (if (eq (car specl) 'eql)
@@ -1387,11 +1411,7 @@ And so, we are saved.
                     (eq (cadr specl) (cadr type)))
                    (class
                     (or (eq (cadr specl) (cadr type))
-                        (memq (cadr specl)
-                              (if (eq *boot-state* 'complete)
-                                  (class-precedence-list (cadr type))
-                                  (early-class-precedence-list
-                                   (cadr type)))))))))
+                        (memq (cadr specl) (cpl-or-nil (cadr type))))))))
        (values pred pred))))
 
 (defun saut-prototype (specl type)
@@ -1404,10 +1424,7 @@ And so, we are saved.
                (class-eq   (eq (cadr specl) (class-of (cadr type))))
                (class      (memq (cadr specl)
                                  (let ((class (class-of (cadr type))))
-                                   (if (eq *boot-state* 'complete)
-                                       (class-precedence-list class)
-                                       (early-class-precedence-list
-                                        class))))))))
+                                   (cpl-or-nil class)))))))
     (values pred pred)))
 
 (defun specializer-applicable-using-type-p (specl type)