X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=8d5b2f06844aca93d7156616131434ff457a224d;hb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;hp=e65ce45b6038e76fa350b03dc2df9cb05c6c1002;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index e65ce45..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,30 +526,28 @@ (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))) (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 +622,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)) @@ -1204,7 +1230,7 @@ meth generic-function)))) (cddr form))) (default (car (last list)))) - (list (list* ':mcase mp (nbutlast list)) + (list (list* :mcase mp (nbutlast list)) (cdr default)))) (t (default-constant-converter form)))))) @@ -1224,7 +1250,7 @@ (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) - (eq (car constant) ':mcase)) + (eq (car constant) :mcase)) (let ((alist (mapcar (lambda (k+m) (cons (car k+m) (convert-methods (cdr k+m) @@ -1301,7 +1327,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))