0.9.15.12:

	Fix longstanding Haiblebug "method combination types that make
	use of MAKE-METHOD don't work with user-defined method classes"
	(sbcl-devel 2004-06-11)
	... in a cheating way; special-case the second argument to
		call-method, which probably isn't completely
                MOP-friendly but does seem to play nice with the test
                cases I can construct that don't change the semantics of
                call-method.
        ... test cases from Pascal Costanza and Bruno Haible

diff --git a/NEWS b/NEWS
index ddbcf78..1478cfb 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,9 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15:
   * bug fix: improved the handling of type declarations and the
     detection of violations for keyword arguments with non-constant
     defaults.
+  * bug fix: use of MAKE-METHOD in method combination now works even
+    in the presence of user-defined method classes.  (reported by
+    Bruno Haible and Pascal Costanza)
 
 changes in sbcl-0.9.15 relative to sbcl-0.9.14:
   * added support for the ucs-2 external format.  (contributed by Ivan

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 759e710..cfce81d 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -135,8 +135,39 @@
                                  :next-method-call next
                                  :arg-info arg-info))
         (if real-mf-p
-            (make-method-call :function mf
-                              :call-method-args cm-args)
+            (flet ((frob-cm-arg (arg)
+                     (if (if (listp arg)
+                             (eq (car arg) :early-method)
+                             (method-p arg))
+                         arg
+                         (if (and (consp arg) (eq (car arg) 'make-method))
+                             (make-instance 'standard-method
+                                            :specializers nil ; XXX
+                                            :qualifiers nil
+                                            :fast-function (fast-method-call-function
+                                                            (make-effective-method-function
+                                                             gf (cadr arg) method-alist wrappers)))
+                             arg))))
+              (make-method-call :function mf
+                                ;; FIXME: this is wrong.  Very wrong.
+                                ;; It assumes that the only place that
+                                ;; can have make-method calls is in
+                                ;; the list structure of the second
+                                ;; argument to CALL-METHOD, but AMOP
+                                ;; says that CALL-METHOD can be more
+                                ;; complicated if
+                                ;; COMPUTE-EFFECTIVE-METHOD (and
+                                ;; presumably MAKE-METHOD-LAMBDA) is
+                                ;; adjusted to match.
+                                ;;
+                                ;; On the other hand, it's a start,
+                                ;; because without this calls to
+                                ;; MAKE-METHOD in method combination
+                                ;; where one of the methods is of a
+                                ;; user-defined class don't work at
+                                ;; all.  -- CSR, 2006-08-05
+                                :call-method-args (cons (mapcar #'frob-cm-arg (car cm-args))
+                                                        (cdr cm-args))))
             mf))))
 
 (defun make-effective-method-function-simple1

diff --git a/tests/mop-20.impure-cload.lisp b/tests/mop-20.impure-cload.lisp
new file mode 100644 (file)
index 0000000..8f1a6af
--- /dev/null
+++ b/tests/mop-20.impure-cload.lisp
@@ -0,0 +1,149 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file tests that user-defined methods can be used in
+;;; combination (ahem) with hairy bits of method-combination.
+
+(defpackage "MOP-20"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-20")
+
+;;; Simple test case from Pascal Costanza
+(defgeneric test (arg)
+  (:method (arg) (format t "~D" arg) arg))
+
+(defun define-around-test ()
+  (multiple-value-bind
+        (method-lambda method-args)
+      (make-method-lambda
+       #'test (class-prototype (generic-function-method-class #'test))
+       '(lambda (arg) (call-next-method)) ())
+    (let ((method (apply #'make-instance
+                         (generic-function-method-class #'test)
+                         :qualifiers '(:around)
+                         :lambda-list '(arg)
+                         :specializers (list (find-class 't))
+                         :function (compile nil method-lambda)
+                         method-args)))
+      (add-method #'test method))))
+
+(defun run-test ()
+  (define-around-test)
+  (test 42))
+
+(assert (string= (with-output-to-string (*standard-output*)
+                   (assert (= (run-test) 42)))
+                 "42"))
+\f
+;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel
+;;; 2004-06-11).  First the setup.
+(defclass user-method (standard-method) (myslot))
+
+(defmacro def-user-method (name &rest rest)
+  (let* ((lambdalist-position (position-if #'listp rest))
+         (qualifiers (subseq rest 0 lambdalist-position))
+         (lambdalist (elt rest lambdalist-position))
+         (body (subseq rest (+ lambdalist-position 1)))
+         (required-part
+          (subseq lambdalist 0
+                  (or (position-if #'(lambda (x)
+                                       (member x lambda-list-keywords))
+                                   lambdalist)
+                      (length lambdalist))))
+         (specializers
+          (mapcar #'find-class
+                  (mapcar #'(lambda (x) (if (consp x) (second x) 't))
+                          required-part)))
+         (unspecialized-required-part
+          (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
+         (unspecialized-lambdalist
+          (append unspecialized-required-part
+                  (subseq required-part (length required-part)))))
+    `(progn
+      (add-method #',name
+       (make-instance 'user-method
+        :qualifiers ',qualifiers
+        :lambda-list ',unspecialized-lambdalist
+        :specializers ',specializers
+        :function
+
+        #'(lambda (arguments next-methods-list)
+            (flet ((next-method-p () next-methods-list)
+                   (call-next-method (&rest new-arguments)
+                     (unless new-arguments (setq new-arguments arguments))
+                     (if (null next-methods-list)
+                         (error "no next method for arguments ~:s" arguments)
+                         (funcall (method-function (first next-methods-list))
+                                  new-arguments (rest next-methods-list)))))
+              (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
+      ',name)))
+
+;;; this one has always worked, as it does not involve MAKE-METHOD in
+;;; its effective method.
+(progn
+  (defgeneric test-um03 (x))
+  (defmethod test-um03 ((x integer))
+    (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+  (def-user-method test-um03 ((x rational))
+    (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um03 ((x real))
+    (list 'real x (not (null (next-method-p)))))
+  (assert (equal (test-um03 17) '(integer 17 t rational 17 t real 17 nil))))
+
+;;; these two used to fail in slightly different ways
+(progn
+  (defgeneric test-um10 (x))
+  (defmethod test-um10 ((x integer))
+    (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um10 ((x rational))
+    (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um10 ((x real))
+    (list 'real x (not (null (next-method-p)))))
+  (defmethod test-um10 :after ((x real)))
+  (def-user-method test-um10 :around ((x integer))
+    (list* 'around-integer x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um10 :around ((x rational))
+    (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um10 :around ((x real))
+    (list* 'around-real x (not (null (next-method-p))) (call-next-method)))
+  (assert (equal (test-um10 17)
+                 '(around-integer 17 t
+                   around-rational 17 t
+                   around-real 17 t
+                   integer 17 t
+                   rational 17 t
+                   real 17 nil))))
+
+(progn
+  (defgeneric test-um12 (x))
+  (defmethod test-um12 ((x integer))
+    (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um12 ((x rational))
+    (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um12 ((x real))
+    (list 'real x (not (null (next-method-p)))))
+  (defmethod test-um12 :after ((x real)))
+  (defmethod test-um12 :around ((x integer))
+    (list* 'around-integer x (not (null (next-method-p))) (call-next-method)))
+  (defmethod test-um12 :around ((x rational))
+    (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
+  (def-user-method test-um12 :around ((x real))
+    (list* 'around-real x (not (null (next-method-p))) (call-next-method)))
+  (assert (equal (test-um12 17)
+                 '(around-integer 17 t
+                   around-rational 17 t
+                   around-real 17 t
+                   integer 17 t
+                   rational 17 t
+                   real 17 nil))))

diff --git a/version.lisp-expr b/version.lisp-expr
index cacd653..b004c9f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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".)
-"0.9.15.11"
+"0.9.15.12"