Progress on delaying some environments.

collects/typed-scheme/main.rkt

@@ -10,11 +10,7 @@
 		   #%top-interaction
 		   lambda
 		   #%app))
-(require "private/base-env.rkt" 
+(require "private/extra-procs.rkt"
-	 "private/base-special-env.rkt"
-	 "private/base-env-numeric.rkt"
-	 "private/base-env-indexing.rkt"
-	 "private/extra-procs.rkt"
          (for-syntax "private/base-types-extra.rkt"))
 (provide (rename-out [with-handlers: with-handlers])
          (for-syntax (all-from-out "private/base-types-extra.rkt"))

collects/typed-scheme/private/base-env-indexing.rkt

@@ -1,11 +1,12 @@
-#lang scheme
+#lang racket/base
 
 (require
  (rename-in "../utils/utils.rkt" [infer r:infer])
- (for-syntax (types abbrev) (env init-envs) (r:infer infer-dummy infer)
+ (types abbrev) (env init-envs) (r:infer infer-dummy infer)
-             "base-env-indexing-abs.rkt"))
+ "base-env-indexing-abs.rkt")
 
-(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Integer)))
+(define e (parameterize ([infer-param infer]) (indexing -Integer)))
-(begin-for-syntax (initialize-type-env e))
+(define (initialize-indexing) (initialize-type-env e))
+(provide initialize-indexing)
 
 

collects/typed-scheme/private/base-env.rkt

@@ -11,8 +11,7 @@
  "extra-procs.rkt"
  (only-in '#%kernel [apply kernel:apply])
  (only-in racket/private/pre-base new-apply-proc)
- (for-syntax (only-in racket/private/pre-base new-apply-proc)
+ (for-syntax (only-in racket/private/pre-base new-apply-proc))
-             #;racket/string)
  scheme/promise scheme/system
  racket/mpair
  (only-in string-constants/private/only-once maybe-print-message)

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

@@ -1,16 +1,10 @@
 #lang racket/base
 
-;; these are libraries providing functions we add types to that are not in scheme/base
+;; this file cheats to define types for unexported variables that are expanded into by Racket macros
 (require
- "extra-procs.rkt"
  "../utils/utils.rkt"
- (only-in scheme/list cons? take drop add-between last filter-map)
+ racket/promise
- (only-in rnrs/lists-6 fold-left)
+ string-constants/string-constant 
- '#%paramz
- (only-in racket/match/runtime match:error)
- scheme/promise
- string-constants/string-constant
- ;(prefix-in ce: test-engine/scheme-tests)
  (for-syntax
   scheme/base syntax/parse
   (only-in unstable/syntax syntax-local-eval)
@@ -18,137 +12,42 @@
   (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])          
+  (only-in (types convenience) [make-arr* make-arr])))
-  (typecheck tc-structs))
- (for-meta 2 scheme/base syntax/parse))
-
-
-(define-for-syntax (initialize-others)
-
-  (define-syntax define-hierarchy
-    (syntax-rules (define-hierarchy)
-      [(_ parent ([name : type] ...)
-          (define-hierarchy child (spec ...) grand ...)
-          ...)
-       (begin
-         (d-s parent ([name : type] ...))
-         (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...)
-         ...)]))
-
-  (define-syntax define-sub-hierarchy
-    (syntax-rules (define-hierarchy)
-      [(_ [child parent] (inheritance ...) ([name : type] ...)
-          (define-hierarchy grandchild (spec ...) great ...)
-          ...)
-       (begin
-         (d-s [child parent] ([name : type] ...) (inheritance ...))
-         (define-sub-hierarchy [grandchild child]
-           (inheritance ... type ...) (spec ...)
-           great
-           ...)
-         ...)]))
-
-  (define-hierarchy srcloc
-    ([source : Univ]
-     [line : (*Un -Integer (-val #f))]
-     [column : (*Un -Integer (-val #f))]
-     [position : (*Un -Integer (-val #f))]
-     [span : (*Un -Integer (-val #f))]))
-
-  (define-hierarchy date 
-    ([second : -Number]
-     [minute : -Number]
-     [hour : -Number]
-     [day : -Number]
-     [month : -Number] 
-     [year : -Number]
-     [weekday : -Number]
-     [year-day : -Number]
-     [dst? : -Boolean]
-     [time-zone-offset : -Number]))
-  
-  (define-hierarchy arity-at-least
-    ([value : -Nat]))
-
-  (define-hierarchy exn
-    ([message : -String] [continuation-marks : -Cont-Mark-Set])
-    
-    (define-hierarchy exn:break ([continuation : top-func]))
-
-    (define-hierarchy exn:fail ()
-
-      (define-hierarchy exn:fail:contract ()
-        (define-hierarchy exn:fail:contract:arity ())
-        (define-hierarchy exn:fail:contract:divide-by-zero ())
-        (define-hierarchy exn:fail:contract:non-fixnum-result ())
-        (define-hierarchy exn:fail:contract:continuation ())
-        (define-hierarchy exn:fail:contract:variable ()))
-
-      (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))]))
-
-      (define-hierarchy exn:fail:read
-        ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc
-        (define-hierarchy exn:fail:read:eof ())
-        (define-hierarchy exn:fail:read:non-char ()))
-
-      (define-hierarchy exn:fail:filesystem ()
-        (define-hierarchy exn:fail:filesystem:exists ())
-        (define-hierarchy exn:fail:filesystem:version ()))
-
-      (define-hierarchy exn:fail:network ())
-
-      (define-hierarchy exn:fail:out-of-memory ())
-
-      (define-hierarchy exn:fail:unsupported ())
-
-      (define-hierarchy exn:fail:user ())))
-
-  ;; cce: adding exn:break would require a generic type for continuations
-
-  )
-
-(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
-         define-initial-env)
 
 (define-syntax (define-initial-env stx)
-    (syntax-case stx ()
+  (syntax-parse stx
-      [(_ initial-env make-promise-ty language-ty qq-append-ty
+    [(_ initialize-env [id-expr ty] ...)
-          [id-expr ty] ...)
+     (with-syntax ([(id ...)
-       (with-syntax ([(_ make-promise . _)
+                    (for/list ([expr (syntax->list #'(id-expr ...))])
-                      (local-expand #'(delay 3)
+                      (syntax-local-eval expr))])
-                                    'expression
+       #`(begin
-                                    null)]
+           (define-for-syntax initial-env
-                     [language
-                      (local-expand #'(this-language)
-                                    'expression
-                                    null)]
-                     [(_ qq-append . _)
-                      (local-expand #'`(,@'() 1)
-                                    'expression
-                                    null)]
-                     [(id ...)
-                      (for/list ([expr (syntax->list #'(id-expr ...))])
-                        (syntax-local-eval expr))])
-         #`(define-for-syntax initial-env
              (make-env
-              [make-promise make-promise-ty]
+              [id ty] ...))
-              [language language-ty]
+           (define-for-syntax (initialize-env)
-              [qq-append qq-append-ty]
+             (initialize-type-env initial-env))
-              [id ty] ...)))]))
+           (provide (for-syntax initialize-env))))]))
 
 
-
+(define-initial-env initialize-special
-
-(define-initial-env initial-env/special-case
   ;; make-promise
-  (-poly (a) (-> (-> a) (-Promise a)))
+  [(syntax-parse (local-expand #'(delay 3) 'expression null)
+     #:context #'make-promise
+     [(_ mp . _) #'mp])
+   (-poly (a) (-> (-> a) (-Promise a)))]
   ;; language
-  -Symbol
+  [(syntax-parse (local-expand #'(this-language) 'expression null)
+     #:context #'language
+     [lang #'lang])
+   -Symbol]
   ;; qq-append
-  (-poly (a b) 
+  [(syntax-parse (local-expand #'`(,@'() 1) 'expression null)
+     #:context #'qq-append
+     [(_ qqa . _) #'qqa])
+   (-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)))))]
   ;; make-sequence
   [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
      #:context #'make-sequence
@@ -234,12 +133,3 @@
       #'i-n])
    (->opt [-Input-Port -Symbol] (-seq -Bytes))])
 
-
-
-
-(begin-for-syntax   
-  (initialize-type-env initial-env/special-case)
-  (initialize-others))
-
-
-

collects/typed-scheme/private/base-structs.rkt

@@ -0,0 +1,99 @@
+#lang racket/base
+
+(require 
+ "../utils/utils.rkt"
+ (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))
+
+(require (for-template racket/base))
+
+(provide initialize-structs)
+
+(define-syntax define-hierarchy
+  (syntax-rules (define-hierarchy)
+    [(_ parent ([name : type] ...)
+        (define-hierarchy child (spec ...) grand ...)
+        ...)
+     (begin
+       (d-s parent ([name : type] ...))
+       (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...)
+       ...)]))
+
+(define-syntax define-sub-hierarchy
+  (syntax-rules (define-hierarchy)
+    [(_ [child parent] (inheritance ...) ([name : type] ...)
+        (define-hierarchy grandchild (spec ...) great ...)
+        ...)
+     (begin
+       (d-s [child parent] ([name : type] ...) (inheritance ...))
+       (define-sub-hierarchy [grandchild child]
+         (inheritance ... type ...) (spec ...)
+         great
+         ...)
+       ...)]))
+
+
+(define (initialize-structs)
+  
+
+  (define-hierarchy srcloc
+    ([source : Univ]
+     [line : (*Un -Integer (-val #f))]
+     [column : (*Un -Integer (-val #f))]
+     [position : (*Un -Integer (-val #f))]
+     [span : (*Un -Integer (-val #f))]))
+
+  (define-hierarchy date 
+    ([second : -Number]
+     [minute : -Number]
+     [hour : -Number]
+     [day : -Number]
+     [month : -Number] 
+     [year : -Number]
+     [weekday : -Number]
+     [year-day : -Number]
+     [dst? : -Boolean]
+     [time-zone-offset : -Number]))
+  
+  (define-hierarchy arity-at-least
+    ([value : -Nat]))
+
+  (define-hierarchy exn
+    ([message : -String] [continuation-marks : -Cont-Mark-Set])
+    
+    (define-hierarchy exn:break ([continuation : top-func]))
+
+    (define-hierarchy exn:fail ()
+
+      (define-hierarchy exn:fail:contract ()
+        (define-hierarchy exn:fail:contract:arity ())
+        (define-hierarchy exn:fail:contract:divide-by-zero ())
+        (define-hierarchy exn:fail:contract:non-fixnum-result ())
+        (define-hierarchy exn:fail:contract:continuation ())
+        (define-hierarchy exn:fail:contract:variable ()))
+
+      (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))]))
+
+      (define-hierarchy exn:fail:read
+        ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc
+        (define-hierarchy exn:fail:read:eof ())
+        (define-hierarchy exn:fail:read:non-char ()))
+
+      (define-hierarchy exn:fail:filesystem ()
+        (define-hierarchy exn:fail:filesystem:exists ())
+        (define-hierarchy exn:fail:filesystem:version ()))
+
+      (define-hierarchy exn:fail:network ())
+
+      (define-hierarchy exn:fail:out-of-memory ())
+
+      (define-hierarchy exn:fail:unsupported ())
+
+      (define-hierarchy exn:fail:user ())))
+
+  ;; cce: adding exn:break would require a generic type for continuations
+  )

collects/typed-scheme/typed-scheme.rkt

@@ -1,6 +1,11 @@
 #lang racket/base
 
-(require (for-syntax racket/base "typecheck/renamer.rkt"))
+(require (for-syntax racket/base "typecheck/renamer.rkt")
+         "private/base-special-env.rkt"
+         "private/base-env.rkt"
+         "private/base-env-numeric.rkt")
+
+(begin-for-syntax (initialize-special))
 
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]
@@ -10,15 +15,16 @@
          with-type)
 
 (define-syntax (module-begin stx)
-  (dynamic-require 'typed-scheme/private/base-env #f)
+  ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs))
-  (dynamic-require 'typed-scheme/private/base-env-numeric #f)
+  ((dynamic-require 'typed-scheme/private/base-env-indexing 'initialize-indexing))
-  (dynamic-require 'typed-scheme/private/base-env-indexing #f)
   ((dynamic-require 'typed-scheme/core 'mb-core) stx))
 
 (define-syntax (top-interaction stx)
+  ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs))
   ((dynamic-require 'typed-scheme/core 'ti-core) stx))
 
 (define-syntax (with-type stx)
+  ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs))
   ((dynamic-require 'typed-scheme/core 'wt-core) stx))