X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=106708db9aee2bce6d7d2aff3bc5a299f3554589;hb=df679ed627975948b1cee190f4d79c397588c43e;hp=70e47da6185c4d01b2a68f51df639737f08dca3b;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 70e47da..106708d 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -628,8 +628,7 @@ And so, we are saved. (maphash (lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) - value - t))) + value))) table) cache)) @@ -687,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) @@ -1307,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)) @@ -1330,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) @@ -1339,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) @@ -1354,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*) @@ -1378,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) @@ -1388,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) @@ -1405,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) @@ -1539,15 +1555,13 @@ And so, we are saved. (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p (!early-gf-name generic-function) - (generic-function-name generic-function))) - (ocache (gf-dfun-cache generic-function))) + (generic-function-name generic-function)))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function)))) - (set-funcallable-instance-fun generic-function dfun) + (set-funcallable-instance-function generic-function dfun) (set-fun-name generic-function gf-name) - (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) (defvar *dfun-count* nil)