(maphash (lambda (classes value)
(setq cache (fill-cache cache
(class-wrapper classes)
- value
- t)))
+ value)))
table)
cache))
(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
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(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)
(let* ((methods (early-gf-methods gf))
(slot-name (early-method-standard-accessor-slot-name (car methods))))
(ecase type
- (reader #'(sb-kernel:instance-lambda (instance)
+ (reader #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
- (boundp #'(sb-kernel:instance-lambda (instance)
+ (boundp #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(not (eq +slot-unbound+
(!bootstrap-get-slot class-name
instance slot-name))))))
- (writer #'(sb-kernel:instance-lambda (new-value instance)
+ (writer #'(instance-lambda (new-value instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-set-slot class-name instance slot-name new-value)))))))
specls all-same-p)
(cond ((null methods)
(values
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args))
nil
(no-methods-dfun-info)))
(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))
(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)
(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)
(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*)
(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)
(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)
(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)
(if function-p
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args)))
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
(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)))
\f
(defvar *dfun-count* nil)
projects / sbcl.git / blobdiff