From 2fe7ca730f378505f86a7553462fa3241185d444 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 30 Oct 2002 12:25:49 +0000 Subject: [PATCH] 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 | 17 +++++++++-------- src/pcl/std-class.lisp | 27 +++++++++++++++++++++++---- tests/clos.impure.lisp | 24 ++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 57 insertions(+), 13 deletions(-) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 5d173bd..97472ca 100644 --- a/src/pcl/defcombin.lisp +++ b/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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ef6f9cf..cfa1c62 100644 --- a/src/pcl/std-class.lisp +++ b/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 ) or (:OBSOLETE ), 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 ); UPDATE-SLOTS later gets to choose whether or +;;; not to "upgrade" this to (:OBSOLETE ). +;;; +;;; 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))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index b08b1d9..b4462cd 100644 --- a/tests/clos.impure.lisp +++ b/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) diff --git a/version.lisp-expr b/version.lisp-expr index e697733..3ee10d7 100644 --- a/version.lisp-expr +++ b/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" -- 1.7.10.4