From: Paul Khuong <pvk@pvk.ca>
Date: Tue, 15 Nov 2011 16:53:50 +0000 (-0500)
Subject: Plug a CTYPE leak into fasls via SETQ
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5efae2334933e0d8a998e8abbc12489cd5043b4d;p=sbcl.git

Plug a CTYPE leak into fasls via SETQ

  Type mismatch from SETQing lexical variables used to dump CTYPE
  structs directly.  Splice a type specifier in instead during
  IR1 conversion of SETQ so that the source form remains dumpable.

  Reported with the test case by Xach on #lisp.

  Fixes lp#890750.
---

diff --git a/NEWS b/NEWS
index 4abfe85..68e84be 100644
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,8 @@ changes relative to sbcl-1.0.53:
     resolved to directories.
   * bug fix: SB-KERNEL:MAKE-LISP-OBJ on GENCGC no longer categorically
     refuses to create SIMPLE-FUN objects.
+  * bug fix: type mismatch when assigning to lexical variables no longer
+    result in fasl-dumping internal type objects. (lp#890750)
 
 changes in sbcl-1.0.53 relative to sbcl-1.0.52:
   * enhancement: on 64-bit targets, in src/compiler/generic/early-vm.lisp,
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 9409482..f79a734 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -994,7 +994,8 @@ care."
         (dest-lvar (make-lvar))
         (type (or (lexenv-find var type-restrictions)
                   (leaf-type var))))
-    (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+    (ir1-convert start dest-ctran dest-lvar `(the ,(type-specifier type)
+                                                  ,value))
     (let ((res (make-set :var var :value dest-lvar)))
       (setf (lvar-dest dest-lvar) res)
       (setf (leaf-ever-used var) t)
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 87e3026..39098a7 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -469,5 +469,17 @@ cat > $tmpfilename <<EOF
 EOF
 expect_clean_cload $tmpfilename
 
+cat > $tmpfilename <<EOF
+(in-package :cl-user)
+
+(defun foo ()
+  (declare (muffle-conditions warning))
+  (let ((em 0d0))
+    (declare (type double-float em))
+    (dotimes (i 42)
+      (setf em (float (1+ i))))))
+EOF
+expect_clean_compile $tmpfilename
+
 # success
 exit $EXIT_TEST_WIN