1.0.43.50: better function signature checking for self-calls

 Fixes bug 655126.

 Allow passing a lambda-list to GET-DEFINED-FUN, and when provided
 one, make up an FTYPE based on that lambda-list.

diff --git a/NEWS b/NEWS
index 1c07af4..0b256df 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -53,6 +53,9 @@ changes relative to sbcl-1.0.43:
     greater value than n-word-bits. (lp#309063)
   * bug fix: (SETF SYMBOL-FUNCTION) and (SETF FDEFINITION) clear derived
     type information for the function being set. (lp#659220)
+  * bug fix: the system used to signal bogus STYLE-WARNINGs when functions
+    containing self-calls were recompiled with a new signature, and failed
+    to warn when a self-call using the old signature was left in. (lp#655126)
 
 changes in sbcl-1.0.43 relative to sbcl-1.0.42:
   * incompatible change: FD-STREAMS no longer participate in the serve-event

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index b1ee7ee..93e739e 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -1015,7 +1015,7 @@
      (let ((name (cadr thing))
            (lambda-expression `(lambda ,@(cddr thing))))
        (if (and name (legal-fun-name-p name))
-           (let ((defined-fun-res (get-defined-fun name))
+           (let ((defined-fun-res (get-defined-fun name (second lambda-expression)))
                  (res (ir1-convert-lambda lambda-expression
                                           :maybe-add-debug-catch t
                                           :source-name name)))
@@ -1073,10 +1073,37 @@
       (setf (functional-inline-expanded clambda) t)
       clambda)))
 
+;;; Given a lambda-list, return a FUN-TYPE object representing the signature:
+;;; return type is *, and each individual arguments type is T -- but we get
+;;; the argument counts and keywords.
+(defun ftype-from-lambda-list (lambda-list)
+  (multiple-value-bind (req opt restp rest-name keyp key-list allowp morep)
+      (parse-lambda-list lambda-list)
+    (declare (ignore rest-name))
+    (flet ((t (list)
+             (mapcar (constantly t) list)))
+      (let ((reqs (t req))
+            (opts (when opt (cons '&optional (t opt))))
+            ;; When it comes to building a type, &REST means pretty much the
+            ;; same thing as &MORE.
+            (rest (when (or morep restp) (list '&rest t)))
+            (keys (when keyp
+                    (cons '&key (mapcar (lambda (spec)
+                                          (let ((key/var (if (consp spec)
+                                                             (car spec)
+                                                             spec)))
+                                            (list (if (consp key/var)
+                                                      (car key/var)
+                                                      (keywordicate key/var))
+                                                  t)))
+                                        key-list))))
+            (allow (when allowp (list '&allow-other-keys))))
+        (specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *))))))
+
 ;;; Get a DEFINED-FUN object for a function we are about to define. If
 ;;; the function has been forward referenced, then substitute for the
 ;;; previous references.
-(defun get-defined-fun (name)
+(defun get-defined-fun (name &optional (lambda-list nil lp))
   (proclaim-as-fun-name name)
   (when (boundp '*free-funs*)
     (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
@@ -1087,15 +1114,20 @@
                     (res (make-defined-fun
                           :%source-name name
                           :where-from (if (eq where-from :declared)
-                                          :declared :defined)
-                          :type (leaf-type found))))
+                                          :declared
+                                          :defined)
+                          :type (if (eq :declared where-from)
+                                    (leaf-type found)
+                                    (if lp
+                                        (ftype-from-lambda-list lambda-list)
+                                        (specifier-type 'function))))))
                (substitute-leaf res found)
                (setf (gethash name *free-funs*) res)))
             ;; If *FREE-FUNS* has a previously converted definition
             ;; for this name, then blow it away and try again.
             ((defined-fun-functionals found)
              (remhash name *free-funs*)
-             (get-defined-fun name))
+             (get-defined-fun name lambda-list))
             (t found)))))
 
 ;;; Check a new global function definition for consistency with
@@ -1184,7 +1216,9 @@
 (defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
   (let ((defined-fun nil)) ; will be set below if we're in the compiler
     (when compile-toplevel
-      (setf defined-fun (get-defined-fun name))
+      (setf defined-fun (if lambda-with-lexenv
+                            (get-defined-fun name (fifth lambda-with-lexenv))
+                            (get-defined-fun name)))
       (when (boundp '*lexenv*)
         (remhash name *free-funs*)
         (aver (fasl-output-p *compile-object*))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 195a2f4..a454e59 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2018,4 +2018,27 @@
                (length (clear-derived-types-on-set-fdefn-1)))))
     (assert (= 6 (clear-derived-types-on-set-fdefn-2)))))
 
+(test-util:with-test (:name :bug-655126)
+  (let ((*evaluator-mode* :compile)
+        (*derive-function-types* t))
+    (eval `(defun bug-655126 (x) x))
+    (assert (eq :style-warning
+                (handler-case
+                    (eval `(defun bug-655126-2 ()
+                             (bug-655126)))
+                  (style-warning ()
+                    :style-warning))))
+    (assert (eq 'bug-655126
+                (handler-case
+                    (eval `(defun bug-655126 (x y)
+                             (cons x y)))
+                  ((and style-warning (not sb-kernel:redefinition-warning)) ()
+                    :oops))))
+    (assert (eq :style-warning
+                (handler-case
+                    (eval `(defun bug-655126 (x)
+                             (bug-655126 x y)))
+                  ((and style-warning (not sb-kernel:redefinition-warning)) ()
+                    :style-warning))))))
+
 ;;; success

diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 13d1c75..549141d 100644 (file)
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -26,6 +26,15 @@ cat > $tmpfilename <<EOF
 EOF
 expect_failed_compile $tmpfilename
 
+# This should fail (but right now we just get a style-warning), as
+# type inference should show that the call to FOO has a wrong number
+# of args.
+cat > $tmpfilename <<EOF
+    (in-package :cl-user)
+    (defun foo (x) (or x (foo x x)))
+EOF
+expect_condition_during_compile style-warning $tmpfilename
+
 # This should fail, as we define a function multiply in the same file
 # (CLHS 3.2.2.3).
 cat > $tmpfilename <<EOF

diff --git a/version.lisp-expr b/version.lisp-expr
index 43eb94e..175f9dd 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.43.49"
+"1.0.43.50"