0.7.9.14:

	Fix overeager checking for duplicate primary methods in
		non-standard method combinations
		(entomotomy reference:
		define-method-combination-duplicate-method-checking-too-eager
		once someone gets round to creating that page)
	... thanks to Wolfhard Buss and Gerd Moellmann
	Comment (adapted from Gerd Moellmann) explaining the paths taken
		to get to SB-PCL::FORCE-CACHE-FLUSHES

src/pcl/defcombin.lisp

@@ -274,14 +274,15 @@
  (push name names)
  (push specializer-cache specializer-caches)
  (push `((or ,@tests)
- (if (equal ,specializer-cache .specializers.)
- (return-from .long-method-combination-function.
- '(error "More than one method of type ~S ~
+ (if (and (equal ,specializer-cache .specializers.)
+ (not (null .specializers.)))
+ (return-from .long-method-combination-function.
+ '(error "More than one method of type ~S ~
  with the same specializers."
-   ',name))
-  (setq ,specializer-cache .specializers.))
-  (push .method. ,name))
-  cond-clauses)
+   ',name))
+ (setq ,specializer-cache .specializers.))
+ (push .method. ,name))
+ cond-clauses)
  (when required
  (push `(when (null ,name)
  (return-from .long-method-combination-function.
@@ -304,7 +305,7 @@
  (dolist (.method. .applicable-methods.)
  (let ((.qualifiers. (method-qualifiers .method.))
  (.specializers. (method-specializers .method.)))
- (progn .qualifiers. .specializers.)
+ (declare (ignorable .qualifiers. .specializers.))
  (cond ,@(nreverse cond-clauses))))
  ,@(nreverse required-checks)
  ,@(nreverse order-cleanups)

src/pcl/std-class.lisp

@@ -1048,6 +1048,25 @@
  (or (eq new-super-meta-class *the-class-std-class*)
  (eq (class-of class) new-super-meta-class))))
 
+;;; What this does depends on which of the four possible values of
+;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
+;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
+;;; nothing to do, as the new wrapper has already been created. If
+;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
+;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
+;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
+;;;
+;;; This leaves the case where LAYOUT-INVALID returns T, which happens
+;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
+;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
+;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
+;;; obsolete the wrapper.
+;;;
+;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
+;;; for (AVER (NOT (EQ (SB-KERNEL:LAYOUT-INVALID OWRAPPER)
+;;; :UNINITIALIZED)))
+;;;
+;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
 (defun force-cache-flushes (class)
  (let* ((owrapper (class-wrapper class)))
  ;; We only need to do something if the wrapper is still valid. If
@@ -1056,10 +1075,10 @@
  ;; particular, we must be sure we never change an OBSOLETE into a
  ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
  (when (or (not (invalid-wrapper-p owrapper))
- ;; Ick. LAYOUT-INVALID can return a list (which we can
- ;; handle), T (which we can't), NIL (which is handled by
- ;; INVALID-WRAPPER-P) or :UNINITIALIZED (which never
- ;; gets here (I hope). -- CSR, 2002-10-28
+ ;; KLUDGE: despite the observations above, this remains
+ ;; a violation of locality or what might be considered
+ ;; good style. There has to be a better way! -- CSR,
+ ;; 2002-10-29
  (eq (sb-kernel:layout-invalid owrapper) t))
  (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
  class)))

tests/clos.impure.lisp

@@ -342,6 +342,30 @@
 (defclass c176-0 (b176) ())
 (assert (= 1 (setf (slot-value (make-instance 'c176-9) 'aslot-176) 1)))
 
+;;; DEFINE-METHOD-COMBINATION was over-eager at checking for duplicate
+;;; primary methods:
+(define-method-combination dmc-test-mc (&optional (order :most-specific-first))
+ ((around (:around))
+ (primary (dmc-test-mc) :order order :required t))
+ (let ((form (if (rest primary)
+ `(and ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ primary))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))
+ form)))
+
+(defgeneric dmc-test-mc (&key k)
+ (:method-combination dmc-test-mc))
+
+(defmethod dmc-test-mc dmc-test-mc (&key k)
+ k)
+
+(dmc-test-mc :k 1)
+
 ;;;; success
 
 (sb-ext:quit :unix-status 104)

version.lisp-expr

@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.13"
+"0.7.9.14"