Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/tests
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv21057/tests

Modified Files:
	compiler.pure.lisp 
Log Message:
1.0.43.71: fix regression from 1.0.43.26

  PROPAGATE-LOCAL-CALL-ARGS needs to special-case optional dispatch
  entry-points after all: our usual approach can load to too narrow
  types being derived for &OPTIONAL arguments.

  So just deal with &REST args in those cases.

  Closes bug 655203 again.


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.239
retrieving revision 1.240
diff -u -d -r1.239 -r1.240
--- compiler.pure.lisp	18 Oct 2010 11:42:47 -0000	1.239
+++ compiler.pure.lisp	19 Oct 2010 10:22:41 -0000	1.240
@@ -2684,6 +2684,16 @@
     (assert (eq 'list type))
     (assert derivedp)))
 
+(with-test (:name :rest-list-type-derivation3)
+  (multiple-value-bind (type derivedp)
+      (funcall (funcall (compile nil `(lambda ()
+                                        (lambda (&optional x &rest args)
+                                          (unless x (error "oops"))
+                                          (ctu:compiler-derived-type args)))))
+               t)
+    (assert (eq 'list type))
+    (assert derivedp)))
+
 (with-test (:name :base-char-typep-elimination)
   (assert (eq (funcall (lambda (ch)
                          (declare (type base-char ch) (optimize (speed 3) (safety 0)))
@@ -3620,3 +3630,17 @@
                     (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
                     :caught))))))
 
+(with-test (:name :bug-655203-regression)
+  (let ((fun (compile nil
+                      `(LAMBDA (VARIABLE)
+                         (LET ((CONTINUATION
+                                (LAMBDA
+                                    (&OPTIONAL DUMMY &REST OTHER)
+                                  (DECLARE (IGNORE OTHER))
+                                  (PRIN1 DUMMY)
+                                  (PRIN1 VARIABLE))))
+                           (FUNCALL CONTINUATION (LIST 1 2)))))))
+    ;; This used to signal a bogus type-error.
+    (assert (equal (with-output-to-string (*standard-output*)
+                     (funcall fun t))
+                   "(1 2)T"))))