From: Christophe R. <cr...@us...> - 2002-11-08 16:23:05
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory usw-pr-cvs1:/tmp/cvs-serv9114/src/pcl Modified Files: boot.lisp methods.lisp Log Message: 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 :) Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.59 retrieving revision 1.60 diff -u -d -r1.59 -r1.60 --- boot.lisp 31 Oct 2002 16:05:39 -0000 1.59 +++ boot.lisp 8 Nov 2002 16:23:02 -0000 1.60 @@ -1658,11 +1658,10 @@ (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 "~@<attempt to add the method~2I~_~S~I~_~ + to the generic function~2I~_~S;~I~_~ + but ~?~:>" + :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 @@ (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))))))) Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- methods.lisp 12 Oct 2002 16:02:38 -0000 1.17 +++ methods.lisp 8 Nov 2002 16:23:02 -0000 1.18 @@ -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 |