suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split type defns into base-types.ss

Browse Source 
Reformat.

svn: r9273

original commit: f23af68d6b0bbc9a82f8fea2178e5e7dfaf2d459
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-12 00:10:32 +00:00
parent 979ec97b18
commit 51b7de58e8
4 changed files with 114 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/typed-scheme/private/base-env.ss
View File

@ -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)

112
collects/typed-scheme/private/base-types.ss Normal file
View File

@ -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)

2
collects/typed-scheme/private/prims.ss
View File

@ -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")

1
collects/typed-scheme/typed-scheme.ss
View File

@ -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"