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

all of types/ now compiles

Browse Source 
everything that doesn't use Un out of convenience.ss
added -out form for requires

svn: r13931
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-03 22:45:57 +00:00
parent 44902149cb
commit f05fcfcf13
5 changed files with 80 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,15 +2,14 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require (for-syntax (private type-effect-convenience)
(require (for-syntax (utils tc-utils)
(env init-envs)
scheme/base
(r:infer infer)
(only-in (r:infer infer-dummy) infer-param)
(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 object-rep filter-rep type-rep) make-arr)
(types convenience union)
(only-in (types convenience) [make-arr* make-arr])))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
@ -33,6 +32,5 @@
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"union.ss")))
(types convenience union)
(all-from-out scheme/base)))

7
collects/typed-scheme/types/abbrev.ss
View File

@ -218,3 +218,10 @@
(->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))]
[(t) (make-pred-ty (list Univ) B t)]))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))

36
collects/typed-scheme/types/convenience.ss
View File

@ -10,7 +10,7 @@
scheme/promise
(for-syntax stxclass)
(for-syntax scheme/base)
(for-template scheme/base scheme/contract scheme/tcp))
(for-template scheme/base))
(provide (all-defined-out)
(all-from-out "abbrev.ss")
@ -24,31 +24,6 @@
(apply Un (map tc-result-t args)))
(define-syntax (make-env stx)
(syntax-case stx ()
[(_ e ...)
#`(list
#,@(map (lambda (e)
(syntax-case e ()
[(nm ty)
(identifier? #'nm)
#`(list #'nm ty)]
[(e ty extra-mods ...)
#'(let ([x (list (let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))
ty)])
;(display x) (newline)
x)]))
(syntax->list #'(e ...))))]))
;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))
;; return t*
;; otherwise, return t
@ -67,14 +42,5 @@
[_ (exit t)]))))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))
;; DO NOT USE if t contains #f
(define (-opt t) (Un (-val #f) t))

24
collects/typed-scheme/utils/tc-utils.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(provide (all-defined-out))
(require "syntax-traversal.ss" (for-syntax scheme/base) scheme/match)
(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match)
;; a parameter representing the original location of the syntax being currently checked
(define current-orig-stx (make-parameter #'here))
@ -142,4 +142,24 @@
(define (add-type-name-reference t)
(type-name-references (cons t (type-name-references))))
;; environment constructor
(define-syntax (make-env stx)
(define-syntax-class spec
#:transparent
#:attributes (ty id)
(pattern [nm:identifier ty]
#:with id #'#'nm)
(pattern [e:expr ty extra-mods ...]
#:with id #'(let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))))
(syntax-parse stx
[(_ e:spec ...)
#'(list (list e.id e.ty) ...)]))

73
collects/typed-scheme/utils/utils.ss
View File

@ -1,11 +1,8 @@
#lang scheme/base
(require (for-syntax scheme/base stxclass)
scheme/contract
mzlib/plt-match
scheme/require-syntax
mzlib/struct
scheme/unit
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
mzlib/struct scheme/unit
(except-in stxclass id))
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
@ -24,33 +21,51 @@
(define-syntax (define-requirer stx)
(syntax-parse stx
[(_ nm:id)
[(_ nm:id nm-out:id)
#`(...
(define-require-syntax (nm stx)
(syntax-parse stx
[(_ id:identifier ...)
(with-syntax ([(id* ...)
(map (lambda (id)
(datum->syntax
id
`(file
,(path->string
(build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)))
(string-append (symbol->string (syntax-e id))
".ss"))))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))])))]))
(begin
(define-require-syntax (nm stx)
(syntax-parse stx
[(_ id:identifier ...)
(with-syntax ([(id* ...)
(map (lambda (id)
(datum->syntax
id
`(file
,(path->string
(build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)))
(string-append (symbol->string (syntax-e id))
".ss"))))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))]))
(define-provide-syntax (nm-out stx)
(syntax-parse stx
[(_ id:identifier ...)
(with-syntax ([(id* ...)
(map (lambda (id)
(datum->syntax
id
`(file
,(path->string
(build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)))
(string-append (symbol->string (syntax-e id))
".ss"))))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-out (all-from-out id*) ...)))]))
(provide nm nm-out)))]))
(define-requirer rep)
(define-requirer infer)
(define-requirer typecheck)
(define-requirer utils)
(define-requirer env)
(define-requirer private)
(define-requirer types)
(define-requirer rep rep-out)
(define-requirer infer infer-out)
(define-requirer typecheck typecheck-out)
(define-requirer utils utils-out)
(define-requirer env env-out)
(define-requirer private private-out)
(define-requirer types types-out)
(define-sequence-syntax in-syntax
(lambda () #'syntax->list)