X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=3ff601ab38910acfd8b69c8b6c0b5813e7f62d21;hb=8160f3ac81fff66563276cfbc7546d43891dae5c;hp=767d305c04fd28d6b64051a01b2c1cd46b060a65;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 767d305..3ff601a 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -132,9 +132,9 @@ (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) (check-lambda-list (legal-lambda-list-p method lambda-list)) (check-specializers (legal-specializers-p method specializers)) - (check-function (legal-method-function-p method - (or function - fast-function))) + (check-fun (legal-method-function-p method + (or function + fast-function))) (check-documentation (legal-documentation-p method documentation))) (unless (eq check-qualifiers t) (lose :qualifiers qualifiers check-qualifiers)) @@ -142,8 +142,8 @@ (lose :lambda-list lambda-list check-lambda-list)) (unless (eq check-specializers t) (lose :specializers specializers check-specializers)) - (unless (eq check-function t) - (lose :function function check-function)) + (unless (eq check-fun t) + (lose :function function check-fun)) (unless (eq check-documentation t) (lose :documentation documentation check-documentation))))) @@ -297,8 +297,8 @@ &rest other-initargs) (unless (and (fboundp generic-function-name) (typep (fdefinition generic-function-name) 'generic-function)) - (sb-kernel::style-warn "implicitly creating new generic function ~S" - generic-function-name)) + (style-warn "implicitly creating new generic function ~S" + generic-function-name)) ;; XXX What about changing the class of the generic function if ;; there is one? Whose job is that, anyway? Do we need something ;; kind of like CLASS-FOR-REDEFINITION? @@ -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,10 +622,9 @@ 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-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore applyp metatypes nkeys)) (let ((types-rev nil)) (dotimes-fixnum (i nreq) @@ -903,7 +929,8 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) + `(not (typep (classoid-of ,arg) + 'built-in-classoid))) ((eq class *the-class-std-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-standard-object*) @@ -1052,7 +1079,7 @@ `(and ,new-type ,@so-far))))) (defun generate-discrimination-net-internal - (gf methods types methods-function test-function type-function) + (gf methods types methods-function test-fun type-function) (let* ((arg-info (gf-arg-info gf)) (precedence (arg-info-precedence arg-info)) (nreq (arg-info-number-required arg-info)) @@ -1109,7 +1136,7 @@ known-types)))) (cond ((determined-to-be nil) (do-if nil t)) ((determined-to-be t) (do-if t t)) - (t (funcall test-function position type + (t (funcall test-fun position type (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) @@ -1204,7 +1231,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 +1251,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) @@ -1258,20 +1285,20 @@ (make-dfun-lambda-list metatypes applyp) (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) - (get-function1 `(,(if function-p - 'sb-kernel:instance-lambda - 'lambda) - ,arglist - ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) - (locally (declare #.*optimize-speed*) - (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) - #'net-test-converter - #'net-code-converter - (lambda (form) - (net-constant-converter form generic-function))) + (get-fun1 `(,(if function-p + 'instance-lambda + 'lambda) + ,arglist + ,@(unless function-p + `((declare (ignore .pv-cell. + .next-method-call.)))) + (locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf)))) + #'net-test-converter + #'net-code-converter + (lambda (form) + (net-constant-converter form generic-function))) (lambda (method-alist wrappers) (let* ((alist (list nil)) (alist-tail alist)) @@ -1301,7 +1328,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)) @@ -1318,12 +1345,12 @@ ;;; the funcallable instance function of the generic function for which ;;; it was computed. ;;; -;;; More precisely, if compute-discriminating-function is called with an -;;; argument , and returns a result , that result must not be -;;; passed to apply or funcall directly. Rather, must be stored as -;;; the funcallable instance function of the same generic function -;;; (using set-funcallable-instance-fun). Then the generic function -;;; can be passed to funcall or apply. +;;; More precisely, if compute-discriminating-function is called with +;;; an argument , and returns a result , that result must +;;; not be passed to apply or funcall directly. Rather, must be +;;; stored as the funcallable instance function of the same generic +;;; function (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the +;;; generic function can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are ;;; permitted to return a function which itself ends up calling the value @@ -1364,7 +1391,7 @@ ;;; (lambda (arg) ;;; (cond ( ;;; -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) @@ -1376,7 +1403,7 @@ ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (lambda (arg) ;;; (cond ( -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (lambda (a) ..)) ;;; (funcall gf arg)) @@ -1462,31 +1489,37 @@ ;;; into account at all yet. (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) - (let ((methods (generic-function-methods generic-function)) - (arglist ())) - (when methods - (multiple-value-bind (required optional rest key allow-other-keys) - (method-pretty-arglist (car methods)) - (dolist (m (cdr methods)) - (multiple-value-bind (method-key-keywords - method-allow-other-keys - method-key) - (function-keywords m) - ;; we've modified function-keywords to return what we want as - ;; the third value, no other change here. - (declare (ignore method-key-keywords)) - (setq key (union key method-key)) - (setq allow-other-keys (or allow-other-keys - method-allow-other-keys)))) - (when allow-other-keys - (setq arglist '(&allow-other-keys))) - (when key - (setq arglist (nconc (list '&key) key arglist))) - (when rest - (setq arglist (nconc (list '&rest rest) arglist))) - (when optional - (setq arglist (nconc (list '&optional) optional arglist))) - (nconc required arglist))))) + (let ((methods (generic-function-methods generic-function))) + (if methods + (let ((arglist ())) + ;; arglist is constructed from the GF's methods - maybe with + ;; keys and rest stuff added + (multiple-value-bind (required optional rest key allow-other-keys) + (method-pretty-arglist (car methods)) + (dolist (m (cdr methods)) + (multiple-value-bind (method-key-keywords + method-allow-other-keys + method-key) + (function-keywords m) + ;; we've modified function-keywords to return what we want as + ;; the third value, no other change here. + (declare (ignore method-key-keywords)) + (setq key (union key method-key)) + (setq allow-other-keys (or allow-other-keys + method-allow-other-keys)))) + (when allow-other-keys + (setq arglist '(&allow-other-keys))) + (when key + (setq arglist (nconc (list '&key) key arglist))) + (when rest + (setq arglist (nconc (list '&rest rest) arglist))) + (when optional + (setq arglist (nconc (list '&optional) optional arglist))) + (nconc required arglist))) + ;; otherwise we take the lambda-list from the GF directly, with no + ;; other 'keys' added ... + (let ((lambda-list (generic-function-lambda-list generic-function))) + lambda-list)))) (defmethod method-pretty-arglist ((method standard-method)) (let ((required ())