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

all of private, and tc-structs, now compiles

Browse Source 
svn: r13956

original commit: 00721c10c80eae7fe51bea7593c1cab181820716
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-04 19:49:20 +00:00
parent 361712cb27
commit 6cafdd4a5d
7 changed files with 28 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,11 +16,11 @@
;; these are all for constructing the types given to variables
(require (for-syntax
scheme/base
(utils tc-utils)
(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"
(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)

8
collects/typed-scheme/private/parse-type.ss
View File

@ -4,17 +4,13 @@
(require (except-in "../utils/utils.ss" extend id))
(require (except-in (rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
(utils tc-utils)
"union.ss"
(rename-in (types convenience union utils) [make-arr* make-arr])
(utils tc-utils stxclass-util)
syntax/stx
stxclass stxclass/util
(env type-environments type-name-env type-alias-env)
"type-utils.ss"
(prefix-in t: "base-types-extra.ss")
scheme/match
"stxclass-util.ss"
(for-template scheme/base "base-types-extra.ss"))
(define enable-mu-parsing (make-parameter #t))

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

@ -37,7 +37,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(env type-name-env)
"type-contract.ss"))
(require "require-contract.ss"
(require (utils require-contract)
(typecheck internal-forms)
(except-in mzlib/contract ->)
(only-in mzlib/contract [-> c->])

4
collects/typed-scheme/private/type-annotation.ss
View File

@ -4,8 +4,8 @@
(require (rep type-rep)
(utils tc-utils)
(env type-env)
"parse-type.ss" "subtype.ss"
"type-effect-convenience.ss" "resolve-type.ss" "union.ss"
(types subtype union convenience resolve)
(private parse-type)
scheme/match mzlib/trace)
(provide type-annotation
get-type

25
collects/typed-scheme/private/type-contract.ss
View File

@ -6,14 +6,11 @@
(require
(rep type-rep)
(typecheck internal-forms)
(utils tc-utils)
(utils tc-utils require-contract)
(env type-name-env)
"parse-type.ss"
"require-contract.ss"
"resolve-type.ss"
"type-utils.ss"
(only-in "type-effect-convenience.ss" Any-Syntax)
(prefix-in t: "type-effect-convenience.ss")
(types resolve utils)
(prefix-in t: (types convenience))
(private parse-type)
scheme/match
syntax/struct
syntax/stx
@ -61,7 +58,7 @@
;; we special-case lists:
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
#`(listof #,(t->c elem-ty))]
[(? (lambda (e) (eq? Any-Syntax e))) #'syntax?]
[(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?]
[(Base: sym cnt) cnt]
[(Union: elems)
(with-syntax
@ -73,13 +70,13 @@
(define (f a)
(define-values (dom* rngs* rst)
(match a
[(arr: dom (Values: rngs) #f #f '() _ _)
[(arr: dom (Values: rngs) #f #f '())
(values (map t->c dom) (map t->c rngs) #f)]
[(arr: dom rng #f #f '() _ _)
[(arr: dom rng #f #f '())
(values (map t->c dom) (list (t->c rng)) #f)]
[(arr: dom (Values: rngs) rst #f '() _ _)
[(arr: dom (Values: rngs) rst #f '() )
(values (map t->c dom) (map t->c rngs) (t->c rst))]
[(arr: dom rng rst #f '() _ _)
[(arr: dom rng rst #f '())
(values (map t->c dom) (list (t->c rng)) (t->c rst))]))
(with-syntax
([(dom* ...) dom*]
@ -91,7 +88,7 @@
#'((dom* ...) () #:rest (listof rst*) . ->* . rng*)
#'(dom* ... . -> . rng*))))
(unless (no-duplicates (for/list ([t arrs])
(match t [(arr: dom _ _ _ _ _ _) (length dom)])))
(match t [(arr: dom _ _ _ _) (length dom)])))
(exit (fail)))
(match (map f arrs)
[(list e) e]
@ -116,7 +113,7 @@
[(Struct: _ _ _ _ #f pred? cert) (cert pred?)]
[(Syntax: (Base: 'Symbol _)) #'identifier?]
[(Syntax: t)
(if (equal? ty Any-Syntax)
(if (equal? ty t:Any-Syntax)
#`syntax?
#`(syntax/c #,(t->c t)))]
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]

17
collects/typed-scheme/private/type-env-lang.ss
View File

@ -2,14 +2,10 @@
(require "../utils/utils.ss")
(require (for-syntax (private type-effect-convenience)
(env init-envs)
(require (for-syntax (env init-envs)
scheme/base
(except-in (rep effect-rep type-rep) make-arr)
(except-in "../rep/type-rep.ss" make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"))
(except-in (rep filter-rep type-rep) make-arr)
(rename-in (types union convenience) [make-arr* make-arr])))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
@ -35,7 +31,6 @@
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"../rep/type-rep.ss"
"union.ss")))
(types-out convenience union)
(rep-out type-rep)
(all-from-out scheme/base)))

5
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -2,9 +2,8 @@
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(private type-effect-convenience
type-utils parse-type
union resolve-type)
(private parse-type)
(types convenience utils union resolve)
(env type-env type-environments type-name-env)
(utils tc-utils)
"def-binding.ss"