One bug was a simple harmless thinko, limiting the cache for validity
checking of reinitialize-instance initargs to only one list of keys.
The other is actually a correctness problem: addition or removal of
methods on MAKE-INSTANCE and ALLOCATE-INSTANCE would invalidate the
wrong set of initarg validity caches and reset the wrong ctors. I
think at the moment this bug is tricky to trigger, because those
methods have no effect on reinitialize-instance initarg checking, and
fallback ctors on non-standard metaclasses are very conservative in
their assumptions.
(flet ((class-of-1st-method-param (method)
(type-class (first (method-specializers method)))))
(case (generic-function-name generic-function)
(flet ((class-of-1st-method-param (method)
(type-class (first (method-specializers method)))))
(case (generic-function-name generic-function)
- ((make-instance allocate-instance
- initialize-instance shared-initialize)
+ ((make-instance allocate-instance)
+ ;; FIXME: I can't see a way of working out which classes a
+ ;; given metaclass specializer are applicable to short of
+ ;; iterating and testing with class-of. It would be good
+ ;; to not invalidate caches of system classes at this
+ ;; point (where it is not legal to define a method
+ ;; applicable to them on system functions). -- CSR,
+ ;; 2010-07-13
+ (reset (find-class 'standard-object) t t))
+ ((initialize-instance shared-initialize)
(reset (class-of-1st-method-param method) t t))
((reinitialize-instance)
(reset (class-of-1st-method-param method) t nil))
(reset (class-of-1st-method-param method) t t))
((reinitialize-instance)
(reset (class-of-1st-method-param method) t nil))
(defun check-ri-initargs (instance initargs)
(let* ((class (class-of instance))
(keys (plist-keys initargs))
(defun check-ri-initargs (instance initargs)
(let* ((class (class-of instance))
(keys (plist-keys initargs))
- (cached (assoc keys (plist-value class 'ri-initargs)
- :test #'equal))
+ (cache (plist-value class 'ri-initargs))
+ (cached (assoc keys cache :test #'equal))
(invalid-keys
(if (consp cached)
(cdr cached)
(invalid-keys
(if (consp cached)
(cdr cached)
(list* 'shared-initialize instance nil initargs))
t nil)))
(setf (plist-value class 'ri-initargs)
(list* 'shared-initialize instance nil initargs))
t nil)))
(setf (plist-value class 'ri-initargs)
- (acons keys invalid cached))
+ (acons keys invalid cache))
invalid))))
(when invalid-keys
(error 'initarg-error :class class :initargs invalid-keys))))
invalid))))
(when invalid-keys
(error 'initarg-error :class class :initargs invalid-keys))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)