From 67a805dee41b93fa03c6e72f3d1ce3078dfe88eb Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Tue, 15 Nov 2011 16:20:06 -0500
Subject: [PATCH] Plug two more CTYPE leaks into fasls

 * (setf aref) would dump the declared element type on compile-time
   type mismatch.

 * same for function return value types (e.g. via (declare (values ...)))
---
 NEWS                             |    2 ++
 src/compiler/array-tran.lisp     |    3 ++-
 src/compiler/ir1tran-lambda.lisp |    2 +-
 tests/compiler.test.sh           |   23 +++++++++++++++++++++++
 4 files changed, 28 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 68e84be..094ae41 100644
--- a/NEWS
+++ b/NEWS
@@ -20,6 +20,8 @@ changes relative to sbcl-1.0.53:
     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)
+  * bug fix: type mismatch on (setf aref) and function return values no
+    longer result in fasl-dumping internal type objects.
 
 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/array-tran.lisp b/src/compiler/array-tran.lisp
index 38defe4..34d8840 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -1098,7 +1098,8 @@
              `(deftransform ,name ((array index ,@extra))
                 (let* ((type (lvar-type array))
                        (element-type (array-type-upgraded-element-type type))
-                       (declared-type (array-type-declared-element-type type)))
+                       (declared-type (type-specifier
+                                       (array-type-declared-element-type type))))
                   ;; If an element type has been declared, we want to
                   ;; use that information it for type checking (even
                   ;; if the access can't be optimized due to the array
diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 4ae5cae..2e9e66a 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -955,7 +955,7 @@
                             forms))
                  (forms (if (eq result-type *wild-type*)
                             forms
-                            `((the ,result-type (progn ,@forms)))))
+                            `((the ,(type-specifier result-type) (progn ,@forms)))))
                  (*allow-instrumenting* (and (not system-lambda) *allow-instrumenting*))
                  (res (cond ((or (find-if #'lambda-var-arg-info vars) keyp)
                              (ir1-convert-hairy-lambda forms vars keyp
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 39098a7..447505c 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -481,5 +481,28 @@ cat > $tmpfilename <<EOF
 EOF
 expect_clean_compile $tmpfilename
 
+cat > $tmpfilename <<EOF
+(in-package :cl-user)
+
+(defun foo ()
+  (declare (muffle-conditions warning))
+  (flet ((foo ()
+           (declare (values fixnum))
+           nil))
+    (foo)))
+EOF
+expect_clean_compile $tmpfilename
+
+cat > $tmpfilename <<EOF
+(in-package :cl-user)
+
+(defun foo (x)
+  (declare (muffle-conditions warning)
+           (type (vector (mod 7) 1) x))
+  (setf (aref x 0) 8)
+  x)
+EOF
+expect_clean_compile $tmpfilename
+
 # success
 exit $EXIT_TEST_WIN
-- 
1.7.10.4