From: Christophe Rhodes Date: Sun, 8 Jun 2003 15:02:27 +0000 (+0000) Subject: 0.8.0.50: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3cc4b17d770f3fe95e5e94f6ac39820784968c4d;p=sbcl.git 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 --- 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 --- 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 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -263,30 +263,7 @@ (apply #'call-next-method generic-function initargs))) ||# -;;; 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 "~@" generic-function qualifiers specializers))))) - + (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 "~@" + generic-function nreq specializers)) + (real-get-method generic-function qualifiers + (parse-specializers specializers) errorp))) ;;; 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 "~@" 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 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -433,26 +433,17 @@ form))) 'dmc-test-return)) -;;; 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 --- 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"