X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=c836f803603f5ae9119545a9fb1577e2ba29c359;hb=342b4bc80d748ced4f8b949ddb3e5b290520fe7d;hp=091c5143efc41f3f64908e6631aa4d8f5452156d;hpb=f6a2be77637d025bfded9430f02863c28f74f77a;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 091c514..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 @@ -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,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 @@ -508,19 +540,19 @@ (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types generic-function - (types-from-arguments generic-function arguments 'eql)))) + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types generic-function - (types-from-arguments generic-function arguments 'eql)))) + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) (compute-applicable-methods-using-types generic-function - (types-from-arguments generic-function classes 'class-eq))) + (types-from-args generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) (setq classes (mapcar (lambda (class) @@ -595,8 +627,7 @@ function n)) -(defun types-from-arguments (generic-function arguments - &optional type-modifier) +(defun types-from-args (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-fun-info generic-function) (declare (ignore applyp metatypes nkeys)) @@ -1301,7 +1332,7 @@ (format t "~&make-unordered-methods-emf ~S~%" (generic-function-name generic-function))) (lambda (&rest args) - (let* ((types (types-from-arguments generic-function args 'eql)) + (let* ((types (types-from-args generic-function args 'eql)) (smethods (sort-applicable-methods generic-function methods types))