Split type defns into base-types.ss

Reformat.

svn: r9273

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

@@ -492,79 +492,5 @@
 (begin-for-syntax (initialize-type-env initial-env)
                   (initialize-others))
 
-;; the initial type name environment - just the base types
-(define-syntax (define-tname-env stx)
-  (syntax-case stx ()
-    [(_ var provider [nm ty] ...)
-     #`(begin
-         (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
-         (provide nm) ...
-         (define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
-         (provide provider)
-         (begin-for-syntax
-           (initialize-type-name-env
-            (list (list #'nm ty) ...))))]))
 
-(define-syntax (define-other-types stx)
-  (syntax-case stx ()
-    [(_ provider requirer nm ...)
-     (with-syntax ([(nms ...) (generate-temporaries #'(nm ...))])
-       (let ([body-maker (lambda (stx)
-                           (map (lambda (nm nms) (datum->syntax stx `(rename ,#'mod ,nm ,nms)))
-                                (syntax->list #'(nm ...))
-                                (syntax->list #'(nms ...))))])
-         #'(begin (define-syntax nms (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
-                  (provide nms) ...
-                  (define-syntax (requirer stx) 
-                    (syntax-case stx () 
-                      [(_ mod) 
-                       (datum->syntax
-                        stx
-                        `(require . ,(map (lambda (nm* nms*) (datum->syntax stx `(rename ,#'mod ,nm* ,nms*)))
-                                          (list 'nm ...)
-                                          (list #'nms ...))))]))                  
-                  (define-syntax provider (lambda (stx) #'(begin (provide (rename-out [nms nm])) ...)))
-                  (provide provider requirer))))]))
-
-;; the initial set of available type names
-(define-tname-env initial-type-names provide-tnames
-  [Number N]
-  [Integer -Integer]
-  [Void -Void]
-  [Boolean B]
-  [Symbol Sym]
-  [String -String]
-  [Any Univ]
-  [Port -Port]
-  [Path -Path]
-  [Regexp -Regexp]
-  [PRegexp -PRegexp]
-  [Char -Char]
-  [Option (-poly (a) (-opt a))]
-  [List (-lst Univ)]
-  [Listof -Listof]
-  [Namespace -Namespace]
-  [Input-Port -Input-Port]
-  [Output-Port -Output-Port]
-  [Bytes -Bytes]
-  [EOF (-val eof)]
-  [Keyword -Keyword]
-  [HashTable (-poly (a b) (-HT a b))]
-  [Promise (-poly (a) (-Promise a))]
-  [Pair (-poly (a b) (-pair a b))]
-  [Box (-poly (a) (make-Box a))]
-  [Syntax Any-Syntax]
-  [Identifier Ident]
-  )
-
-(define-other-types
-  provide-extra-tnames
-  require-extra-tnames
-  
-  
-  -> U mu Un All Opaque Vectorof
-  Parameter Tuple Class
-  )  
-
-(provide-extra-tnames)
 

collects/typed-scheme/private/base-types.ss

@@ -0,0 +1,112 @@
+#lang scheme/base
+
+(require (for-template (only-in (lib "list.ss") foldl)
+                       scheme/base
+                       '#%paramz
+                       scheme/promise
+                       string-constants/string-constant
+                       #;'#%more-scheme
+                       #;'#%qq-and-or
+                       (only-in scheme/match/patterns match:error))
+         )
+
+
+(require
+ "extra-procs.ss"
+ scheme/promise
+ (except-in "type-rep.ss" make-arr)
+ (only-in scheme/list cons?)
+ "type-effect-convenience.ss"
+ (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+ "union.ss"
+ string-constants/string-constant
+ (only-in scheme/match/patterns match:error)
+ "tc-structs.ss")
+
+(require (for-syntax
+          scheme/base
+          "init-envs.ss"
+          (except-in "type-rep.ss" make-arr)
+          (only-in (lib "list.ss") foldl)
+          "type-effect-convenience.ss"
+          (only-in "type-effect-convenience.ss" [make-arr* make-arr])
+          "union.ss"
+          string-constants/string-constant
+          (only-in scheme/match/patterns match:error)
+          "tc-structs.ss"))
+
+;; the initial type name environment - just the base types
+(define-syntax (define-tname-env stx)
+  (syntax-case stx ()
+    [(_ var provider [nm ty] ...)
+     #`(begin
+         (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
+         (provide nm) ...
+         (define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
+         (provide provider)
+         (begin-for-syntax
+           (initialize-type-name-env
+            (list (list #'nm ty) ...))))]))
+
+(define-syntax (define-other-types stx)
+  (syntax-case stx ()
+    [(_ provider requirer nm ...)
+     (with-syntax ([(nms ...) (generate-temporaries #'(nm ...))])
+       (let ([body-maker (lambda (stx)
+                           (map (lambda (nm nms) (datum->syntax stx `(rename ,#'mod ,nm ,nms)))
+                                (syntax->list #'(nm ...))
+                                (syntax->list #'(nms ...))))])
+         #'(begin (define-syntax nms (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
+                  (provide nms) ...
+                  (define-syntax (requirer stx) 
+                    (syntax-case stx () 
+                      [(_ mod) 
+                       (datum->syntax
+                        stx
+                        `(require . ,(map (lambda (nm* nms*) (datum->syntax stx `(rename ,#'mod ,nm* ,nms*)))
+                                          (list 'nm ...)
+                                          (list #'nms ...))))]))                  
+                  (define-syntax provider (lambda (stx) #'(begin (provide (rename-out [nms nm])) ...)))
+                  (provide provider requirer))))]))
+
+;; the initial set of available type names
+(define-tname-env initial-type-names provide-tnames
+  [Number N]
+  [Integer -Integer]
+  [Void -Void]
+  [Boolean B]
+  [Symbol Sym]
+  [String -String]
+  [Any Univ]
+  [Port -Port]
+  [Path -Path]
+  [Regexp -Regexp]
+  [PRegexp -PRegexp]
+  [Char -Char]
+  [Option (-poly (a) (-opt a))]
+  [List (-lst Univ)]
+  [Listof -Listof]
+  [Namespace -Namespace]
+  [Input-Port -Input-Port]
+  [Output-Port -Output-Port]
+  [Bytes -Bytes]
+  [EOF (-val eof)]
+  [Keyword -Keyword]
+  [HashTable (-poly (a b) (-HT a b))]
+  [Promise (-poly (a) (-Promise a))]
+  [Pair (-poly (a b) (-pair a b))]
+  [Box (-poly (a) (make-Box a))]
+  [Syntax Any-Syntax]
+  [Identifier Ident]
+  )
+
+(define-other-types
+  provide-extra-tnames
+  require-extra-tnames
+  
+  
+  -> U mu Un All Opaque Vectorof
+  Parameter Tuple Class
+  )  
+
+(provide-extra-tnames)

collects/typed-scheme/private/prims.ss

@@ -40,7 +40,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
          (except-in (lib "contract.ss") ->)
          (only-in (lib "contract.ss") [-> c->])
          (lib "struct.ss")
-         "base-env.ss")
+         "base-types.ss")
 
 
 

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

@@ -20,11 +20,13 @@
 ;; add a single type to the mapping
 ;; identifier type -> void
 (define (register-type id type)
+  ;(printf "register-type ~a~n" (syntax-e id))
   (module-identifier-mapping-put! the-mapping id type))
 
 ;; add a single type to the mapping
 ;; identifier type -> void
 (define (register-type/undefined id type)
+  ;(printf "register-type/undef ~a~n" (syntax-e id))
   (module-identifier-mapping-put! the-mapping id (box type)))
 
 ;; add a bunch of types to the mapping

collects/typed-scheme/private/typechecker.ss

@@ -3,7 +3,7 @@
 (require "unit-utils.ss"
          mzlib/trace
          (only-in mzlib/unit provide-signature-elements)
-         "signatures.ss" #;"typechecker-unit.ss" "tc-toplevel.ss"
+         "signatures.ss" "tc-toplevel.ss"         
          "tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss"
          "tc-let-unit.ss"
          "tc-expr-unit.ss" "check-subforms-unit.ss")
@@ -11,6 +11,4 @@
 (provide-signature-elements typechecker^)
 
 (define-values/link-units/infer
-  ;typechecker@ 
-  tc-toplevel@
-  tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@)
+  tc-toplevel@ tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@)

collects/typed-scheme/typed-scheme.ss

@@ -5,6 +5,7 @@
          "private/extra-procs.ss"
          "private/internal-forms.ss"
          "private/base-env.ss"
+         "private/base-types.ss"
          (for-syntax 
           scheme/base
           "private/type-utils.ss"