From: Richard M Kreuter Date: Sun, 28 Sep 2008 14:20:36 +0000 (+0000) Subject: 1.0.20.32: Fix some bugs in GF type tracking. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9283908642216e9a3cc217f8e3eab186c8876593;p=sbcl.git 1.0.20.32: Fix some bugs in GF type tracking. --- diff --git a/NEWS b/NEWS index daf653c..a0ce8f4 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,8 @@ given mixed integer and double-float arguments, leading to better precision. (reported by Bob Felts) * bug fix: LOG with base zero returned values of inconsistent type. + * new feature: have the compiler track the effective type of a generic + function across method addition and removal. changes in sbcl-1.0.20 relative to 1.0.19: * minor incompatible change: OPTIMIZE qualities diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 79ac11b..8ad72f6 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -609,32 +609,44 @@ (gf-lambda-list (generic-function-lambda-list gf)) (tfun (constantly t)) keysp) - (multiple-value-bind - (gf.required gf.optional gf.rest ignore gf.allowp) - (%split-arglist gf-lambda-list) - (declare (ignore ignore)) - (setf (info :function :type name) - (specifier-type - `(function - (,@(mapcar tfun gf.required) - ,@(if gf.optional - `(&optional ,@(mapcar tfun gf.optional))) - ,@(if gf.rest - `(&rest t)) - ,@(let ((all-keys - (mapcar - (lambda (x) - (list x t)) - (remove-duplicates - (mapcan #'function-keywords methods))))) - (when all-keys - (setq keysp t) - `(&key ,@all-keys))) - ,@(if (and keysp gf.allowp) + (multiple-value-bind (gf.required gf.optional gf.restp gf.rest + gf.keyp gf.keys gf.allowp) + (parse-lambda-list gf-lambda-list) + (declare (ignore gf.rest)) + ;; 7.6.4 point 5 probably entails that if any method says + ;; &allow-other-keys then the gf should be construed to + ;; accept any key. + (let ((allowp (or gf.allowp + (find '&allow-other-keys methods + :test #'find + :key #'method-lambda-list)))) + (setf (info :function :type name) + (specifier-type + `(function + (,@(mapcar tfun gf.required) + ,@(if gf.optional + `(&optional ,@(mapcar tfun gf.optional))) + ,@(if gf.restp + `(&rest t)) + ,@(when gf.keyp + (let ((all-keys + (mapcar + (lambda (x) + (list x t)) + (remove-duplicates + (nconc + (mapcan #'function-keywords methods) + (mapcar #'keywordicate gf.keys)))))) + (when all-keys + (setq keysp t) + `(&key ,@all-keys)))) + ,@(when (and (not keysp) allowp) + `(&key)) + ,@(when allowp `(&allow-other-keys))) - *)) - (info :function :where-from name) :defined-method - (gf-info-needs-update gf) nil))))) + *)) + (info :function :where-from name) :defined-method + (gf-info-needs-update gf) nil)))))) (values))) (defun compute-applicable-methods-function (generic-function arguments) @@ -1663,11 +1675,11 @@ (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p - keywords keyword-parameters) + keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) - (declare (ignore nreq nopt keysp restp keywords)) + (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defmethod function-keyword-parameters ((method standard-method)) diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp index c6947e9..4da330e 100644 --- a/tests/clos-1.impure.lisp +++ b/tests/clos-1.impure.lisp @@ -144,3 +144,43 @@ ;; On second thought... (remove-method #'foo (find-method #'foo () '(integer))) (compile nil '(lambda () (foo (read) :bar 10))))))) + +;; If the GF has &REST with no &KEY, not all methods are required to +;; parse the tail of the arglist as keywords, so we don't treat the +;; function type as having &KEY in it. +(fmakunbound 'foo) +(with-test (:name gf-rest-method-key) + (defgeneric foo (x &rest y)) + (defmethod foo ((i integer) &key w) (list i w)) + ;; 1.0.20.30 failed here. + (assert + (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15)))))) + (assert + (not (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo))))) + +;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be +;; anything, and we don't warn about unrecognized keys. +(fmakunbound 'foo) +(with-test (:name gf-allow-other-keys) + (defgeneric foo (x &key &allow-other-keys)) + (defmethod foo ((i integer) &key y z) (list i y z)) + (assert + (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15)))))) + (assert + (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15)))))) + (assert + (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo))) + (assert + (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo)))) + +;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the +;; GF should be construed to have &ALLOW-OTHER-KEYS. +(fmakunbound 'foo) +(with-test (:name method-allow-other-keys) + (defgeneric foo (x &key)) + (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y)) + (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20)))))) + (assert (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo))) + (assert (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo)))) + + diff --git a/version.lisp-expr b/version.lisp-expr index 30863b0..8c762d6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.20.31" +"1.0.20.32"