(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))
(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)))))))
&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
(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))
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
form)))
'dmc-test-return))
\f
+;;; 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))
+\f
;;;; success
(sb-ext:quit :unix-status 104)
projects / sbcl.git / commitdiff