- (let* ((ostate (type-of dfun-info))
- (otype (dfun-info-accessor-type dfun-info))
- oindex ow0 ow1 cache
- (args (ecase otype
- ;; The congruence rules ensure that this is safe
- ;; despite not knowing the new type yet.
- ((reader boundp) (list object))
- (writer (list new object)))))
- (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-
- ;; The following lexical functions change the state of the
- ;; dfun to that which is their name. They accept arguments
- ;; which are the parameters of the new state, and get other
- ;; information from the lexical variables bound above.
- (flet ((two-class (index w0 w1)
- (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 ((wrapper (wrapper-of object))
+ (previous-miss (assq gf *accessor-miss-history*)))
+ (when (eq wrapper (cdr previous-miss))
+ (error "~@<Vicious metacircle: The computation of a ~
+ dfun of ~s for argument ~s uses the dfun being ~
+ computed.~@:>"
+ gf object))
+ (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
+ (ostate (type-of dfun-info))
+ (otype (dfun-info-accessor-type dfun-info))
+ oindex ow0 ow1 cache
+ (args (ecase otype
+ ((reader boundp) (list object))
+ (writer (list new object)))))
+ (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
+ ;; The following lexical functions change the state of the
+ ;; dfun to that which is their name. They accept arguments
+ ;; which are the parameters of the new state, and get other
+ ;; information from the lexical variables bound above.
+ (flet ((two-class (index w0 w1)
+ (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)))))))))))