1.0.30.9: improved generic-function FTYPE handling

 * Use :DEFINED-METHOD as :WHERE-FROM even if there is no explicit
   DEFGENERIC -- initial type becomes FUNCTION.

 * Also signal a style-warning when the FTYPE is clobbered by a
   generic function -- though in this case it is more "bad SBCL style"
   than bad user style... but at least the user will know that
   something unexpected is going on. (Clobbering itself is not new.)

diff --git a/NEWS b/NEWS
index 96b7c1f..9367e1c 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,11 @@ changes relative to sbcl-1.0.30:
     multiplication by reciprocal when an exact reciprocal exists.
   * optimization: multiplication of single- and double-floats floats by
     constant two has been optimized.
+  * improvement: a STYLE-WARNING is signalled when a generic function
+    clobbers an earlier FTYPE proclamation.
+  * improvement: the compiler is able to track the effective type of
+    generic function across method addition and removal even in the
+    absence of an explicit DEFGENERIC.
   * bug fix: moderately complex combinations of inline expansions could
     be miscompiled if the result was declared to be dynamic extent.
   * bug fix: in some cases no compiler note about failure to stack allocate

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 12467fa..cc1dc82 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -2208,6 +2208,21 @@ bootstrapping.
                      method-class)
                     (t (find-class method-class t ,env))))))))
 
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+  ;; FIXME: Ideally we would like to not clobber it, but because generic
+  ;; functions assert their FTYPEs callers believing the FTYPE are
+  ;; left with unsafe assumptions. Hence the clobbering.
+  (when (eq :declared (info :function :where-from fun-name))
+    (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~
+                 for the same name.~:@>"
+                fun-name 'ftype))
+  (setf (info :function :type fun-name)
+        (specifier-type
+         (if lambda-list-p
+             (ftype-declaration-from-lambda-list lambda-list fun-name)
+             'function)))
+  (setf (info :function :where-from fun-name) :defined-method))
+
 (defun real-ensure-gf-using-class--generic-function
        (existing
         fun-name
@@ -2222,11 +2237,7 @@ bootstrapping.
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)
-    (when lambda-list-p
-      (setf (info :function :type fun-name)
-            (specifier-type
-             (ftype-declaration-from-lambda-list lambda-list fun-name))
-            (info :function :where-from fun-name) :defined-method))))
+    (note-gf-signature fun-name lambda-list-p lambda-list)))
 
 (defun real-ensure-gf-using-class--null
        (existing
@@ -2241,11 +2252,7 @@ bootstrapping.
       (setf (gdefinition fun-name)
             (apply #'make-instance generic-function-class
                    :name fun-name all-keys))
-    (when lambda-list-p
-      (setf (info :function :type fun-name)
-            (specifier-type
-             (ftype-declaration-from-lambda-list lambda-list fun-name))
-            (info :function :where-from fun-name) :defined-method))))
+    (note-gf-signature fun-name lambda-list-p lambda-list)))
 \f
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 447639e..4b0f1db 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1718,5 +1718,30 @@
     (shared-initialize x '(a))
     (assert (slot-boundp x 'a))
     (assert (eq :ok (slot-value x 'a)))))
+
+(declaim (ftype (function (t t t) (values single-float &optional))
+                i-dont-want-to-be-clobbered-1
+                i-dont-want-to-be-clobbered-2))
+(defgeneric i-dont-want-to-be-clobbered-1 (t t t))
+(defmethod i-dont-want-to-be-clobbered-2 ((x cons) y z)
+  y)
+(defun i-cause-an-gf-info-update ()
+  (i-dont-want-to-be-clobbered-2 t t t))
+(with-test (:name :defgeneric-should-clobber-ftype)
+  ;; (because it doesn't check the argument or result types)
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-1))))
+  (assert (equal '(function (t t t) *)
+                 (sb-kernel:type-specifier
+                  (sb-int:info :function
+                               :type 'i-dont-want-to-be-clobbered-2))))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-1)))
+  (assert (eq :defined-method
+              (sb-int:info :function
+                           :where-from 'i-dont-want-to-be-clobbered-2))))
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 2ee8655..1ee7365 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.30.8"
+"1.0.30.9"