X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=6dc9fd33e6ba51f8f34bde6c6495cacb8d17495b;hb=94ac5b7c3ff37850210b6fc9a7593cf1c5752993;hp=767d305c04fd28d6b64051a01b2c1cd46b060a65;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 767d305..6dc9fd3 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))))) @@ -508,19 +508,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,10 +595,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) @@ -1052,7 +1051,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 +1108,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 +1203,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 +1223,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 +1257,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 + '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))) (lambda (method-alist wrappers) (let* ((alist (list nil)) (alist-tail alist)) @@ -1301,7 +1300,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)) @@ -1462,31 +1461,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 ())