X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=8d5b2f06844aca93d7156616131434ff457a224d;hb=a74b0bdb483504f6faddf8089f848f61ed94b92a;hp=6dc9fd33e6ba51f8f34bde6c6495cacb8d17495b;hpb=104ee7ee303efa16e415f5e75df635ac54dba733;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 6dc9fd3..8d5b2f0 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
@@ -403,6 +405,14 @@
 	 (when restp
 	       `(&rest ,(intern "Discriminating Function &rest Arg")))))
 
+(defmethod generic-function-argument-precedence-order
+    ((gf standard-generic-function))
+  (aver (eq *boot-state* 'complete))
+  (loop with arg-info = (gf-arg-info gf)
+	with lambda-list = (arg-info-lambda-list arg-info)
+	for argument-position in (arg-info-precedence arg-info)
+	collect (nth argument-position lambda-list)))
+
 (defmethod generic-function-lambda-list ((gf generic-function))
   (gf-lambda-list gf))
 
@@ -450,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))
@@ -464,24 +482,35 @@
 				   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
-			  allocate-instance shared-initialize
-			  initialize-instance))
-	    (update-make-instance-function-table (type-class
-						  (car specializers))))
+	  (update-ctors 'add-method
+			:generic-function generic-function
+			:method method)
 	  (update-dfun generic-function))
 	method)))
 
@@ -497,11 +526,9 @@
       (dolist (specializer (method-specializers method))
 	(remove-direct-method specializer method))
       (set-arg-info generic-function)
-      (when (member name
-		    '(make-instance
-		      default-initargs
-		      allocate-instance shared-initialize initialize-instance))
-	(update-make-instance-function-table (type-class (car specializers))))
+      (update-ctors 'remove-method
+		    :generic-function generic-function
+		    :method method)
       (update-dfun generic-function)
       generic-function)))