From 917307bd2e8f8dccad9bfcc27261f30e19cc87cb Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 22 Sep 2008 21:37:13 +0000
Subject: [PATCH] Fix delay/force.

svn: r11841
---
 .../private/type-effect-convenience.ss        |  6 ++++--
 .../typed-scheme/typecheck/tc-app-unit.ss     | 19 ++++++++++++++++++-
 2 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss
index 13aa199c91..e0af0bbacf 100644
--- a/collects/typed-scheme/private/type-effect-convenience.ss
+++ b/collects/typed-scheme/private/type-effect-convenience.ss
@@ -104,8 +104,10 @@
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #f (cons dty dbound) null null))
 
-(define (make-promise-ty t)
-  (make-Struct (string->uninterned-symbol "Promise") #f (list t) #f #f #'promise? values))
+(define make-promise-ty
+  (let ([s (string->uninterned-symbol "Promise")])
+    (lambda (t)
+      (make-Struct s #f (list t) #f #f #'promise? values))))
 
 (define N (make-Base 'Number))
 (define -Integer (make-Base 'Integer))
diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss
index 3e7ba3fdd6..7b0b080852 100644
--- a/collects/typed-scheme/typecheck/tc-app-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-app-unit.ss
@@ -606,10 +606,27 @@
     [(Value: '()) null]
     [_ (int-err "bad value in type->list: ~a" t)]))
 
+;; id: identifier
+;; sym: a symbol
+;; mod: a quoted require spec like 'scheme/base
+;; is id the name sym defined in mod?
+(define (id-from? id sym mod)
+  (and (eq? (syntax-e id) sym)
+       (eq? (module-path-index-resolve (syntax-source-module id))
+            ((current-module-name-resolver) mod #f #f #f))))
+
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
     (values apply not list list* call-with-values do-make-object make-object cons
-            andmap ormap) ;; the special-cased functions   
+            andmap ormap) ;; the special-cased functions
+    ;; special case for delay
+    [(#%plain-app 
+      mp1 
+      (#%plain-lambda () 
+        (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
+     (and (id-from? #'mp1 'make-promise 'scheme/promise)
+          (id-from? #'mp2 'make-promise 'scheme/promise))
+     (ret (-Promise (tc-expr/t #'e)))]
     ;; special cases for classes
     [(#%plain-app make-object cl . args)     
      (check-do-make-object #'cl #'args #'() #'())]