Reorg to separate out files.

svn: r11857

collects/typed-scheme/main.ss

@@ -1,10 +1,12 @@
 #lang s-exp "minimal.ss"
            
+
+
 (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
                  (except "private/prims.ss"))
 	   (basics #%module-begin		   		   		   
 		   #%top-interaction
 		   lambda
 		   #%app))
-
+(require "private/base-env.ss" "private/base-special-env.ss")
 (provide (rename-out [with-handlers: with-handlers]))

collects/typed-scheme/minimal.ss

@@ -5,7 +5,7 @@
 
 (require (for-syntax scheme/base))
 
-(define-for-syntax ts-mod "typed-scheme.ss")
+(define-for-syntax ts-mod 'typed-scheme/typed-scheme)
 
 (define-syntax (providing stx)
   (syntax-case stx (libs from basics except)

collects/typed-scheme/private/base-special-env.ss

@@ -0,0 +1,83 @@
+#lang scheme/base
+
+;; these are libraries providing functions we add types to that are not in scheme/base
+(require
+ "extra-procs.ss"
+ "../utils/utils.ss"
+ (only-in scheme/list cons? take drop add-between last filter-map)
+ (only-in rnrs/lists-6 fold-left)
+ '#%paramz
+ (only-in scheme/match/runtime match:error)
+ scheme/promise
+ string-constants/string-constant)
+
+
+
+;; these are all for constructing the types given to variables
+(require (for-syntax
+          scheme/base
+          (env init-envs)          
+          (except-in (rep effect-rep type-rep) make-arr)
+          "type-effect-convenience.ss"
+          (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+          "union.ss"
+          (typecheck tc-structs)))
+
+(define-for-syntax (initialize-others) 
+  (d-s date 
+       ([second : N] [minute : N] [hour : N] [day : N] [month : N] 
+        [year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
+       ())
+  (d-s exn ([message : -String] [continuation-marks : Univ]) ())
+  (d-s (exn:fail exn) () (-String Univ))
+  (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
+  )
+
+(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
+         define-initial-env)
+
+(define-syntax (define-initial-env stx)
+    (syntax-case stx ()
+      [(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
+       (with-syntax ([(_ make-promise . _)
+                      (local-expand #'(delay 3)
+                                    'expression
+                                    null)]
+                     [language
+                      (local-expand #'(this-language)
+                                    'expression
+                                    null)]
+                     [(_ qq-append . _)
+                      (local-expand #'`(,@'() 1)
+                                    'expression
+                                    null)])
+         #`(define-for-syntax initial-env
+             (make-env
+              [make-promise make-promise-ty]
+              [language language-ty]
+              [qq-append qq-append-ty]
+              [id ty] ...)))]))
+
+
+
+
+(define-initial-env initial-env/special-case
+  ;; make-promise
+  (-poly (a) (-> (-> a) (-Promise a)))
+  ;; language
+  Sym
+  ;; qq-append
+  (-poly (a b) 
+         (cl->*
+          (-> (-lst a) (-val '()) (-lst a))
+          (-> (-lst a) (-lst b) (-lst (*Un a b))))))
+     
+     
+     
+
+(begin-for-syntax   
+  (initialize-type-env initial-env/special-case)
+  (initialize-others))
+
+
+

collects/typed-scheme/private/env-lang.ss

@@ -0,0 +1,34 @@
+#lang scheme/base
+
+(require "../utils/utils.ss")
+
+(require (for-syntax (private type-effect-convenience)
+                     (env init-envs)
+                     scheme/base
+                     (except-in (rep effect-rep type-rep) make-arr)
+                     "type-effect-convenience.ss"
+                     (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+                     "union.ss"))
+(define-syntax (#%module-begin stx)
+  (syntax-case stx (require)
+    [(mb (require . args) [id ty] ...)
+     (begin
+       (unless (andmap identifier? (syntax->list #'(id ...)))
+         (raise-syntax-error #f "not all ids"))
+       #'(#%plain-module-begin
+          (begin
+            (require . args)
+            (define-for-syntax e
+              (make-env [id ty] ...))
+            (begin-for-syntax
+              (initialize-type-env e)))))]
+    [(mb . rest)
+     #'(mb (require) . rest)]))
+
+(provide #%module-begin
+         require
+         (all-from-out scheme/base)
+         (for-syntax
+          (all-from-out scheme/base
+                        "type-effect-convenience.ss"
+                        "union.ss")))

collects/typed-scheme/private/type-effect-convenience.ss

@@ -13,7 +13,12 @@
          (for-syntax macro-debugger/stxclass/stxclass)
          (for-syntax scheme/base))
 
-(provide (all-defined-out))
+(provide (all-defined-out) 
+         ;; these should all eventually go away
+         make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
+
+(define (one-of/c . args)
+  (apply Un (map -val args)))
 
 (define (-vet id) (make-Var-True-Effect id))
 (define (-vef id) (make-Var-False-Effect id))
@@ -206,6 +211,8 @@
 
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
+(define -box make-Box)
+(define -vec make-Vector)
 
 (define Any-Syntax 
   (-mu x

collects/typed-scheme/typed-scheme.ss

@@ -2,7 +2,7 @@
 
 (require (rename-in "utils/utils.ss" [infer r:infer]))
 
-(require (private base-env base-types)
+(require (private #;base-env base-types)
          (for-syntax 
           scheme/base
 	  (private type-utils type-contract type-effect-convenience)