- (apply (fdefinition generator) args)
- (or (cadr args-entry)
- (multiple-value-bind (new not-best-p)
- (apply (symbol-function generator) args)
- (let ((entry (list (copy-list args) new (unless not-best-p 'pcl)
- not-best-p)))
- (if generator-entry
- (push entry (cdr generator-entry))
- (push (list generator entry)
- *dfun-constructors*)))
- (values new not-best-p))))))
+ (apply (fdefinition generator) args)
+ (or (cadr args-entry)
+ (multiple-value-bind (new not-best-p)
+ (apply (symbol-function generator) args)
+ (let ((entry (list (copy-list args) new (unless not-best-p 'pcl)
+ not-best-p)))
+ (if generator-entry
+ (push entry (cdr generator-entry))
+ (push (list generator entry)
+ *dfun-constructors*)))
+ (values new not-best-p))))))
- (when (fourth args-entry)
- (let* ((dfun-type (case generator
- (emit-checking 'checking)
- (emit-caching 'caching)
- (emit-constant-value 'constant-value)
- (emit-default-only 'default-method-only)))
- (metatypes (car args))
- (gfs (when dfun-type (gfs-of-type dfun-type))))
- (dolist (gf gfs)
- (when (and (equal metatypes
- (arg-info-metatypes (gf-arg-info gf)))
- (let ((gf-name (generic-function-name gf)))
- (and (not (eq gf-name 'slot-value-using-class))
- (not (equal gf-name
- '(setf slot-value-using-class)))
- (not (eq gf-name 'slot-boundp-using-class)))))
- (update-dfun gf)))
- (setf (second args-entry) constructor)
- (setf (third args-entry) system)
- (setf (fourth args-entry) nil)))
- (let ((entry (list args constructor system nil)))
- (if generator-entry
- (push entry (cdr generator-entry))
- (push (list generator entry) *dfun-constructors*))))))
+ (when (fourth args-entry)
+ (let* ((dfun-type (case generator
+ (emit-checking 'checking)
+ (emit-caching 'caching)
+ (emit-constant-value 'constant-value)
+ (emit-default-only 'default-method-only)))
+ (metatypes (car args))
+ (gfs (when dfun-type (gfs-of-type dfun-type))))
+ (dolist (gf gfs)
+ (when (and (equal metatypes
+ (arg-info-metatypes (gf-arg-info gf)))
+ (let ((gf-name (generic-function-name gf)))
+ (and (not (eq gf-name 'slot-value-using-class))
+ (not (equal gf-name
+ '(setf slot-value-using-class)))
+ (not (eq gf-name 'slot-boundp-using-class)))))
+ (update-dfun gf)))
+ (setf (second args-entry) constructor)
+ (setf (third args-entry) system)
+ (setf (fourth args-entry) nil)))
+ (let ((entry (list args constructor system nil)))
+ (if generator-entry
+ (push entry (cdr generator-entry))
+ (push (list generator entry) *dfun-constructors*))))))
- (dolist (generator-entry *dfun-constructors*)
- (dolist (args-entry (cdr generator-entry))
- (when (or (null (caddr args-entry))
- (eq (caddr args-entry) system))
- (when system (setf (caddr args-entry) system))
- (push `(load-precompiled-dfun-constructor
+ (dolist (generator-entry *dfun-constructors*)
+ (dolist (args-entry (cdr generator-entry))
+ (when (or (null (caddr args-entry))
+ (eq (caddr args-entry) system))
+ (when system (setf (caddr args-entry) system))
+ (push `(load-precompiled-dfun-constructor
- (let ((value (if (funcallable-instance-p object)
- (funcallable-standard-instance-access object location)
- (standard-instance-access object location))))
- (when (eq +slot-unbound+ value)
- (error "~@<slot ~s of class ~s is unbound in object ~s~@:>"
- slot-name class object))
- value)
- (error "~@<cannot get standard value of slot ~s of class ~s ~
- in object ~s~@:>"
- slot-name class object))))
+ (let ((value (if (funcallable-instance-p object)
+ (funcallable-standard-instance-access object location)
+ (standard-instance-access object location))))
+ (when (eq +slot-unbound+ value)
+ (error "~@<slot ~S of class ~S is unbound in object ~S~@:>"
+ slot-name class object))
+ value)
+ (error "~@<cannot get standard value of slot ~S of class ~S ~
+ in object ~S~@:>"
+ slot-name class object))))
- (let ((dfun-info (default-method-only-dfun-info)))
- (values
- (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
- function)
- nil
- dfun-info))
- (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
- (dfun-info (checking-dfun-info function cache)))
- (values
- (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
- cache
- function
- (lambda (&rest args)
- (checking-miss generic-function args dfun-info)))
- cache
- dfun-info)))))
+ (let ((dfun-info (default-method-only-dfun-info)))
+ (values
+ (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
+ function)
+ nil
+ dfun-info))
+ (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
+ (dfun-info (checking-dfun-info function cache)))
+ (values
+ (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
+ cache
+ function
+ (lambda (&rest args)
+ (checking-miss generic-function args dfun-info)))
+ cache
+ dfun-info)))))
- (values (lambda (&rest args)
- (invoke-emf function args))
- nil (default-method-only-dfun-info))
- (let ((cache (make-final-ordinary-dfun-internal
- generic-function nil #'checking-limit-fn
- classes-list new-class)))
- (make-checking-dfun generic-function function cache)))))
+ (values (lambda (&rest args)
+ (invoke-emf function args))
+ nil (default-method-only-dfun-info))
+ (let ((cache (make-final-ordinary-dfun-internal
+ generic-function nil #'checking-limit-fn
+ classes-list new-class)))
+ (make-checking-dfun generic-function function cache)))))
- (let ((fmf (if (listp method)
- (third method)
- (method-fast-function method))))
- (method-function-get fmf :slot-name-lists)))
- ;; KLUDGE: As of sbcl-0.6.4, it's very important for
- ;; efficiency to know the type of the sequence argument to
- ;; quantifiers (SOME/NOTANY/etc.) at compile time, but
- ;; the compiler isn't smart enough to understand the :TYPE
- ;; slot option for DEFCLASS, so we just tell
- ;; it the type by hand here.
- (the list
- (if (early-gf-p generic-function)
- (early-gf-methods generic-function)
- (generic-function-methods generic-function)))))
+ (let ((fmf (if (listp method)
+ (third method)
+ (method-fast-function method))))
+ (method-function-get fmf :slot-name-lists)))
+ ;; KLUDGE: As of sbcl-0.6.4, it's very important for
+ ;; efficiency to know the type of the sequence argument to
+ ;; quantifiers (SOME/NOTANY/etc.) at compile time, but
+ ;; the compiler isn't smart enough to understand the :TYPE
+ ;; slot option for DEFCLASS, so we just tell
+ ;; it the type by hand here.
+ (the list
+ (if (early-gf-p generic-function)
+ (early-gf-methods generic-function)
+ (generic-function-methods generic-function)))))
- (or (not (eq *boot-state* 'complete))
- ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
- ;; can't use this, of course, because we can't tell
- ;; which methods will be considered applicable.
- ;;
- ;; Also, don't use this dfun method if the generic
- ;; function has a non-standard method combination,
- ;; because if it has, it's not sure that method
- ;; functions are used directly as effective methods,
- ;; which CONSTANT-VALUE-MISS depends on. The
- ;; pre-defined method combinations like LIST are
- ;; examples of that.
- (and (compute-applicable-methods-emf-std-p gf)
- (eq (generic-function-method-combination gf)
- *standard-method-combination*)))
- ;; Check that no method is eql-specialized, and that all
- ;; methods return a constant value. If BOOLEAN-VALUES-P,
- ;; check that all return T or NIL. Also, check that no
- ;; method has qualifiers, to make sure that emfs are really
- ;; method functions; see above.
- (dolist (method methods t)
- (when (eq *boot-state* 'complete)
- (when (or (some #'eql-specializer-p
- (method-specializers method))
- (method-qualifiers method))
- (return nil)))
- (let ((value (method-function-get
- (if early-p
- (or (third method) (second method))
- (or (method-fast-function method)
- (method-function method)))
- :constant-value default)))
- (when (or (eq value default)
- (and boolean-values-p
- (not (member value '(t nil)))))
- (return nil))))))))
+ (or (not (eq *boot-state* 'complete))
+ ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
+ ;; can't use this, of course, because we can't tell
+ ;; which methods will be considered applicable.
+ ;;
+ ;; Also, don't use this dfun method if the generic
+ ;; function has a non-standard method combination,
+ ;; because if it has, it's not sure that method
+ ;; functions are used directly as effective methods,
+ ;; which CONSTANT-VALUE-MISS depends on. The
+ ;; pre-defined method combinations like LIST are
+ ;; examples of that.
+ (and (compute-applicable-methods-emf-std-p gf)
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*)))
+ ;; Check that no method is eql-specialized, and that all
+ ;; methods return a constant value. If BOOLEAN-VALUES-P,
+ ;; check that all return T or NIL. Also, check that no
+ ;; method has qualifiers, to make sure that emfs are really
+ ;; method functions; see above.
+ (dolist (method methods t)
+ (when (eq *boot-state* 'complete)
+ (when (or (some #'eql-specializer-p
+ (method-specializers method))
+ (method-qualifiers method))
+ (return nil)))
+ (let ((value (method-function-get
+ (if early-p
+ (or (third method) (second method))
+ (or (method-fast-function method)
+ (method-function method)))
+ :constant-value default)))
+ (when (or (eq value default)
+ (and boolean-values-p
+ (not (member value '(t nil)))))
+ (return nil))))))))
- (if (eq 'class (car type))
- (let* ((metaclass (class-of (cadr type)))
- (mcpl (class-precedence-list metaclass)))
- (cond ((memq *the-class-built-in-class* mcpl)
- *built-in-typep-cost*)
- ((memq *the-class-structure-class* mcpl)
- *structure-typep-cost*)
- (t
- *non-built-in-typep-cost*)))
- 0))
- (max-cost-so-far
- (+ (max true-value false-value) type-test-cost)))
+ (if (eq 'class (car type))
+ (let* ((metaclass (class-of (cadr type)))
+ (mcpl (class-precedence-list metaclass)))
+ (cond ((memq *the-class-built-in-class* mcpl)
+ *built-in-typep-cost*)
+ ((memq *the-class-structure-class* mcpl)
+ *structure-typep-cost*)
+ (t
+ *non-built-in-typep-cost*)))
+ 0))
+ (max-cost-so-far
+ (+ (max true-value false-value) type-test-cost)))
- (nkeys (arg-info-nkeys arg-info))
- (new-class (and new-class
- (equal (type-of (gf-dfun-info generic-function))
- (cond ((eq valuep t) 'caching)
- ((eq valuep :constant-value) 'constant-value)
- ((null valuep) 'checking)))
- new-class))
- (cache (if new-class
- (copy-cache (gf-dfun-cache generic-function))
- (get-cache nkeys (not (null valuep)) limit-fn 4))))
+ (nkeys (arg-info-nkeys arg-info))
+ (new-class (and new-class
+ (equal (type-of (gf-dfun-info generic-function))
+ (cond ((eq valuep t) 'caching)
+ ((eq valuep :constant-value) 'constant-value)
+ ((null valuep) 'checking)))
+ new-class))
+ (cache (if new-class
+ (copy-cache (gf-dfun-cache generic-function))
+ (get-cache nkeys (not (null valuep)) limit-fn 4))))
- ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
- ;; slots?)
- `((if (and (eq ,type 'boundp) (integerp ,nemf))
- (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
- (invoke-emf ,nemf ,args)))
- `((invoke-emf ,nemf ,args)))))
+ ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
+ ;; slots?)
+ `((if (and (eq ,type 'boundp) (integerp ,nemf))
+ (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
+ (invoke-emf ,nemf ,args)))
+ `((invoke-emf ,nemf ,args)))))
- (dolist (method methods all-finalized)
- (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)))))))))
+ (dolist (method methods all-finalized)
+ (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)))))))))
- (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))))))
+ (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))))))
- (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 #'(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 #'(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)))))))
+ (reader #'(lambda (instance)
+ (let* ((class (class-of instance))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-get-slot class-name instance slot-name))))
+ (boundp #'(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 #'(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)))))))
- ((and ntype nindex)
- (dfun-update
- gf #'make-one-class-accessor-dfun ntype wrappers nindex))
- ((use-caching-dfun-p gf)
- (dfun-update gf #'make-caching-dfun))
- (t
- (dfun-update
- gf #'make-checking-dfun
- ;; nemf is suitable only for caching, have to do this:
- (cache-miss-values gf args 'checking))))))
+ ((and ntype nindex)
+ (dfun-update
+ gf #'make-one-class-accessor-dfun ntype wrappers nindex))
+ ((use-caching-dfun-p gf)
+ (dfun-update gf #'make-caching-dfun))
+ (t
+ (dfun-update
+ gf #'make-checking-dfun
+ ;; nemf is suitable only for caching, have to do this:
+ (cache-miss-values gf args 'checking))))))
- (if (consp method)
- (eq *the-class-standard-reader-method*
- (early-method-class method))
- (standard-reader-method-p method)))
- methods)
- 'reader)
- ((every (lambda (method)
- (if (consp method)
- (eq *the-class-standard-boundp-method*
- (early-method-class method))
- (standard-boundp-method-p method)))
- methods)
- 'boundp)
- ((every (lambda (method)
- (if (consp method)
- (eq *the-class-standard-writer-method*
- (early-method-class method))
- (standard-writer-method-p method)))
- methods)
- 'writer))))
+ (if (consp method)
+ (eq *the-class-standard-reader-method*
+ (early-method-class method))
+ (standard-reader-method-p method)))
+ methods)
+ 'reader)
+ ((every (lambda (method)
+ (if (consp method)
+ (eq *the-class-standard-boundp-method*
+ (early-method-class method))
+ (standard-boundp-method-p method)))
+ methods)
+ 'boundp)
+ ((every (lambda (method)
+ (if (consp method)
+ (eq *the-class-standard-writer-method*
+ (early-method-class method))
+ (standard-writer-method-p method)))
+ methods)
+ 'writer))))
- (cond ((= size 1)
- (let ((w (class-wrapper first)))
- (make-one-class-accessor-dfun gf type w all-index)))
- ((and (= size 2) (or (integerp all-index) (consp all-index)))
- (let ((w0 (class-wrapper first))
- (w1 (class-wrapper second)))
- (make-two-class-accessor-dfun gf type w0 w1 all-index)))
- ((or (integerp all-index) (consp all-index))
- (make-final-one-index-accessor-dfun
- gf type all-index table))
- (no-class-slots-p
- (make-final-n-n-accessor-dfun gf type table))
- (t
- (make-final-caching-dfun gf classes-list new-class)))
- (make-final-caching-dfun gf classes-list new-class)))))
+ (cond ((= size 1)
+ (let ((w (class-wrapper first)))
+ (make-one-class-accessor-dfun gf type w all-index)))
+ ((and (= size 2) (or (integerp all-index) (consp all-index)))
+ (let ((w0 (class-wrapper first))
+ (w1 (class-wrapper second)))
+ (make-two-class-accessor-dfun gf type w0 w1 all-index)))
+ ((or (integerp all-index) (consp all-index))
+ (make-final-one-index-accessor-dfun
+ gf type all-index table))
+ (no-class-slots-p
+ (make-final-n-n-accessor-dfun gf type table))
+ (t
+ (make-final-caching-dfun gf classes-list new-class)))
+ (make-final-caching-dfun gf classes-list new-class)))))
- (values
- #'(instance-lambda (&rest args)
- (apply #'no-applicable-method gf args))
- nil
- (no-methods-dfun-info)))
- ((setq type (final-accessor-dfun-type gf))
- (make-final-accessor-dfun gf type classes-list new-class))
- ((and (not (and (every (lambda (specl) (eq specl *the-class-t*))
- (setq specls
- (method-specializers (car methods))))
- (setq all-same-p
- (every (lambda (method)
- (and (equal specls
- (method-specializers
- method))))
- methods))))
- (use-constant-value-dfun-p gf))
- (make-final-constant-value-dfun gf classes-list new-class))
- ((use-dispatch-dfun-p gf)
- (make-final-dispatch-dfun gf))
- ((and all-same-p (not (use-caching-dfun-p gf)))
- (let ((emf (get-secondary-dispatch-function gf methods nil)))
- (make-final-checking-dfun gf emf classes-list new-class)))
- (t
- (make-final-caching-dfun gf classes-list new-class)))))
+ (values
+ #'(lambda (&rest args)
+ (apply #'no-applicable-method gf args))
+ nil
+ (no-methods-dfun-info)))
+ ((setq type (final-accessor-dfun-type gf))
+ (make-final-accessor-dfun gf type classes-list new-class))
+ ((and (not (and (every (lambda (specl) (eq specl *the-class-t*))
+ (setq specls
+ (method-specializers (car methods))))
+ (setq all-same-p
+ (every (lambda (method)
+ (and (equal specls
+ (method-specializers
+ method))))
+ methods))))
+ (use-constant-value-dfun-p gf))
+ (make-final-constant-value-dfun gf classes-list new-class))
+ ((use-dispatch-dfun-p gf)
+ (make-final-dispatch-dfun gf))
+ ((and all-same-p (not (use-caching-dfun-p gf)))
+ (let ((emf (get-secondary-dispatch-function gf methods nil)))
+ (make-final-checking-dfun gf emf classes-list new-class)))
+ (t
+ (make-final-caching-dfun gf classes-list new-class)))))
- (when (zerop (random 2)) (psetf w0 w1 w1 w0))
- (dfun-update gf
- #'make-two-class-accessor-dfun
- ntype
- w0
- w1
- index))
- (one-index (index &optional cache)
- (dfun-update gf
- #'make-one-index-accessor-dfun
- ntype
- index
- cache))
- (n-n (&optional cache)
- (if (consp nindex)
- (dfun-update gf #'make-checking-dfun nemf)
- (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
- (caching () ; because cached accessor emfs are much faster
- ; for accessors
- (dfun-update gf #'make-caching-dfun))
- (do-fill (update-fn)
- (let ((ncache (fill-cache cache wrappers nindex)))
- (unless (eq ncache cache)
- (funcall update-fn ncache)))))
-
- (cond ((null ntype)
- (caching))
- ((or invalidp
- (null nindex)))
- ((not (pcl-instance-p object))
- (caching))
- ((or (neq ntype otype) (listp wrappers))
- (caching))
- (t
- (ecase ostate
- (one-class
- (setq oindex (dfun-info-index dfun-info))
- (setq ow0 (dfun-info-wrapper0 dfun-info))
- (unless (eq ow0 wrappers)
- (if (eql nindex oindex)
- (two-class nindex ow0 wrappers)
- (n-n))))
- (two-class
- (setq oindex (dfun-info-index dfun-info))
- (setq ow0 (dfun-info-wrapper0 dfun-info))
- (setq ow1 (dfun-info-wrapper1 dfun-info))
- (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
- (if (eql nindex oindex)
- (one-index nindex)
- (n-n))))
- (one-index
- (setq oindex (dfun-info-index dfun-info))
- (setq cache (dfun-info-cache dfun-info))
- (if (eql nindex oindex)
- (do-fill (lambda (ncache)
- (one-index nindex ncache)))
- (n-n)))
- (n-n
- (setq cache (dfun-info-cache dfun-info))
- (if (consp nindex)
- (caching)
- (do-fill #'n-n))))))))))
+ (when (zerop (random 2)) (psetf w0 w1 w1 w0))
+ (dfun-update gf
+ #'make-two-class-accessor-dfun
+ ntype
+ w0
+ w1
+ index))
+ (one-index (index &optional cache)
+ (dfun-update gf
+ #'make-one-index-accessor-dfun
+ ntype
+ index
+ cache))
+ (n-n (&optional cache)
+ (if (consp nindex)
+ (dfun-update gf #'make-checking-dfun nemf)
+ (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
+ (caching () ; because cached accessor emfs are much faster
+ ; for accessors
+ (dfun-update gf #'make-caching-dfun))
+ (do-fill (update-fn)
+ (let ((ncache (fill-cache cache wrappers nindex)))
+ (unless (eq ncache cache)
+ (funcall update-fn ncache)))))
+
+ (cond ((null ntype)
+ (caching))
+ ((or invalidp
+ (null nindex)))
+ ((not (pcl-instance-p object))
+ (caching))
+ ((or (neq ntype otype) (listp wrappers))
+ (caching))
+ (t
+ (ecase ostate
+ (one-class
+ (setq oindex (dfun-info-index dfun-info))
+ (setq ow0 (dfun-info-wrapper0 dfun-info))
+ (unless (eq ow0 wrappers)
+ (if (eql nindex oindex)
+ (two-class nindex ow0 wrappers)
+ (n-n))))
+ (two-class
+ (setq oindex (dfun-info-index dfun-info))
+ (setq ow0 (dfun-info-wrapper0 dfun-info))
+ (setq ow1 (dfun-info-wrapper1 dfun-info))
+ (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
+ (if (eql nindex oindex)
+ (one-index nindex)
+ (n-n))))
+ (one-index
+ (setq oindex (dfun-info-index dfun-info))
+ (setq cache (dfun-info-cache dfun-info))
+ (if (eql nindex oindex)
+ (do-fill (lambda (ncache)
+ (one-index nindex ncache)))
+ (n-n)))
+ (n-n
+ (setq cache (dfun-info-cache dfun-info))
+ (if (consp nindex)
+ (caching)
+ (do-fill #'n-n))))))))))
- (let* ((function
- (typecase emf
- (fast-method-call (fast-method-call-function emf))
- (method-call (method-call-function emf))))
- (value (let ((val (method-function-get
- function :constant-value '.not-found.)))
- (aver (not (eq val '.not-found.)))
- val))
- (ncache (fill-cache ocache wrappers value)))
- (unless (eq ncache ocache)
- (dfun-update generic-function
- #'make-constant-value-dfun ncache)))))))
+ (let* ((function
+ (typecase emf
+ (fast-method-call (fast-method-call-function emf))
+ (method-call (method-call-function emf))))
+ (value (let ((val (method-function-get
+ function :constant-value '.not-found.)))
+ (aver (not (eq val '.not-found.)))
+ val))
+ (ncache (fill-cache ocache wrappers value)))
+ (unless (eq ncache ocache)
+ (dfun-update generic-function
+ #'make-constant-value-dfun ncache)))))))
-;;; is a standard reader or writer method. To be specific,
-;;; the value is READER when the method combination is eq to
-;;; *standard-method-combination*; there are no applicable
-;;; :before, :after or :around methods; and the most specific
-;;; primary method is a standard reader method.
+;;; is a standard reader or writer method. To be specific,
+;;; the value is READER when the method combination is eq to
+;;; *standard-method-combination*; there are no applicable
+;;; :before, :after or :around methods; and the most specific
+;;; primary method is a standard reader method.
- (acons gf classes *cache-miss-values-stack*))
- (cam-std-p (or (null arg-info)
- (gf-info-c-a-m-emf-std-p arg-info))))
- (multiple-value-bind (methods all-applicable-and-sorted-p)
- (if cam-std-p
- (compute-applicable-methods-using-types gf types)
- (compute-applicable-methods-using-classes gf classes))
-
+ (acons gf classes *cache-miss-values-stack*))
+ (cam-std-p (or (null arg-info)
+ (gf-info-c-a-m-emf-std-p arg-info))))
+ (multiple-value-bind (methods all-applicable-and-sorted-p)
+ (if cam-std-p
+ (compute-applicable-methods-using-types gf types)
+ (compute-applicable-methods-using-classes gf classes))
+
- (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
- (emf (if (or cam-std-p all-applicable-and-sorted-p)
- (let ((generator
- (get-secondary-dispatch-function1
- gf methods types nil (and for-cache-p wrappers)
- all-applicable-and-sorted-p)))
- (make-callable gf methods generator
- nil (and for-cache-p wrappers)))
- (default-secondary-dispatch-function gf))))
+ (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
+ (emf (if (or cam-std-p all-applicable-and-sorted-p)
+ (let ((generator
+ (get-secondary-dispatch-function1
+ gf methods types nil (and for-cache-p wrappers)
+ all-applicable-and-sorted-p)))
+ (make-callable gf methods generator
+ nil (and for-cache-p wrappers)))
+ (default-secondary-dispatch-function gf))))
- (let ((method (find-standard-class-accessor-method
- gf class accessor-type))
- (index (standard-slot-value/eslotd slotd 'location))
- (type (gf-info-simple-accessor-type arg-info)))
- (when (and method
- (subtypep (ecase accessor-type
- ((reader) (car classes))
- ((writer) (cadr classes)))
- class))
- (return-from break-vicious-metacircle
- (values index (list method) type index)))))))
+ (let ((method (find-standard-class-accessor-method
+ gf class accessor-type))
+ (index (standard-slot-value/eslotd slotd 'location))
+ (type (gf-info-simple-accessor-type arg-info)))
+ (when (and method
+ (subtypep (ecase accessor-type
+ ((reader) (car classes))
+ ((writer) (cadr classes)))
+ class))
+ (return-from break-vicious-metacircle
+ (values index (list method) type index)))))))
- (loop with gf-name = (standard-slot-value/gf gf 'name)
- for slotd in (standard-slot-value/class class 'slots)
- ;; FIXME: where does BOUNDP fit in here? Is it
- ;; relevant?
- as readers = (standard-slot-value/eslotd slotd 'readers)
- as writers = (standard-slot-value/eslotd slotd 'writers)
- if (member gf-name readers :test #'equal)
- return (values slotd 'reader)
- else if (member gf-name writers :test #'equal)
- return (values slotd 'writer))))
+ (loop with gf-name = (standard-slot-value/gf gf 'name)
+ for slotd in (standard-slot-value/class class 'slots)
+ ;; FIXME: where does BOUNDP fit in here? Is it
+ ;; relevant?
+ as readers = (standard-slot-value/eslotd slotd 'readers)
+ as writers = (standard-slot-value/eslotd slotd 'writers)
+ if (member gf-name readers :test #'equal)
+ return (values slotd 'reader)
+ else if (member gf-name writers :test #'equal)
+ return (values slotd 'writer))))
- (dolist (method (standard-slot-value/gf gf 'methods))
- (let ((specializers (standard-slot-value/method method 'specializers))
- (qualifiers (plist-value method 'qualifiers)))
- (when (and (null qualifiers)
- (eq (ecase type
- (reader (car specializers))
- (writer (cadr specializers)))
- class))
- (return method)))))
+ (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+ (found-specializer *the-class-t*)
+ (found-method nil))
+ (dolist (method (standard-slot-value/gf gf 'methods) found-method)
+ (let ((specializers (standard-slot-value/method method 'specializers))
+ (qualifiers (plist-value method 'qualifiers)))
+ (when (and (null qualifiers)
+ (let ((subcpl (member (ecase type
+ (reader (car specializers))
+ (writer (cadr specializers)))
+ cpl)))
+ (and subcpl (member found-specializer subcpl))))
+ (setf found-specializer (ecase type
+ (reader (car specializers))
+ (writer (cadr specializers))))
+ (setf found-method method))))))
- (early-p (not (eq *boot-state* 'complete)))
- (slot-name (when accessor-class
- (if (consp meth)
- (and (early-method-standard-accessor-p meth)
- (early-method-standard-accessor-slot-name meth))
- (and (member *the-class-std-object*
- (if early-p
- (early-class-precedence-list
- accessor-class)
- (class-precedence-list
- accessor-class)))
- (if early-p
- (not (eq *the-class-standard-method*
- (early-method-class meth)))
- (standard-accessor-method-p meth))
- (if early-p
- (early-accessor-method-slot-name meth)
- (accessor-method-slot-name meth))))))
- (slotd (and accessor-class
- (if early-p
- (dolist (slot (early-class-slotds accessor-class) nil)
- (when (eql slot-name
- (early-slot-definition-name slot))
- (return slot)))
- (find-slot-definition accessor-class slot-name)))))
+ (early-p (not (eq *boot-state* 'complete)))
+ (slot-name (when accessor-class
+ (if (consp meth)
+ (and (early-method-standard-accessor-p meth)
+ (early-method-standard-accessor-slot-name meth))
+ (and (member *the-class-standard-object*
+ (if early-p
+ (early-class-precedence-list
+ accessor-class)
+ (class-precedence-list
+ accessor-class)))
+ (if early-p
+ (not (eq *the-class-standard-method*
+ (early-method-class meth)))
+ (standard-accessor-method-p meth))
+ (if early-p
+ (early-accessor-method-slot-name meth)
+ (accessor-method-slot-name meth))))))
+ (slotd (and accessor-class
+ (if early-p
+ (dolist (slot (early-class-slotds accessor-class) nil)
+ (when (eql slot-name
+ (early-slot-definition-name slot))
+ (return slot)))
+ (find-slot-definition accessor-class slot-name)))))
- (early-method-specializers method t)
- (method-specializers method)))
- (specl (ecase type
- ((reader boundp) (car specializers))
- (writer (cadr specializers))))
- (specl-cpl (if early-p
- (early-class-precedence-list specl)
- (and (class-finalized-p specl)
- (class-precedence-list specl))))
- (so-p (member *the-class-std-object* specl-cpl))
- (slot-name (if (consp method)
- (and (early-method-standard-accessor-p method)
- (early-method-standard-accessor-slot-name
- method))
- (accessor-method-slot-name method))))
- (when (or (null specl-cpl)
- (member *the-class-structure-object* specl-cpl))
- (return-from make-accessor-table nil))
- (maphash (lambda (class slotd)
- (let ((cpl (if early-p
- (early-class-precedence-list class)
- (class-precedence-list class))))
- (when (memq specl cpl)
- (unless (and (or so-p
- (member *the-class-std-object* cpl))
- (or early-p
- (slot-accessor-std-p slotd type)))
- (return-from make-accessor-table nil))
- (push (cons specl slotd) (gethash class table)))))
- (gethash slot-name *name->class->slotd-table*))))
+ (early-method-specializers method t)
+ (method-specializers method)))
+ (specl (ecase type
+ ((reader boundp) (car specializers))
+ (writer (cadr specializers))))
+ (specl-cpl (if early-p
+ (early-class-precedence-list specl)
+ (and (class-finalized-p specl)
+ (class-precedence-list specl))))
+ (so-p (member *the-class-standard-object* specl-cpl))
+ (slot-name (if (consp method)
+ (and (early-method-standard-accessor-p method)
+ (early-method-standard-accessor-slot-name
+ method))
+ (accessor-method-slot-name method))))
+ (when (or (null specl-cpl)
+ (member *the-class-structure-object* specl-cpl))
+ (return-from make-accessor-table nil))
+ (maphash (lambda (class slotd)
+ (let ((cpl (if early-p
+ (early-class-precedence-list class)
+ (class-precedence-list class))))
+ (when (memq specl cpl)
+ (unless (and (or so-p
+ (member *the-class-standard-object*
+ cpl))
+ (or early-p
+ (slot-accessor-std-p slotd type)))
+ (return-from make-accessor-table nil))
+ (push (cons specl slotd) (gethash class table)))))
+ (gethash slot-name *name->class->slotd-table*))))
- (dolist (sclass (if early-p
- (early-class-precedence-list class)
- (class-precedence-list class))
- (error "This can't happen."))
- (let ((a (assq sclass specl+slotd-list)))
- (when a
- (let* ((slotd (cdr a))
- (index (if early-p
- (early-slot-definition-location slotd)
- (slot-definition-location slotd))))
- (unless index (return-from make-accessor-table nil))
- (setf (gethash class table) index)
- (when (consp index) (setq no-class-slots-p nil))
- (setq all-index (if (or (null all-index)
- (eql all-index index))
- index t))
- (incf size)
- (cond ((= size 1) (setq first class))
- ((= size 2) (setq second class)))
- (return nil))))))
- table)
+ (dolist (sclass (if early-p
+ (early-class-precedence-list class)
+ (class-precedence-list class))
+ (error "This can't happen."))
+ (let ((a (assq sclass specl+slotd-list)))
+ (when a
+ (let* ((slotd (cdr a))
+ (index (if early-p
+ (early-slot-definition-location slotd)
+ (slot-definition-location slotd))))
+ (unless index (return-from make-accessor-table nil))
+ (setf (gethash class table) index)
+ (when (consp index) (setq no-class-slots-p nil))
+ (setq all-index (if (or (null all-index)
+ (eql all-index index))
+ index t))
+ (incf size)
+ (cond ((= size 1) (setq first class))
+ ((= size 2) (setq second class)))
+ (return nil))))))
+ table)
- (early-method-specializers method t)
- (method-specializers method)))
- (types types)
- (possibly-applicable-p t) (applicable-p t))
- (dolist (specl specls)
- (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
- (specializer-applicable-using-type-p specl (pop types))
- (unless specl-applicable-p
- (setq applicable-p nil))
- (unless specl-possibly-applicable-p
- (setq possibly-applicable-p nil)
- (return nil))))
- (when possibly-applicable-p
- (unless applicable-p (setq definite-p nil))
- (push method possibly-applicable-methods))))
+ (early-method-specializers method t)
+ (method-specializers method)))
+ (types types)
+ (possibly-applicable-p t) (applicable-p t))
+ (dolist (specl specls)
+ (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
+ (specializer-applicable-using-type-p specl (pop types))
+ (unless specl-applicable-p
+ (setq applicable-p nil))
+ (unless specl-possibly-applicable-p
+ (setq possibly-applicable-p nil)
+ (return nil))))
+ (when possibly-applicable-p
+ (unless applicable-p (setq definite-p nil))
+ (push method possibly-applicable-methods))))
- precedence
- (lambda (class1 class2 index)
- (let* ((class (type-class (nth index types)))
- (cpl (if (eq *boot-state* 'complete)
- (class-precedence-list class)
- (early-class-precedence-list class))))
- (if (memq class2 (memq class1 cpl))
- class1 class2)))))
+ precedence
+ (lambda (class1 class2 index)
+ (let* ((class (type-class (nth index types)))
+ (cpl (if (eq *boot-state* 'complete)
+ (class-precedence-list class)
+ (early-class-precedence-list class))))
+ (if (memq class2 (memq class1 cpl))
+ class1 class2)))))
- (dolist (index precedence)
- (let* ((specl1 (nth index (if (listp method1)
- (early-method-specializers method1
- t)
- (method-specializers method1))))
- (specl2 (nth index (if (listp method2)
- (early-method-specializers method2
- t)
- (method-specializers method2))))
- (order (order-specializers
- specl1 specl2 index compare-classes-function)))
- (when order
- (return-from sorter (eq order specl1)))))))
+ (dolist (index precedence)
+ (let* ((specl1 (nth index (if (listp method1)
+ (early-method-specializers method1
+ t)
+ (method-specializers method1))))
+ (specl2 (nth index (if (listp method2)
+ (early-method-specializers method2
+ t)
+ (method-specializers method2))))
+ (order (order-specializers
+ specl1 specl2 index compare-classes-function)))
+ (when order
+ (return-from sorter (eq order specl1)))))))
- (declare (ignore index))
- (let ((choice nil))
- (dolist (c choices nil)
- (when (or (and (eq (first c) class1)
- (eq (second c) class2))
- (and (eq (first c) class2)
- (eq (second c) class1)))
- (return (setq choice c))))
- (unless choice
- (setq choice
- (if (class-might-precede-p class1 class2)
- (if (class-might-precede-p class2 class1)
- (list class1 class2 nil t)
- (list class1 class2 t))
- (if (class-might-precede-p class2 class1)
- (list class2 class1 t)
- (let ((name1 (class-name class1))
- (name2 (class-name class2)))
- (if (and name1
- name2
- (symbolp name1)
- (symbolp name2)
- (string< (symbol-name name1)
- (symbol-name name2)))
- (list class1 class2 t)
- (list class2 class1 t))))))
- (push choice choices))
- (car choice))))
+ (declare (ignore index))
+ (let ((choice nil))
+ (dolist (c choices nil)
+ (when (or (and (eq (first c) class1)
+ (eq (second c) class2))
+ (and (eq (first c) class2)
+ (eq (second c) class1)))
+ (return (setq choice c))))
+ (unless choice
+ (setq choice
+ (if (class-might-precede-p class1 class2)
+ (if (class-might-precede-p class2 class1)
+ (list class1 class2 nil t)
+ (list class1 class2 t))
+ (if (class-might-precede-p class2 class1)
+ (list class2 class1 t)
+ (let ((name1 (class-name class1))
+ (name2 (class-name class2)))
+ (if (and name1
+ name2
+ (symbolp name1)
+ (symbolp name2)
+ (string< (symbol-name name1)
+ (symbol-name name2)))
+ (list class1 class2 t)
+ (list class2 class1 t))))))
+ (push choice choices))
+ (car choice))))
- (sort-methods methods
- precedence
- #'compare-classes-function))
- (unless (dolist (c choices nil)
- (unless (third c)
- (rotatef (car c) (cadr c))
- (return (setf (third c) t))))
- (return nil))))))
-
-(defvar *in-precompute-effective-methods-p* nil)
-
-;used only in map-all-orders
+ (sort-methods methods
+ precedence
+ #'compare-classes-function))
+ (unless (dolist (c choices nil)
+ (unless (third c)
+ (rotatef (car c) (cadr c))
+ (return (setf (third c) t))))
+ (return nil))))))
+
+;;; CMUCL comment: used only in map-all-orders
- (when (class-finalized-p class)
+ ;; KLUDGE: why not use (slot-boundp class
+ ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
+ ;; used within COMPUTE-APPLICABLE-METHODS, including for
+ ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for
+ ;; breaking such nasty cycles in effective method computation
+ ;; only works for readers and writers, not boundps. It might
+ ;; not be too hard to make it work for BOUNDP accessors, but in
+ ;; the meantime we use an extra slot for exactly the result of
+ ;; the SLOT-BOUNDP that we want. (We cannot use
+ ;; CLASS-FINALIZED-P, because in the process of class
+ ;; finalization we need to use the CPL which has been computed
+ ;; to cache effective methods for slot accessors.) -- CSR,
+ ;; 2004-09-19.
+ (when (cpl-available-p class)
- (case (car ntype)
- (class (saut-not-class specl ntype))
- (class-eq (saut-not-class-eq specl ntype))
- (prototype (saut-not-prototype specl ntype))
- (eql (saut-not-eql specl ntype))
- (t (error "~S cannot handle the second argument ~S"
- 'specializer-applicable-using-type-p type))))))
+ (case (car ntype)
+ (class (saut-not-class specl ntype))
+ (class-eq (saut-not-class-eq specl ntype))
+ (prototype (saut-not-prototype specl ntype))
+ (eql (saut-not-eql specl ntype))
+ (t (error "~S cannot handle the second argument ~S"
+ 'specializer-applicable-using-type-p type))))))
- (and (saut-and specl type))
- (not (saut-not specl type))
- (class (saut-class specl type))
- (prototype (saut-prototype specl type))
- (class-eq (saut-class-eq specl type))
- (eql (saut-eql specl type))
- (t (error "~S cannot handle the second argument ~S."
- 'specializer-applicable-using-type-p
- type)))))
+ (and (saut-and specl type))
+ (not (saut-not specl type))
+ (class (saut-class specl type))
+ (prototype (saut-prototype specl type))
+ (class-eq (saut-class-eq specl type))
+ (eql (saut-eql specl type))
+ (t (error "~S cannot handle the second argument ~S."
+ 'specializer-applicable-using-type-p
+ type)))))
- (lambda (method-alist wrappers)
- (declare (ignore method-alist wrappers))
- #'(instance-lambda (&rest args)
- (apply #'no-applicable-method gf args)))
- (lambda (method-alist wrappers)
- (declare (ignore method-alist wrappers))
- (lambda (&rest args)
- (apply #'no-applicable-method gf args))))
+ (lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ #'(lambda (&rest args)
+ (apply #'no-applicable-method gf args)))
+ (lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ (lambda (&rest args)
+ (apply #'no-applicable-method gf args))))
- (ht-value (or (gethash key *effective-method-cache*)
- (setf (gethash key *effective-method-cache*)
- (cons nil nil)))))
- (if (and (null (cdr methods)) all-applicable-p ; the most common case
- (null method-alist-p) wrappers-p (not function-p))
- (or (car ht-value)
- (setf (car ht-value)
- (get-secondary-dispatch-function2
- gf methods types method-alist-p wrappers-p
- all-applicable-p all-sorted-p function-p)))
- (let ((akey (list methods
- (if all-applicable-p 'all-applicable types)
- method-alist-p wrappers-p function-p)))
- (or (cdr (assoc akey (cdr ht-value) :test #'equal))
- (let ((value (get-secondary-dispatch-function2
- gf methods types method-alist-p wrappers-p
- all-applicable-p all-sorted-p function-p)))
- (push (cons akey value) (cdr ht-value))
- value)))))))
+ (ht-value (or (gethash key *effective-method-cache*)
+ (setf (gethash key *effective-method-cache*)
+ (cons nil nil)))))
+ (if (and (null (cdr methods)) all-applicable-p ; the most common case
+ (null method-alist-p) wrappers-p (not function-p))
+ (or (car ht-value)
+ (setf (car ht-value)
+ (get-secondary-dispatch-function2
+ gf methods types method-alist-p wrappers-p
+ all-applicable-p all-sorted-p function-p)))
+ (let ((akey (list methods
+ (if all-applicable-p 'all-applicable types)
+ method-alist-p wrappers-p function-p)))
+ (or (cdr (assoc akey (cdr ht-value) :test #'equal))
+ (let ((value (get-secondary-dispatch-function2
+ gf methods types method-alist-p wrappers-p
+ all-applicable-p all-sorted-p function-p)))
+ (push (cons akey value) (cdr ht-value))
+ value)))))))
- (let* ((combin (generic-function-method-combination gf))
- (effective (compute-effective-method gf combin methods)))
- (make-effective-method-function1 gf effective method-alist-p
- wrappers-p))
- (let ((effective (standard-compute-effective-method gf nil methods)))
- (make-effective-method-function1 gf effective method-alist-p
- wrappers-p)))
+ (let* ((combin (generic-function-method-combination gf))
+ (effective (compute-effective-method gf combin methods)))
+ (make-effective-method-function1 gf effective method-alist-p
+ wrappers-p))
+ (let ((effective (standard-compute-effective-method gf nil methods)))
+ (make-effective-method-function1 gf effective method-alist-p
+ wrappers-p)))