`values->tc-results' needs the formals

Fix values->tc-results for ValuesDots
Don't generate problematic nested lists.
Fix stupid typo.
Parsing of tc-results now doesn't use parsing of values, which does something different.

svn: r14713

original commit: 9c538764dcd499d9b8a04b415a88835ccd55f1c9

collects/typed-scheme/private/parse-type.ss

@@ -566,7 +566,11 @@
        (-values (list (parse-type #'t)))])))
 
 (define (parse-tc-results stx)
-  (values->tc-results (parse-values-type stx)))
+  (syntax-parse stx
+    [(values t ...)
+     #:when (eq? 'values (syntax-e #'values))
+     (ret (map parse-type (syntax->list #'(t ...))))]
+    [t (parse-type #'t)]))
 
 (define parse-tc-results/id (parse/id parse-tc-results))
 

collects/typed-scheme/test2.ss

@@ -4,6 +4,7 @@
 (define (f x z) (f x z))
 (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x)))
 (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y)))
+(lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y)))
 (lambda: ([x : Any]) (values (number? x) (number? x)))
 (: g (Any -> Boolean : Number))
 (define g (lambda: ([x : Any]) (number? x)))

collects/typed-scheme/typecheck/tc-lambda-unit.ss

@@ -199,7 +199,8 @@
          [(tc-result1: (Mu: _ _)) (loop (unfold expected))]
          [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...)))
           (for/list ([args argss] [ret rets] [rest rests] [drest drests])
-            (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args (values->tc-results ret) rest drest))]
+            (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies))
+                                    args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))]
          [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))]
     ;; otherwise
     [else (go (syntax->list formals) (syntax->list bodies) null null null)]))

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

@@ -134,26 +134,40 @@
     ;; or
     [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (combine null (append f1- f3-))]
     ;; and
-    [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (combine (append f1+ f2+) null)]
+    [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) 
+     (combine (append f1+ f2+) null)]
     [(f f* f*) f*]
     [(_ _ _)
      ;; could intersect f2 and f3 here
      (make-FilterSet null null)]))
 
-
-;; FIXME - this should really be a new metafunction like abstract-filter
 ;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results?
 (define (values->tc-results tc formals)
   (match tc
-    [(ValuesDots: (list (Result: ts fs os)) dty dbound)
-     (int-err "values->tc-results NYI for Dots")]
+    [(ValuesDots: (list (Result: ts lfs los)) dty dbound)
+     (ret ts
+          (for/list ([lf lfs]) 
+            (merge-filter-sets
+             (for/list ([x formals] [i (in-naturals)])
+               (apply-filter (split-lfilters lf i) Univ (make-Path null x)))))
+          (for/list ([lo los])
+            (or 
+             (for/or ([x formals] [i (in-naturals)])
+               (match lo
+                 [(LEmpty:) #f]
+                 [(LPath: p (== i)) (make-Path p x)]))
+             (make-Empty)))
+          dty dbound)]
     [(Values: (list (Result: ts lfs los) ...))
      (ret ts
           (for/list ([lf lfs]) 
-            (for/list ([x formals] [i (in-naturals)])
-              (apply-filter (split-lfilters lf i) Univ (make-Path null x))))
+            (merge-filter-sets
+             (for/list ([x formals] [i (in-naturals)])
+               (apply-filter (split-lfilters lf i) Univ (make-Path null x)))))
           (for/list ([lo los])
-            (for/list ([x formals] [i (in-naturals)])
-              (match lo
-                [(LEmpty:) (make-Empty)]
-                [(LPath: p (== i)) (make-Path p x)]))))]))
+            (or 
+             (for/or ([x formals] [i (in-naturals)])
+               (match lo
+                 [(LEmpty:) #f]
+                 [(LPath: p (== i)) (make-Path p x)]))
+             (make-Empty))))]))

collects/typed-scheme/typecheck/tc-new-if.ss

@@ -28,7 +28,7 @@
        (cond [(= (length ts) (length us))
               (ret (for/list ([t ts] [u us]) (Un t u))
                    (for/list ([f2 fs2] [f3 fs3])
-                             (combine-filter f1 f2 f2)))]
+                             (combine-filter f1 f2 f3)))]
              [else
               (tc-error/expr #:return (ret Err)
                              "Expected the same number of values from both branches of if expression, but got ~a and ~a"

collects/typed-scheme/types/utils.ss

@@ -30,9 +30,7 @@
          just-Dotted?
          tc-error/expr
          lookup-fail
-         lookup-type-fail
-         values->tc-results
-         tc-results->values)
+         lookup-type-fail)
 
 
 ;; substitute : Type Name Type -> Type
@@ -197,7 +195,8 @@
                  (cond [(Type? t)
                         (list (make-tc-result t (make-FilterSet null null) (make-Empty)))]
                        [(or (Values? t) (ValuesDots? t))
-                        (values->tc-results t)]
+                        (int-err "Values in ret: ~a" t)
+                        #;(values->tc-results t)]
                        [else
                         (for/list ([i t])
                           (make-tc-result i (make-FilterSet null null) (make-Empty)))])
@@ -283,10 +282,3 @@
 
 (define (lookup-type-fail i)
   (tc-error/expr "~a is not bound as a type" (syntax-e i)))
-
-(define (tc-results->values tc)
-  (match tc
-    [(tc-results: ts fs os dty dbound)
-     (make-ValuesDots (map make-Result ts fs os) dty dbound)]
-    [(tc-results: ts fs os)
-     (make-Values (map make-Result ts fs os))]))