From f0ec51670ce68146fded30ae66b811eee048d86e Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sat, 2 May 2009 12:46:53 +0000
Subject: [PATCH] fix values->tc-results, doesn't compile yet

svn: r14688

original commit: cce7f91b78955206b44c180c77b9c6d78be88ce4
---
 .../typed-scheme/typecheck/tc-lambda-unit.ss  |  2 +-
 .../typecheck/tc-metafunctions.ss             | 22 +++++++++++++++++--
 collects/typed-scheme/types/utils.ss          |  8 -------
 3 files changed, 21 insertions(+), 11 deletions(-)

diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
index f749365e..f3a4ebc3 100644
--- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
@@ -165,7 +165,7 @@
 
 ;(trace tc-args)
 
-;; tc/mono-lambda : syntax-list syntax-list -> (listof lam-result)
+;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result)
 ;; typecheck a sequence of case-lambda clauses
 (define (tc/mono-lambda formals bodies expected)
   (define (syntax-len s)
diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss
index 23144313..f1e3c854 100644
--- a/collects/typed-scheme/typecheck/tc-metafunctions.ss
+++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss
@@ -11,7 +11,7 @@
          (for-syntax scheme/base))
 
 (provide combine-filter apply-filter abstract-filter abstract-filters
-         split-lfilters merge-filter-sets)
+         split-lfilters merge-filter-sets values->tc-results)
 
 ;; this implements the sequence invariant described on the first page relating to Bot
 (define (lcombine l1 l2)
@@ -138,4 +138,22 @@
     [(f f* f*) f*]
     [(_ _ _)
      ;; could intersect f2 and f3 here
-     (make-FilterSet null null)]))
\ No newline at end of file
+     (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")]
+    [(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))))
+          (for/list ([lo los])
+            (for/list ([x formals] [i (in-naturals)])
+              (match lo
+                [(LEmpty:) (make-Empty)]
+                [(LPath: p (== i)) (make-Path p x)]))))]))
\ No newline at end of file
diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss
index d80088f7..6c0e49b1 100644
--- a/collects/typed-scheme/types/utils.ss
+++ b/collects/typed-scheme/types/utils.ss
@@ -290,11 +290,3 @@
      (make-ValuesDots (map make-Result ts fs os) dty dbound)]
     [(tc-results: ts fs os)
      (make-Values (map make-Result ts fs os))]))
-
-;; FIXME - this should really be a new metafunction like abstract-filter
-(define (values->tc-results tc)
-  (match tc
-    [(ValuesDots: (list (Result: ts fs os)) dty dbound)
-     (int-err "values->tc-results NYI for Dots")]
-    [(Values: (list (Result: ts fs os) ...))
-     (ret ts)]))
\ No newline at end of file