Fix bug with use of match with ... and annotation.

svn: r16216

collects/tests/typed-scheme/succeed/match-dots2.ss

@@ -0,0 +1,9 @@
+#lang typed-scheme
+
+(require scheme/match)
+
+(: post-eval : -> Number)
+;; evaluates a postfix sequence of items, using a stack
+(define (post-eval)
+  (match '(1 2)
+    [(list (? number? #{stack : (Listof Number)}) ...) 3]))

collects/typed-scheme/typecheck/find-annotation.ss

@@ -1,9 +1,10 @@
 #lang scheme/base
 
 (require "../utils/utils.ss" syntax/parse
-         scheme/contract
+         scheme/contract scheme/trace
          (rep type-rep)
-         (private type-annotation))
+         (private type-annotation)
+         (for-template scheme/base))
 
 (p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))])
 
@@ -63,3 +64,5 @@
 	 (find #'body))]
     [e:core-expr
      (ormap find (syntax->list #'(e.expr ...)))]))
+
+;(trace find-annotation)

collects/typed-scheme/typecheck/tc-app.ss

@@ -143,17 +143,18 @@
 
 (define (let-loop-check form lp actuals args body expected)
   (syntax-parse #`(#,args #,body #,actuals) 
-    #:literals (#%plain-app if null?)
+    #:literals (#%plain-app if null? pair?)
     [((val acc ...)
-      ((if (#%plain-app null? val*) thn els))
+      ((~and inner-body (if (#%plain-app (~or pair? null?) val*) thn els)))
       (actual actuals ...))
+     #:fail-unless
      (and (free-identifier=? #'val #'val*)
-          (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a))
+          (ormap (lambda (a) (find-annotation #'inner-body a))
-                 (syntax->list #'(acc ...))))
+                 (syntax->list #'(acc ...)))) #f
      (let* ([ts1 (generalize (tc-expr/t #'actual))]
             [ann-ts (for/list ([a (in-syntax #'(acc ...))]
                                [ac (in-syntax #'(actuals ...))])
-                      (or (find-annotation #'(if (#%plain-app null? val*) thn els) a)
+                      (or (find-annotation #'inner-body a)
                           (generalize (tc-expr/t ac))))]
             [ts (cons ts1 ann-ts)])
        ;; check that the actual arguments are ok here
@@ -164,7 +165,7 @@
        (tc/rec-lambda/check form args body lp ts expected)
        expected)]
     ;; special case when argument needs inference
-    [_
+    [_     
      (let ([ts (for/list ([ac (syntax->list actuals)]
                           [f (syntax->list args)])
                  (or 

collects/typed-scheme/types/convenience.ss

@@ -31,6 +31,7 @@
       (match t*
         [(Value: '()) (-lst Univ)]
         [(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
+        [(Pair: t1 (Value: '())) (-lst t1)]
         [(Pair: t1 t2)
          (let ([t-new (loop t2)])
            (if (type-equal? (-lst t1) t-new)