From 589ba9d77a6d120f5cf0ebcc926518db69d391bf Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 7 Jul 2008 16:43:12 -0400
Subject: [PATCH] Add require of scheme/promise for force. Handle
 call-with-values more appropriately.

---
 collects/typed-scheme/private/base-env.ss     | 10 +++----
 collects/typed-scheme/private/tc-app-unit.ss  | 28 +++++++++----------
 .../private/type-effect-convenience.ss        | 24 ++++++++--------
 3 files changed, 31 insertions(+), 31 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 88b2e8fbec..00c6d8e784 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -7,7 +7,8 @@
  (only-in scheme/list cons? take drop add-between last)
  (only-in rnrs/lists-6 fold-left)
  '#%paramz
- (only-in scheme/match/runtime match:error))
+ (only-in scheme/match/runtime match:error)
+ scheme/promise)
 
 
 
@@ -415,17 +416,16 @@
                  [(-Input-Port Sym) -String])]
      [copy-file (-> -Pathlike -Pathlike -Void)]  
      [bytes->string/utf-8 (-> -Bytes -String)]
+     
      ;; language
      [(expand '(this-language))
       Sym
       string-constants/string-constant]
-     ;; make-promise 
-     
+     ;; make-promise      
      [(cadr (syntax->list (expand '(delay 3))))
       (-poly (a) (-> (-> a) (-Promise a)))
       scheme/promise]
-     ;; qq-append
-     
+     ;; qq-append     
      [(cadr (syntax->list (expand '`(,@'() 1)))) 
       (-poly (a b) 
              (cl->*
diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss
index 49c42ce115..b8ce6bbb9d 100644
--- a/collects/typed-scheme/private/tc-app-unit.ss
+++ b/collects/typed-scheme/private/tc-app-unit.ss
@@ -522,21 +522,19 @@
      (int-err "bad do-make-object : ~a" (syntax->datum #'args))]
     ;; call-with-values
     [(#%plain-app call-with-values prod con)
-     (match-let* ([(tc-result: prod-t) (tc-expr #'prod)]
-                  [(tc-result: con-t) (tc-expr #'con)])
-       (match (list prod-t con-t)
-         [(list (Function: (list (arr: (list) vals #f #f _ _))) (Function: (list (arr: dom rng #f #f _ _))))
-          (=> unmatch)
-          (match (list vals dom)
-            [(list (Values: v) (list t ...))
-             (if (subtypes v t)
-                 (ret rng)
-                 (unmatch))]
-            [(list t1 (list t2))
-             (if (subtype t1 t2) (ret rng) (unmatch))]
-            [_ (unmatch)])]
-         [_ (tc-error "Incorrect arguments to call with values: ~a ~a" prod-t con-t)]))]
-    ;; special cases for `values'
+     (match-let* ([(tc-result: prod-t) (tc-expr #'prod)])
+       (define (values-ty->list t)
+         (match t
+           [(Values: ts) ts]
+           [_ (list t)]))
+       (match prod-t
+         [(Function: (list (arr: (list) vals _ #f _ _)))
+          (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
+         [_ (tc-error/expr #:return (ret (Un)) 
+                           "First argument to call with values must be a function that can accept no arguments, got: ~a"
+                           prod-t)]))]
+    ;; special cases for `values'    
+    ;; special case the single-argument version to preserve the effects
     [(#%plain-app values arg) (tc-expr #'arg)]
     [(#%plain-app values . args)
      (let ([tys (map tc-expr/t (syntax->list #'args))])
diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss
index 6f1667913a..9c9e11308e 100644
--- a/collects/typed-scheme/private/type-effect-convenience.ss
+++ b/collects/typed-scheme/private/type-effect-convenience.ss
@@ -213,17 +213,19 @@
                      (identifier? #'nm)
                      #`(list  #'nm ty)]
                     [(e ty extra-mods ...)
-                     #'(list (let ([new-ns
-                                    (let* ([ns (make-empty-namespace)])
-                                      (namespace-attach-module (current-namespace)
-                                                               'scheme/base
-                                                               ns)
-                                      ns)])
-                               (parameterize ([current-namespace new-ns])
-                                 (namespace-require 'scheme/base)
-                                 (namespace-require 'extra-mods) ...
-                                 e))
-                             ty)]))
+                     #'(let ([x (list (let ([new-ns
+                                             (let* ([ns (make-empty-namespace)])
+                                               (namespace-attach-module (current-namespace)
+                                                                        'scheme/base
+                                                                        ns)
+                                               ns)])
+                                        (parameterize ([current-namespace new-ns])
+                                          (namespace-require 'scheme/base)
+                                          (namespace-require 'extra-mods) ...
+                                          e))
+                                      ty)])
+                         ;(display x) (newline)
+                         x)]))
                 (syntax->list #'(e ...))))]))
 
 ;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))