1.0.20.32: Fix some bugs in GF type tracking.

diff --git a/NEWS b/NEWS
index daf653c..a0ce8f4 100644 (file)
--- 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 (file)
--- 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)))
 \f
 (defun compute-applicable-methods-function (generic-function arguments)
@@ -1663,11 +1675,11 @@
 \f
 (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 (file)
--- 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 (file)
--- 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"