From 342b4bc80d748ced4f8b949ddb3e5b290520fe7d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 8 Nov 2002 16:23:02 +0000 Subject: [PATCH] 0.7.9.37: Fix for DEFMETHOD laxness reported CSR sbcl-devel 2002-11-07, patch CSR/Gerd Moellmann cmucl-imp 2002-11-08 ... and nicer format strings for the errors :) --- NEWS | 2 ++ src/pcl/boot.lisp | 13 ++++++----- src/pcl/methods.lisp | 56 ++++++++++++++++++++++++++++++++++-------------- tests/clos.impure.lisp | 29 +++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 78 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 4a3381a..427105c 100644 --- a/NEWS +++ b/NEWS @@ -1369,6 +1369,8 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: instance to return different numbers on distinct instances, while preserving the same return value through invocations of CHANGE-CLASS; + ** DEFMETHOD signals errors when methods with longer incongruent + lambda lists are added to generic functions; * fixed some bugs shown by Paul Dietz' test suite: ** DOLIST puts its body in TAGBODY ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 0033725..12a81ff 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1658,11 +1658,10 @@ bootstrapping. (method-lambda-list method))) (flet ((lose (string &rest args) (error 'simple-program-error - :format-control "attempt to add the method ~S ~ - to the generic function ~S.~%~ - But ~A" - :format-arguments (list method gf - (apply #'format nil string args)))) + :format-control "~@" + :format-arguments (list method gf string args))) (comparison-description (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) @@ -1679,13 +1678,13 @@ bootstrapping. (comparison-description nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) (lose - "the method and generic function differ in whether they accept~%~ + "the method and generic function differ in whether they accept~_~ &REST or &KEY arguments.")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the &KEY arguments~%~ + (lose "the method does not accept each of the &KEY arguments~2I~_~ ~S." gf-keywords))))))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 9f43912..c836f80 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -317,10 +317,12 @@ &optional (errorp t)) (let ((hit (dolist (method (generic-function-methods generic-function)) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method))))) + (let ((mspecializers (method-specializers method))) + (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 @@ -458,12 +460,20 @@ (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) - (if (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." - method (method-generic-function method)) - + (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." + 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) + (analyze-lambda-list (method-lambda-list method-a)) + (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) + (analyze-lambda-list (method-lambda-list method-b)) + (and (= a-nreq b-nreq) + (= a-nopt b-nopt) + (eq (or a-keyp a-restp) + (or b-keyp b-restp))))))) (let* ((name (generic-function-name generic-function)) (qualifiers (method-qualifiers method)) (specializers (method-specializers method)) @@ -472,17 +482,31 @@ specializers nil))) - ;; If there is already a method like this one then we must - ;; get rid of it before proceeding. Note that we call the - ;; generic function remove-method to remove it rather than - ;; doing it in some internal way. - (when existing (remove-method generic-function existing)) + ;; If there is already a method like this one then we must get + ;; rid of it before proceeding. Note that we call the generic + ;; function REMOVE-METHOD to remove it rather than doing it in + ;; some internal way. + (when (and existing (similar-lambda-lists-p existing method)) + (remove-method generic-function existing)) (setf (method-generic-function method) generic-function) (pushnew method (generic-function-methods generic-function)) (dolist (specializer specializers) (add-direct-method specializer method)) - (set-arg-info generic-function :new-method method) + + ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for + ;; detecting attempts to add methods with incongruent lambda + ;; lists. However, according to Gerd Moellmann on cmucl-imp, + ;; it also depends on the new method already having been added + ;; to the generic function. Therefore, we need to remove it + ;; again on error: + (let ((remove-again-p t)) + (unwind-protect + (progn + (set-arg-info generic-function :new-method method) + (setq remove-again-p nil)) + (when remove-again-p + (remove-method generic-function method)))) (unless skip-dfun-update-p (when (member name '(make-instance default-initargs diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index cad0723..753dd4c 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -387,6 +387,35 @@ form))) 'dmc-test-return)) +;;; DEFMETHOD should signal a PROGRAM-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))) +;;; 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))) +(defmethod incompatible-ll-test-2 (x &rest y) y) +(assert (= (length + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1)) +(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar) +(assert (= (length + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2)) +(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2))) +(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 3991fe8..8bec1de 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.36" +"0.7.9.37" -- 1.7.10.4