(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~@:>"
+ (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~@:>"
+ (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)
;;; considered as state transitions.
(defvar *lazy-dfun-compute-p* t)
(defvar *early-p* nil)
-(defvar *max-emf-precomputation-methods* 10)
+
+(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*))
+(defvar *max-emf-precomputation-methods* nil)
(defun finalize-specializers (gf)
(let ((methods (generic-function-methods gf)))
- (when (<= (length methods) *max-emf-precomputation-methods*)
+ (when (or (null *max-emf-precomputation-methods*)
+ (<= (length methods) *max-emf-precomputation-methods*))
(let ((all-finalized t))
(dolist (method methods all-finalized)
(dolist (specializer (method-specializers method))
;;; 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)))))
+ (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))))))
(defun accessor-values (gf arg-info classes methods)
(declare (ignore gf))
(return (setf (third c) t))))
(return nil))))))
-(defvar *in-precompute-effective-methods-p* nil)
-
-;used only in map-all-orders
+;;; CMUCL comment: used only in map-all-orders
(defun class-might-precede-p (class1 class2)
(if (not *in-precompute-effective-methods-p*)
(not (member class1 (cdr (class-precedence-list class2))))
(defun cpl-or-nil (class)
(if (eq *boot-state* 'complete)
- (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)
(class-precedence-list class))
(early-class-precedence-list class)))