X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fdfun.lisp;h=106708db9aee2bce6d7d2aff3bc5a299f3554589;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=4d81f4bd8a37ce873af241a596489248363b04fd;hpb=dc86450e18fb7b90bf6be7d8df8b8ebcb0d090f9;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 4d81f4b..106708d 100644 --- 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)