From a28478f4f22bf6753eb18c44d5205726f87a0ead Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 19 Mar 2010 20:35:15 +0000
Subject: [PATCH] 1.0.36.33: handle missing &REST in proclamations

 * FIND-OPTIONAL-DISPATCH-TYPES cannot skip &REST verification in the
   presence of &KEY.

 Fixes launchpad bug #458354.
---
 NEWS                       |    2 ++
 src/compiler/ctype.lisp    |   39 ++++++++++++++++++++++++++++++---------
 tests/compiler.impure.lisp |   17 +++++++++++++++++
 version.lisp-expr          |    2 +-
 4 files changed, 50 insertions(+), 10 deletions(-)

diff --git a/NEWS b/NEWS
index b0813e2..a1f166b 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,8 @@ changes relative to sbcl-1.0.36:
     due to it, so that handlers can run.
   * bug fix: reparsing undefined types if they have become defined since
     parsing. (lp#309128)
+  * bug fix: missing &REST type in a proclamation for a function with both
+    &REST and &KEY in lambda-list caused miscompilation (lp#458354)
 
 changes in sbcl-1.0.36 relative to sbcl-1.0.35:
   * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and
diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 1470a49..f853997 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -616,7 +616,7 @@
       (unless (optional-dispatch-keyp od)
         (frob (not (null (optional-dispatch-more-entry od)))
               (not (null (fun-type-rest type)))
-              "&REST arguments"))
+              "&REST argument"))
       (frob (optional-dispatch-allowp od) (fun-type-allowp type)
             "&ALLOW-OTHER-KEYS"))
 
@@ -776,14 +776,35 @@
   (let ((type (info :function :type name))
         (where (info :function :where-from name)))
     (when (eq where :declared)
-      (setf (leaf-type fun) type)
-      (assert-definition-type
-       fun type
-       :unwinnage-fun #'compiler-notify
-       :where "proclamation"
-       :really-assert (not (awhen (info :function :info name)
-                             (ir1-attributep (fun-info-attributes it)
-                                             explicit-check)))))))
+      (let ((type (massage-global-definition-type type fun)))
+        (setf (leaf-type fun) type)
+        (assert-definition-type
+         fun type
+         :unwinnage-fun #'compiler-notify
+         :where "proclamation"
+         :really-assert (not (awhen (info :function :info name)
+                               (ir1-attributep (fun-info-attributes it)
+                                               explicit-check))))))))
+
+;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
+;;; doesn't complain about the type missing &REST -- which is good, because in
+;;; that case &REST is really an implementation detail and not part of the
+;;; interface. However since we set the leaf type missing &REST from there
+;;; would be a bad thing -- to make up a new type if necessary.
+(defun massage-global-definition-type (type fun)
+  (if (and (fun-type-p type)
+           (optional-dispatch-p fun)
+           (optional-dispatch-keyp fun)
+           (optional-dispatch-more-entry fun)
+           (not (fun-type-rest type)))
+      (make-fun-type :required (fun-type-required type)
+                     :optional (fun-type-optional type)
+                     :rest *universal-type*
+                     :keyp (fun-type-keyp type)
+                     :keywords (fun-type-keywords type)
+                     :allowp (fun-type-allowp type)
+                     :returns (fun-type-returns type))
+      type))
 
 ;;; Call FUN with (arg-lvar arg-type)
 (defun map-combination-args-and-types (fun call)
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index f410d4d..70b7bc7 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1166,6 +1166,23 @@
   (let ((x (make-instance 'some-slot-thing :slot "foo")))
     (with-slots (slot) (the some-slot-thing x)
       (assert (equal "foo" slot)))))
+
+;;; Missing &REST type in proclamation causing a miscompile.
+(declaim (ftype
+          (function
+           (sequence unsigned-byte
+                     &key (:initial-element t) (:initial-contents sequence))
+           (values sequence &optional))
+          bug-458354))
+(defun bug-458354
+    (sequence length
+     &rest keys
+     &key (initial-element nil iep) (initial-contents nil icp))
+  (declare (sb-ext:unmuffle-conditions style-warning))
+  (declare (ignorable keys initial-element iep initial-contents icp))
+  (apply #'sb-sequence:make-sequence-like sequence length keys))
+(with-test (:name :bug-458354)
+  (assert (equalp #((a b) (a b)) (bug-458354 #(1 2) 2 :initial-element '(a b)))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
diff --git a/version.lisp-expr b/version.lisp-expr
index 2f66a6e..c2a2ebb 100644
--- 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.36.32"
+"1.0.36.33"
-- 
1.7.10.4