(defun make-final-checking-dfun (generic-function function
classes-list new-class)
- (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-fun-info generic-function)
+ (declare (ignore nreq applyp nkeys))
(if (every (lambda (mt) (eq mt t)) metatypes)
(values (lambda (&rest args)
(invoke-emf function args))
(some (lambda (method)
(let ((fmf (if (listp method)
(third method)
- (method-fast-function method))))
+ (safe-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
(dolist (method methods t)
(when (eq *boot-state* 'complete)
(when (or (some #'eql-specializer-p
- (method-specializers method))
- (method-qualifiers method))
+ (safe-method-specializers method))
+ (safe-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)))
+ (or (safe-method-fast-function method)
+ (safe-method-function method)))
:constant-value default)))
(when (or (eq value default)
(and boolean-values-p
(defparameter *secondary-dfun-call-cost* 1)
(defun caching-dfun-cost (gf)
- (let* ((arg-info (gf-arg-info gf))
- (nreq (length (arg-info-metatypes arg-info))))
+ (let ((nreq (get-generic-fun-info gf)))
(+ *cache-lookup-cost*
(* *wrapper-of-cost* nreq)
(if (methods-contain-eql-specializer-p
(t
(make-final-caching-dfun gf classes-list new-class)))))
+(defvar *accessor-miss-history* nil)
+
(defun accessor-miss (gf new object dfun-info)
- (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))
+ (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 *pcl-misc-random-state*))
+ (psetf w0 w1 w1 w0))
(dfun-update gf
#'make-two-class-accessor-dfun
ntype
(setq cache (dfun-info-cache dfun-info))
(if (consp nindex)
(caching)
- (do-fill #'n-n))))))))))
+ (do-fill #'n-n)))))))))))
(defun checking-miss (generic-function args dfun-info)
(let ((oemf (dfun-info-function dfun-info))
;;; function GF which reads/writes instances of class CLASS.
;;; TYPE is one of the symbols READER or WRITER.
(defun find-standard-class-accessor-method (gf class type)
- (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+ (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)
method))
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
+ (null so-p)
(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)))
+ ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
+ ;; all of its subclasses. If either SPECL or one of the subclasses
+ ;; is not a standard-class, bail out.
+ (labels ((aux (class)
+ ;; FIND-SLOT-DEFINITION might not be defined yet
+ (let ((slotd (find-if (lambda (x)
+ (eq (sb-pcl::slot-definition-name x)
+ slot-name))
+ (sb-pcl::class-slots class))))
+ (when slotd
+ (unless (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*))))
+ (push (cons specl slotd) (gethash class table))))
+ (dolist (subclass (sb-pcl::class-direct-subclasses class))
+ (aux subclass))))
+ (aux specl))))
(maphash (lambda (class specl+slotd-list)
(dolist (sclass (if early-p
(early-class-precedence-list class)
(let ((definite-p t) (possibly-applicable-methods nil))
(dolist (method (if (early-gf-p generic-function)
(early-gf-methods generic-function)
- (generic-function-methods generic-function)))
+ (safe-generic-function-methods generic-function)))
(let ((specls (if (consp method)
(early-method-specializers method t)
- (method-specializers method)))
+ (safe-method-specializers method)))
(types types)
(possibly-applicable-p t) (applicable-p t))
(dolist (specl specls)
(when possibly-applicable-p
(unless applicable-p (setq definite-p nil))
(push method possibly-applicable-methods))))
- (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
- (early-gf-arg-info
- generic-function)
- (gf-arg-info
- generic-function)))))
- (values (sort-applicable-methods precedence
- (nreverse possibly-applicable-methods)
- types)
- definite-p))))
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-fun-info generic-function)
+ (declare (ignore nreq applyp metatypes nkeys))
+ (let* ((precedence (arg-info-precedence arg-info)))
+ (values (sort-applicable-methods precedence
+ (nreverse possibly-applicable-methods)
+ types)
+ definite-p)))))
(defun sort-applicable-methods (precedence methods types)
(sort-methods methods
(defun order-specializers (specl1 specl2 index compare-classes-function)
(let ((type1 (if (eq *boot-state* 'complete)
(specializer-type specl1)
- (!bootstrap-get-slot 'specializer specl1 'type)))
+ (!bootstrap-get-slot 'specializer specl1 '%type)))
(type2 (if (eq *boot-state* 'complete)
(specializer-type specl2)
- (!bootstrap-get-slot 'specializer specl2 'type))))
+ (!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
nil)
((atom type1)
'specializer-applicable-using-type-p
type)))))
-(defun map-all-classes (function &optional (root t))
- (let ((braid-p (or (eq *boot-state* 'braid)
+(defun map-all-classes (fun &optional (root t))
+ (let ((all-classes (make-hash-table :test 'eq))
+ (braid-p (or (eq *boot-state* 'braid)
(eq *boot-state* 'complete))))
(labels ((do-class (class)
- (mapc #'do-class
- (if braid-p
- (class-direct-subclasses class)
- (early-class-direct-subclasses class)))
- (funcall function class)))
+ (unless (gethash class all-classes)
+ (setf (gethash class all-classes) t)
+ (funcall fun class)
+ (mapc #'do-class
+ (if braid-p
+ (class-direct-subclasses class)
+ (early-class-direct-subclasses class))))))
(do-class (if (symbolp root)
(find-class root)
- root)))))
+ root)))
+ nil))
\f
(defvar *effective-method-cache* (make-hash-table :test 'eq))
(return t)))))
\f
(defun update-dfun (generic-function &optional dfun cache info)
- (let* ((early-p (early-gf-p generic-function))
- (gf-name (if early-p
- (!early-gf-name generic-function)
- (generic-function-name generic-function))))
+ (let* ((early-p (early-gf-p 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-function generic-function dfun)
- (set-fun-name generic-function gf-name)
- dfun)))
+ (let ((gf-name (if early-p
+ (!early-gf-name generic-function)
+ (generic-function-name generic-function))))
+ (set-fun-name generic-function gf-name)
+ dfun))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)