0.8.21.37: fix bug 305

 * annotate the inline/notinline fun with type-restrictions from the
    environment.

diff --git a/BUGS b/BUGS
index 0b795f0..ba4e1f1 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1073,17 +1073,6 @@ WORKAROUND:
 
   The problem is that both EVALs sequentially write to the same LVAR.
 
-305:
-  (Reported by Dave Roberts.)
-  Local INLINE/NOTINLINE declaration removes local FTYPE declaration:
-
-    (defun quux (x)
-      (declare (ftype (function () (integer 0 10)) fee)
-               (inline fee))
-      (1+ (fee)))
-
-  uses generic arithmetic with INLINE and fixnum without.
-
 306: "Imprecise unions of array types"
   a.(defun foo (x)
       (declare (optimize speed)

diff --git a/NEWS b/NEWS
index 9fc6eaf..0692ab7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21:
     *ERROR-OUTPUT*, not *STANDARD-OUTPUT*.
   * fixed inference of the upper bound of an iteration variable.
     (reported by Rajat Datta).
+  * fixed bug 305: INLINE/NOTINLINE declaration no longer causes local
+    ftype declaration to be disregarded. (reported by Dave Roberts)
   * fixed bug 373: caused by erronous compilation of references to alien
     variables in the runtime on ppc/darwin.
   * fixed bug 376: CONJUGATE type deriver.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index d7cb33b..5f37066 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -66,7 +66,6 @@
   (unless (info :function :kind name)
     (setf (info :function :kind name) :function)
     (setf (info :function :where-from name) :assumed))
-
   (let ((where (info :function :where-from name)))
     (when (and (eq where :assumed)
               ;; In the ordinary target Lisp, it's silly to report
@@ -988,11 +987,9 @@
     (collect ((res nil cons))
       (dolist (name names)
        (when (fboundp name)
-         (compiler-assert-symbol-home-package-unlocked name
-                                                        "declaring the ftype of ~A"))
-       (let ((found (find name fvars
-                          :key #'leaf-source-name
-                          :test #'equal)))
+         (compiler-assert-symbol-home-package-unlocked 
+          name "declaring the ftype of ~A"))
+       (let ((found (find name fvars :key #'leaf-source-name :test #'equal)))
          (cond
           (found
            (setf (leaf-type found) type)
@@ -1039,17 +1036,20 @@
        res)))
 
 ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
-;;; (and TYPE if notinline).
-(defun make-new-inlinep (var inlinep)
+;;; (and TYPE if notinline), plus type-restrictions from the lexenv.
+(defun make-new-inlinep (var inlinep local-type)
   (declare (type global-var var) (type inlinep inlinep))
-  (let ((res (make-defined-fun
-             :%source-name (leaf-source-name var)
-             :where-from (leaf-where-from var)
-             :type (if (and (eq inlinep :notinline)
-                            (not (eq (leaf-where-from var) :declared)))
-                       (specifier-type 'function)
-                       (leaf-type var))
-             :inlinep inlinep)))
+  (let* ((type (if (and (eq inlinep :notinline)
+                       (not (eq (leaf-where-from var) :declared)))
+                  (specifier-type 'function)
+                  (leaf-type var)))
+        (res (make-defined-fun
+              :%source-name (leaf-source-name var)
+              :where-from (leaf-where-from var)
+              :type (if local-type 
+                        (type-intersection local-type type)
+                        type)
+              :inlinep inlinep)))
     (when (defined-fun-p var)
       (setf (defined-fun-inline-expansion res)
            (defined-fun-inline-expansion var))
@@ -1063,14 +1063,11 @@
   (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))
        (new-fenv ()))
     (dolist (name (rest spec))
-      (let ((fvar (find name fvars
-                       :key #'leaf-source-name
-                       :test #'equal)))
+      (let ((fvar (find name fvars :key #'leaf-source-name :test #'equal)))
        (if fvar
            (setf (functional-inlinep fvar) sense)
-           (let ((found
-                  (find-lexically-apparent-fun
-                   name "in an inline or notinline declaration")))
+           (let ((found (find-lexically-apparent-fun
+                         name "in an inline or notinline declaration")))
              (etypecase found
                (functional
                 (when (policy *lexenv* (>= speed inhibit-warnings))
@@ -1078,9 +1075,10 @@
                                      definition of local function:~%  ~S"
                                    sense name)))
                (global-var
-                (push (cons name (make-new-inlinep found sense))
-                      new-fenv)))))))
-
+                (let ((type 
+                       (cdr (assoc found (lexenv-type-restrictions res)))))
+                  (push (cons name (make-new-inlinep found sense type))
+                        new-fenv))))))))
     (if new-fenv
        (make-lexenv :default res :funs new-fenv)
        res)))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index cf2a75e..94fa639 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -998,5 +998,36 @@
   (print output)
   (assert (zerop (length output))))
 
+;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
+
+(define-condition optimization-error (error) ())
+
+(labels ((compile-lambda (type sense)
+          (handler-bind ((compiler-note (lambda (_)
+                                          (declare (ignore _))
+                                          (error 'optimization-error))))
+            (values
+             (compile 
+              nil
+              `(lambda ()
+                 (declare 
+                  ,@(when type '((ftype (function () (integer 0 10)) bug-305)))
+                  (,sense bug-305)
+                  (optimize speed))
+                 (1+ (bug-305))))
+             nil)))
+        (expect-error (sense)
+          (multiple-value-bind (f e)  (ignore-errors (compile-lambda nil sense))
+            (assert (not f))
+            (assert (typep e 'optimization-error))))
+        (expect-pass (sense)
+          (multiple-value-bind (f e)  (ignore-errors (compile-lambda t sense))
+            (assert f)
+            (assert (not e)))))
+  (expect-error 'inline)
+  (expect-error 'notinline)
+  (expect-pass 'inline)
+  (expect-pass 'notinline))
+
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 3583ac7..665fecf 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".)
-"0.8.21.36"
+"0.8.21.37"