From 1eeef8e717014cc78b8059dcb495310739987948 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 6 Jan 2010 23:03:08 +0000
Subject: [PATCH] Put dynamic behavior of `check-expect' into functions. Give
 those functions types.

svn: r17519

original commit: c7cb124c954cb533d31d2dac165697780322e7c6
---
 .../typed-scheme/fail/check-expect-fail.ss    |  6 ++
 .../typed-scheme/succeed/check-expect.ss      |  6 ++
 .../typed-scheme/private/base-special-env.ss  | 58 ++++++++++++++-----
 3 files changed, 55 insertions(+), 15 deletions(-)
 create mode 100644 collects/tests/typed-scheme/fail/check-expect-fail.ss
 create mode 100644 collects/tests/typed-scheme/succeed/check-expect.ss

diff --git a/collects/tests/typed-scheme/fail/check-expect-fail.ss b/collects/tests/typed-scheme/fail/check-expect-fail.ss
new file mode 100644
index 00000000..92b38e8a
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/check-expect-fail.ss
@@ -0,0 +1,6 @@
+#lang typed/scheme
+
+(require test-engine/scheme-tests)
+(check-expect 3 (+ 1 'foo))
+
+(test)
diff --git a/collects/tests/typed-scheme/succeed/check-expect.ss b/collects/tests/typed-scheme/succeed/check-expect.ss
new file mode 100644
index 00000000..dddc43af
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/check-expect.ss
@@ -0,0 +1,6 @@
+#lang typed/scheme
+
+(require test-engine/scheme-tests)
+(check-expect 3 4)
+
+(test)
diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss
index 0e5de962..187da6e5 100644
--- a/collects/typed-scheme/private/base-special-env.ss
+++ b/collects/typed-scheme/private/base-special-env.ss
@@ -9,20 +9,18 @@
  '#%paramz
  (only-in scheme/match/runtime match:error)
  scheme/promise
- string-constants/string-constant)
+ string-constants/string-constant
+ (prefix-in ce: test-engine/scheme-tests)
+ (for-syntax
+  scheme/base syntax/parse
+  (utils tc-utils)
+  (env init-envs)          
+  (except-in (rep filter-rep object-rep type-rep) make-arr)
+  (types convenience union)
+  (only-in (types convenience) [make-arr* make-arr])          
+  (typecheck tc-structs)))
 
 
-
-;; these are all for constructing the types given to variables
-(require (for-syntax
-          scheme/base
-          (utils tc-utils)
-          (env init-envs)          
-          (except-in (rep filter-rep object-rep type-rep) make-arr)
-          (types convenience union)
-          (only-in (types convenience) [make-arr* make-arr])          
-          (typecheck tc-structs)))
-
 (define-for-syntax (initialize-others)
   (d-s srcloc
        ([source : Univ]
@@ -46,7 +44,7 @@
 
 (define-syntax (define-initial-env stx)
     (syntax-case stx ()
-      [(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
+      [(_ initial-env make-promise-ty language-ty qq-append-ty cl ...)
        (with-syntax ([(_ make-promise . _)
                       (local-expand #'(delay 3)
                                     'expression
@@ -64,7 +62,7 @@
               [make-promise make-promise-ty]
               [language language-ty]
               [qq-append qq-append-ty]
-              [id ty] ...)))]))
+              cl ...)))]))
 
 
 
@@ -78,7 +76,37 @@
   (-poly (a b) 
          (cl->*
           (-> (-lst a) (-val '()) (-lst a))
-          (-> (-lst a) (-lst b) (-lst (*Un a b))))))
+          (-> (-lst a) (-lst b) (-lst (*Un a b)))))
+  [(syntax-parse (local-expand #'(ce:test) 'expression null)
+                 #:context #'ce:test
+     [(_ ce-t:id) #'ce-t])
+   (-> -Void)]
+  
+  [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f)
+                 #:literals (let when define-values)
+    [(define-values _ 
+       (let ((_ _))
+         (when _ 
+           (insert-test _ (lambda () (check-values-expected _ _ _ _))))))
+     #'insert-test])
+   (Univ (-> Univ) . -> . -Void)]
+  [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f)
+                 #:literals (let when define-values)
+                 ;#:literal-sets (kernel-literals)
+    [(define-values _ 
+       (let ((_ _))
+         (when _ 
+           (insert-test _ (lambda () (check-values-expected _ _ _ _))))))
+     #'check-values-expected])
+   ((-> Univ) Univ Univ Univ . -> . -Void)]
+  [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f)
+                 #:literals (let when define-values)
+                 ;#:literal-sets (kernel-literals)
+    [(define-values _ 
+       (let ((_ (nvv _ _ builder _)))
+         _))
+     #'builder])
+   (-> Univ)])