And so, we are saved.
+Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
+
|#
\f
;;; an alist in which each entry is of the form
collect))))
(nreverse collect)))))
\f
+;;; Standardized class slot access: when trying to break vicious
+;;; metacircles, we need a way to get at the values of slots of some
+;;; standard classes without going through the whole meta machinery,
+;;; because that would likely enter the vicious circle again. The
+;;; following are helper functions that short-circuit the generic
+;;; lookup machinery.
+
+(defvar *standard-classes*
+ '(standard-method standard-generic-function standard-class
+ standard-effective-slot-definition))
+
+(defvar *standard-slot-locations* (make-hash-table :test 'equal))
+
+(defun compute-standard-slot-locations ()
+ (clrhash *standard-slot-locations*)
+ (dolist (class-name *standard-classes*)
+ (let ((class (find-class class-name)))
+ (dolist (slot (class-slots class))
+ (setf (gethash (cons class (slot-definition-name slot))
+ *standard-slot-locations*)
+ (slot-definition-location slot))))))
+
+;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS
+;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS.
+(defun maybe-update-standard-class-locations (class)
+ (when (and (eq *boot-state* 'complete)
+ (memq (class-name class) *standard-classes*))
+ (compute-standard-slot-locations)))
+
+(defun standard-slot-value (object slot-name class)
+ (let ((location (gethash (cons class slot-name) *standard-slot-locations*)))
+ (if location
+ (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))))
+
+(defun standard-slot-value/gf (gf slot-name)
+ (standard-slot-value gf slot-name *the-class-standard-generic-function*))
+
+(defun standard-slot-value/method (method slot-name)
+ (standard-slot-value method slot-name *the-class-standard-method*))
+
+(defun standard-slot-value/eslotd (slotd slot-name)
+ (standard-slot-value slotd slot-name
+ *the-class-standard-effective-slot-definition*))
+
+(defun standard-slot-value/class (class slot-name)
+ (standard-slot-value class slot-name *the-class-standard-class*))
+\f
;;; When all the methods of a generic function are automatically
;;; generated reader or writer methods a number of special
;;; optimizations are possible. These are important because of the
(defun accessor-miss-function (gf dfun-info)
(ecase (dfun-info-accessor-type dfun-info)
- (reader
+ ((reader boundp)
(lambda (arg)
(accessor-miss gf nil arg dfun-info)))
(writer
#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
\f
(defun make-one-class-accessor-dfun (gf type wrapper index)
- (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-one-class-reader)
+ (boundp 'emit-one-class-boundp)
+ (writer 'emit-one-class-writer)))
(dfun-info (one-class-dfun-info type index wrapper)))
(values
(funcall (get-dfun-constructor emit (consp index))
dfun-info)))
(defun make-two-class-accessor-dfun (gf type w0 w1 index)
- (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-two-class-reader)
+ (boundp 'emit-two-class-boundp)
+ (writer 'emit-two-class-writer)))
(dfun-info (two-class-dfun-info type index w0 w1)))
(values
(funcall (get-dfun-constructor emit (consp index))
;;; std accessors same index dfun
(defun make-one-index-accessor-dfun (gf type index &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-one-index-readers)
+ (boundp 'emit-one-index-boundps)
+ (writer 'emit-one-index-writers)))
(cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
(dfun-info (one-index-dfun-info type index cache)))
(declare (type cache cache))
(default-limit-fn nlines))
(defun make-n-n-accessor-dfun (gf type &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-n-n-readers)
+ (boundp 'emit-n-n-boundps)
+ (writer 'emit-n-n-writers)))
(cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
(dfun-info (n-n-dfun-info type cache)))
(declare (type cache cache))
(default '(unknown)))
(and (null applyp)
(or (not (eq *boot-state* 'complete))
- (compute-applicable-methods-emf-std-p gf))
- (notany (lambda (method)
- (or (and (eq *boot-state* 'complete)
- (some #'eql-specializer-p
- (method-specializers method)))
- (let ((value (method-function-get
- (if early-p
- (or (third method) (second method))
- (or (method-fast-function method)
- (method-function method)))
- :constant-value default)))
- (if boolean-values-p
- (not (or (eq value t) (eq value nil)))
- (eq value default)))))
- methods)))))
+ ;; 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))))))))
(defun make-constant-value-dfun (generic-function &optional cache)
(multiple-value-bind (nreq applyp metatypes nkeys)
(maphash (lambda (classes value)
(setq cache (fill-cache cache
(class-wrapper classes)
- value
- t)))
+ value)))
table)
cache))
(cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
(type 'accessor)
(t 'checking)))
- (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
- (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
- ,@body))
- (invoke-emf ,nemf ,args)))
+ (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+ (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
+ ,@body))
+ ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
+ ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
+ ;; does not signal a SLOT-UNBOUND error for a boundp test.
+ ,@(if type
+ ;; 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)))))
;;; The dynamically adaptive method lookup algorithm is implemented is
;;; implemented as a kind of state machine. The kinds of
;;; considered as state transitions.
(defvar *lazy-dfun-compute-p* t)
(defvar *early-p* nil)
+(defvar *max-emf-precomputation-methods* 0)
+
+(defun finalize-specializers (gf)
+ (let ((methods (generic-function-methods gf)))
+ (when (< (length methods) *max-emf-precomputation-methods*)
+ (let ((all-finalized t))
+ (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)))))))))
(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))))
- (writer #'(sb-kernel:instance-lambda (new-value 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 #'(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)
((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)))
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)))
(let* ((ostate (type-of dfun-info))
(otype (dfun-info-accessor-type dfun-info))
oindex ow0 ow1 cache
- (args (ecase otype ; The congruence rules ensure
- (reader (list object)) ; that this is safe despite not
- (writer (list new object))))) ; knowing the new type yet.
+ (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
(defun constant-value-miss (generic-function args dfun-info)
(let ((ocache (dfun-info-cache dfun-info)))
(dfun-miss (generic-function args wrappers invalidp emf nil nil t)
- (cond (invalidp)
- (t
- (let* ((function (typecase emf
- (fast-method-call (fast-method-call-function
- emf))
- (method-call (method-call-function emf))))
- (value (method-function-get function :constant-value))
- (ncache (fill-cache ocache wrappers value)))
- (unless (eq ncache ocache)
- (dfun-update generic-function
- #'make-constant-value-dfun ncache))))))))
+ (unless invalidp
+ (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)))))))
\f
;;; Given a generic function and a set of arguments to that generic
;;; function, return a mess of values.
;;; <index> If <type> is READER or WRITER, and the slot accessed is
;;; an :instance slot, this is the index number of that slot
;;; in the object argument.
+(defvar *cache-miss-values-stack* ())
+
(defun cache-miss-values (gf args state)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
(get-generic-fun-info gf)
accessor-type index)))))
(defun cache-miss-values-internal (gf arg-info wrappers classes types state)
+ (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*))))
+ (break-vicious-metacircle gf classes arg-info)
+ (let ((*cache-miss-values-stack*
+ (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))
+
(let* ((for-accessor-p (eq state 'accessor))
(for-cache-p (or (eq state 'caching) (eq state 'accessor)))
- (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))
- (let ((emf (if (or cam-std-p all-applicable-and-sorted-p)
- (function-funcall (get-secondary-dispatch-function1
- gf methods types nil (and for-cache-p
- wrappers)
- all-applicable-and-sorted-p)
- nil (and for-cache-p wrappers))
- (default-secondary-dispatch-function gf))))
- (multiple-value-bind (index accessor-type)
- (and for-accessor-p all-applicable-and-sorted-p methods
- (accessor-values gf arg-info classes methods))
- (values (if (integerp index) index emf)
- methods accessor-type index))))))
+ (emf (if (or cam-std-p all-applicable-and-sorted-p)
+ (function-funcall (get-secondary-dispatch-function1
+ gf methods types nil (and for-cache-p
+ wrappers)
+ all-applicable-and-sorted-p)
+ nil (and for-cache-p wrappers))
+ (default-secondary-dispatch-function gf))))
+ (multiple-value-bind (index accessor-type)
+ (and for-accessor-p all-applicable-and-sorted-p methods
+ (accessor-values gf arg-info classes methods))
+ (values (if (integerp index) index emf)
+ methods accessor-type index)))))))
+
+;;; Try to break a vicious circle while computing a cache miss.
+;;; GF is the generic function, CLASSES are the classes of actual
+;;; arguments, and ARG-INFO is the generic functions' arg-info.
+;;;
+;;; A vicious circle can be entered when the computation of the cache
+;;; miss values itself depends on the values being computed. For
+;;; instance, adding a method which is an instance of a subclass of
+;;; STANDARD-METHOD leads to cache misses for slot accessors of
+;;; STANDARD-METHOD like METHOD-SPECIALIZERS, and METHOD-SPECIALIZERS
+;;; is itself used while we compute cache miss values.
+(defun break-vicious-metacircle (gf classes arg-info)
+ (when (typep gf 'standard-generic-function)
+ (multiple-value-bind (class slotd accessor-type)
+ (accesses-standard-class-slot-p gf)
+ (when class
+ (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)))))))
+ (error "~@<vicious metacircle: The computation of an ~
+ effective method of ~s for arguments of types ~s uses ~
+ the effective method being computed.~@:>"
+ gf classes))
+
+;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic
+;;; function GF accesses a slot of some class in *STANDARD-CLASSES*.
+;;; CLASS is the class accessed, SLOTD is the effective slot definition
+;;; object of the slot accessed, and ACCESSOR-TYPE is one of the symbols
+;;; READER or WRITER describing the slot access.
+(defun accesses-standard-class-slot-p (gf)
+ (flet ((standard-class-slot-access (gf class)
+ (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 (class-name *standard-classes*)
+ (let ((class (find-class class-name)))
+ (multiple-value-bind (slotd accessor-type)
+ (standard-class-slot-access gf class)
+ (when slotd
+ (return (values class slotd accessor-type))))))))
+
+;;; Find a slot reader/writer method among the methods of generic
+;;; 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)
+ (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)))))
(defun accessor-values (gf arg-info classes methods)
(declare (ignore gf))
(let* ((accessor-type (gf-info-simple-accessor-type arg-info))
(accessor-class (case accessor-type
- (reader (car classes))
- (writer (cadr classes))
- (boundp (car classes)))))
+ ((reader boundp) (car classes))
+ (writer (cadr classes)))))
(accessor-values-internal accessor-type accessor-class methods)))
(defun accessor-values1 (gf accessor-type accessor-class)
(let* ((type `(class-eq ,accessor-class))
- (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+ (types (ecase accessor-type
+ ((reader boundp) `(,type))
+ (writer `(t ,type))))
(methods (compute-applicable-methods-using-types gf types)))
(accessor-values-internal accessor-type accessor-class methods)))
(let* ((specializers (if (consp method)
(early-method-specializers method t)
(method-specializers method)))
- (specl (if (eq type 'reader)
- (car specializers)
- (cadr specializers)))
+ (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)
(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