0.8.0.50:

	Fixes for ADD-METHOD.[12] and FIND-METHOD error cases
	... ADD-METHOD should return the generic function (but preserve
	method-returning in the internal function ADD-NAMED-METHOD
	... FIND-METHOD needs to signal an error if the lengths of the
	specializers isn't the same as the number of required arguments
	to the generic function.  Turn the test in REAL-GET-METHOD into
	an AVER.
	... REMOVED-NAMED-METHOD is unused; delete it.
	... incompatible lambda lists don't actually require an error of
	type PROGRAM-ERROR to be signalled, and in fact this change
	can make the error signalled be an ERROR.  Adjust the test.

diff --git a/NEWS b/NEWS
index e808be2..e3cfa2c 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1823,6 +1823,11 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0:
     ** functions [N]SUBST*, LAST, NRECONC, [N]SUBLIS may return any
        object.
     ** DISASSEMBLE works with closures and funcallable instances.
+    ** ADD-METHOD now returns the generic function, not the new
+       method.
+    ** FIND-METHOD signals an error if the lengths of the specializers
+       is incompatible with the generic function, even if the ERRORP
+       argument is true.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp
index a66447c..4c44940 100644 (file)
--- a/src/pcl/generic-functions.lisp
+++ b/src/pcl/generic-functions.lisp
@@ -464,10 +464,6 @@
                         specializers
                         &optional errorp))
 
-(defgeneric remove-named-method (generic-function-name
-                                argument-specifiers
-                                &optional extra))
-
 (defgeneric slot-missing (class
                          instance
                          slot-name

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 63b1bcd..437e146 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -263,30 +263,7 @@
     (apply #'call-next-method generic-function initargs)))
 ||#
 \f
-;;; These three are scheduled for demolition.
-
-(defmethod remove-named-method (generic-function-name argument-specifiers
-                                                     &optional extra)
-  (let ((generic-function ())
-       (method ()))
-    (cond ((or (null (fboundp generic-function-name))
-              (not (generic-function-p
-                     (setq generic-function
-                           (fdefinition generic-function-name)))))
-          (error "~S does not name a generic function."
-                 generic-function-name))
-         ((null (setq method (get-method generic-function
-                                         extra
-                                         (parse-specializers
-                                           argument-specifiers)
-                                         nil)))
-          (error "There is no method for the generic function ~S~%~
-                  which matches the ARGUMENT-SPECIFIERS ~S."
-                 generic-function
-                 argument-specifiers))
-         (t
-          (remove-method generic-function method)))))
-
+;;; These two are scheduled for demolition.
 (defun real-add-named-method (generic-function-name
                              qualifiers
                              specializers
@@ -308,28 +285,41 @@
                                     :specializers specs
                                     :lambda-list lambda-list
                                     other-initargs)))
-    (add-method generic-function new)))
+    (add-method generic-function new)
+    new))
 
 (defun real-get-method (generic-function qualifiers specializers
                                         &optional (errorp t))
-  (let ((hit 
+  (let* ((lspec (length specializers))
+        (hit 
          (dolist (method (generic-function-methods generic-function))
            (let ((mspecializers (method-specializers method)))
+             (aver (= lspec (length mspecializers)))
              (when (and (equal qualifiers (method-qualifiers method))
-                        (= (length specializers) (length mspecializers))
                         (every #'same-specializer-p specializers
                                (method-specializers method)))
                (return method))))))
     (cond (hit hit)
          ((null errorp) nil)
          (t
-          (error "no method on ~S with qualifiers ~:S and specializers ~:S"
+          (error "~@<There is no method on ~S with ~
+                   ~:[no qualifiers~;~:*qualifiers ~S~] ~
+                   and specializers ~S.~@:>"
                  generic-function qualifiers specializers)))))
-\f
+
 (defmethod find-method ((generic-function standard-generic-function)
                        qualifiers specializers &optional (errorp t))
-  (real-get-method generic-function qualifiers
-                  (parse-specializers specializers) errorp))
+  (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function)))))
+    ;; ANSI: "The specializers argument contains the parameter
+    ;; specializers for the method. It must correspond in length to
+    ;; the number of required arguments of the generic function, or an
+    ;; error is signaled."
+    (when (/= (length specializers) nreq)
+      (error "~@<The generic function ~S takes ~D required argument~:P; ~
+              was asked to find a method with specializers ~S~@:>"
+            generic-function nreq specializers))
+    (real-get-method generic-function qualifiers
+                    (parse-specializers specializers) errorp)))
 \f
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -458,9 +448,9 @@
 
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
   (when (method-generic-function method)
-    (error "The method ~S is already part of the generic~@
-           function ~S. It can't be added to another generic~@
-           function until it is removed from the first one."
+    (error "~@<The method ~S is already part of the generic ~
+           function ~S; it can't be added to another generic ~
+           function until it is removed from the first one.~@:>"
           method (method-generic-function method)))
   (flet ((similar-lambda-lists-p (method-a method-b)
           (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
@@ -509,7 +499,7 @@
                        :generic-function generic-function
                        :method method)
          (update-dfun generic-function))
-       method)))
+       generic-function)))
 
 (defun real-remove-method (generic-function method)
   (when  (eq generic-function (method-generic-function method))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 014fa2f..a94d842 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -433,26 +433,17 @@
                    form)))
            'dmc-test-return))
 \f
-;;; DEFMETHOD should signal a PROGRAM-ERROR if an incompatible lambda
-;;; list is given:
+;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
+;;; given:
 (defmethod incompatible-ll-test-1 (x) x)
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-1 (x y) y))
-  (assert (null result))
-  (assert (typep error 'program-error)))
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-1 (x &rest y) y))
-  (assert (null result))
-  (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
 ;;; Sneakily using a bit of MOPness to check some consistency
 (assert (= (length
            (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
 
 (defmethod incompatible-ll-test-2 (x &key bar) bar)
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-2 (x) x))
-  (assert (null result))
-  (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
 (defmethod incompatible-ll-test-2 (x &rest y) y)
 (assert (= (length
            (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))

diff --git a/version.lisp-expr b/version.lisp-expr
index c72f7ab..6bd8474 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.8.0.49"
+"0.8.0.50"