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

Reorg to separate out files.

Browse Source 
svn: r11857
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-24 19:56:48 +00:00
parent 9b6a8d2e5a
commit 15e7be91f5
7 changed files with 593 additions and 558 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/main.ss
View File

@ -1,10 +1,12 @@
#lang s-exp "minimal.ss"
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
(except "private/prims.ss"))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require "private/base-env.ss" "private/base-special-env.ss")
(provide (rename-out [with-handlers: with-handlers]))

2
collects/typed-scheme/minimal.ss
View File

@ -5,7 +5,7 @@
(require (for-syntax scheme/base))
(define-for-syntax ts-mod "typed-scheme.ss")
(define-for-syntax ts-mod 'typed-scheme/typed-scheme)
(define-syntax (providing stx)
(syntax-case stx (libs from basics except)

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

@ -1,100 +1,18 @@
#lang scheme/base
#lang s-exp "env-lang.ss"
;; these are libraries providing functions we add types to that are not in scheme/base
(require
"extra-procs.ss"
"../utils/utils.ss"
(only-in scheme/list cons? take drop add-between last filter-map)
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in scheme/match/runtime match:error)
scheme/promise
string-constants/string-constant)
;; these are all for constructing the types given to variables
(require (for-syntax
scheme/base
(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"
(typecheck tc-structs)))
(define-for-syntax (initialize-others)
(d-s date
([second : N] [minute : N] [hour : N] [day : N] [month : N]
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
())
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
(d-s (exn:fail exn) () (-String Univ))
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
)
(provide (for-syntax initial-env initialize-others))
(define-syntax (define-initial-env stx)
(syntax-case stx ()
[(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
(with-syntax ([(_ make-promise . _)
(local-expand #'(delay 3)
'expression
null)]
[language
(local-expand #'(this-language)
'expression
null)]
[(_ qq-append . _)
(local-expand #'`(,@'() 1)
'expression
null)])
#`(define-for-syntax initial-env
(make-env
[make-promise make-promise-ty]
[language language-ty]
[qq-append qq-append-ty]
[id ty] ...)))]))
(define-for-syntax (one-of/c . args)
(apply Un (map -val args)))
(define-initial-env initial-env
;; make-promise
(-poly (a) (-> (-> a) (-Promise a)))
;; language
Sym
;; qq-append
(-poly (a b)
(cl->*
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b)))))
#|;; language
[(expand '(this-language))
Sym
string-constants/string-constant]
;; make-promise
[(cadr (syntax->list (expand '(delay 3))))
(-poly (a) (-> (-> a) (-Promise a)))
scheme/promise]
;; qq-append
[(cadr (syntax->list (expand '`(,@'() 1))))
(-poly (a b)
(cl->*
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b)))))]
|#
(only-in scheme/match/runtime match:error))
[raise (Univ . -> . (Un))]
(car (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
[((make-Listof (-v a))) (-v a)])))
[first (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
[((make-Listof (-v a))) (-v a)]))]
(car (-poly (a b) (cl-> [((-pair a b)) a]
[((make-Listof a)) a])))
[first (-poly (a b) (cl-> [((-pair a b)) a]
[((make-Listof a)) a]))]
[second (-poly (a b c)
(cl->
[((-pair a (-pair b c))) b]
@ -114,10 +32,10 @@
[((-lst a)) a])))
(caddr (-poly (a) (-> (-lst a) a)))
(cadddr (-poly (a) (-> (-lst a) a)))
(cdr (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v b)]
[((make-Listof (-v a))) (make-Listof (-v a))])))
(cddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
(cdddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
(cdr (-poly (a b) (cl-> [((-pair a b)) b]
[((make-Listof a)) (make-Listof a)])))
(cddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
(cdddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
(cons (-poly (a b)
(cl-> [(a (-lst a)) (-lst a)]
[(a b) (-pair a b)])))
@ -165,10 +83,10 @@
[(-Port) -Void])]
[not (-> Univ B)]
[floor (-> N N)]
[box (-poly (a) (a . -> . (make-Box a)))]
[unbox (-poly (a) ((make-Box a) . -> . a))]
[set-box! (-poly (a) ((make-Box a) a . -> . -Void))]
[box? (make-pred-ty (make-Box Univ))]
[box (-poly (a) (a . -> . (-box a)))]
[unbox (-poly (a) ((-box a) . -> . a))]
[set-box! (-poly (a) ((-box a) a . -> . -Void))]
[box? (make-pred-ty (-box Univ))]
[cons? (make-pred-ty (-pair Univ Univ))]
[pair? (make-pred-ty (-pair Univ Univ)) #;(-poly (a b) (make-pred-ty (-pair a b)))]
[empty? (make-pred-ty (-val null))]
@ -237,8 +155,8 @@
[printf (->* (list -String) Univ -Void)]
[fprintf (->* (list -Output-Port -String) Univ -Void)]
[format (->* (list -String) Univ -String)]
(fst (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v a))))
(snd (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v b))))
(fst (-poly (a b) (-> (-pair a b) a)))
(snd (-poly (a b) (-> (-pair a b) b)))
(= (->* (list N N) N B))
(>= (->* (list N N) N B))
@ -253,14 +171,14 @@
(max (->* (list N) N N))
(min (->* (list N) N N))
[vector-ref
(make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))]
(-poly (a) ((-vec a) N . -> . a))]
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))]
[build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))]
[reverse (make-Poly '(a) (-> (make-Listof (-v a)) (make-Listof (-v a))))]
[reverse (-poly (a) (-> (make-Listof a) (make-Listof a)))]
[append (-poly (a) (->* (list) (-lst a) (-lst a)))]
[length (make-Poly '(a) (-> (make-Listof (-v a)) -Integer))]
[memq (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
[memv (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
[length (-poly (a) (-> (make-Listof a) -Integer))]
[memq (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
[memv (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
[memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))]
[member
(-poly (a) (a (-lst a) . -> . (-opt (-lst a))))]
@ -354,7 +272,7 @@
[current-namespace (-Param -Namespace -Namespace)]
[print-struct (-Param B B)]
[read-decimal-as-inexact (-Param B B)]
[current-command-line-arguments (-Param (make-Vector -String) (make-Vector -String))]
[current-command-line-arguments (-Param (-vec -String) (-vec -String))]
;; regexp stuff
[regexp-match
@ -389,14 +307,14 @@
[match:error ((list) Univ . ->* . (Un))]
[vector-set! (-poly (a) (-> (make-Vector a) N a -Void))]
[vector-set! (-poly (a) (-> (-vec a) N a -Void))]
[vector->list (-poly (a) (-> (make-Vector a) (-lst a)))]
[list->vector (-poly (a) (-> (-lst a) (make-Vector a)))]
[vector->list (-poly (a) (-> (-vec a) (-lst a)))]
[list->vector (-poly (a) (-> (-lst a) (-vec a)))]
[exact? (N . -> . B)]
[inexact? (N . -> . B)]
[expt (cl->* (-Integer -Integer . -> . -Integer) (N N . -> . N))]
[vector (-poly (a) (->* (list) a (make-Vector a)))]
[vector (-poly (a) (->* (list) a (-vec a)))]
[real? (Univ . -> . B)]
[real-part (N . -> . N)]
[imag-part (N . -> . N)]
@ -419,13 +337,13 @@
[make-vector
(-poly (a)
(cl->
[(N) (make-Vector N)]
[(N a) (make-Vector a)]))]
[(N) (-vec N)]
[(N a) (-vec a)]))]
[file-exists? (-Pathlike . -> . B)]
[string->symbol (-String . -> . Sym)]
[symbol->string (Sym . -> . -String)]
[vector-length (-poly (a) ((make-Vector a) . -> . N))]
[vector-length (-poly (a) ((-vec a) . -> . N))]
[call-with-input-file (-poly (a)
(cl->
@ -563,12 +481,3 @@
[eof (-val eof)]
[read-accept-reader (-Param B B)]
)
(begin-for-syntax
#;(printf "running base-env~n")
(initialize-type-env initial-env)
(initialize-others))

83
collects/typed-scheme/private/base-special-env.ss Normal file
View File

@ -0,0 +1,83 @@
#lang scheme/base
;; these are libraries providing functions we add types to that are not in scheme/base
(require
"extra-procs.ss"
"../utils/utils.ss"
(only-in scheme/list cons? take drop add-between last filter-map)
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in scheme/match/runtime match:error)
scheme/promise
string-constants/string-constant)
;; these are all for constructing the types given to variables
(require (for-syntax
scheme/base
(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"
(typecheck tc-structs)))
(define-for-syntax (initialize-others)
(d-s date
([second : N] [minute : N] [hour : N] [day : N] [month : N]
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
())
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
(d-s (exn:fail exn) () (-String Univ))
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
)
(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
define-initial-env)
(define-syntax (define-initial-env stx)
(syntax-case stx ()
[(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
(with-syntax ([(_ make-promise . _)
(local-expand #'(delay 3)
'expression
null)]
[language
(local-expand #'(this-language)
'expression
null)]
[(_ qq-append . _)
(local-expand #'`(,@'() 1)
'expression
null)])
#`(define-for-syntax initial-env
(make-env
[make-promise make-promise-ty]
[language language-ty]
[qq-append qq-append-ty]
[id ty] ...)))]))
(define-initial-env initial-env/special-case
;; make-promise
(-poly (a) (-> (-> a) (-Promise a)))
;; language
Sym
;; qq-append
(-poly (a b)
(cl->*
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b))))))
(begin-for-syntax
(initialize-type-env initial-env/special-case)
(initialize-others))

34
collects/typed-scheme/private/env-lang.ss Normal file
View File

@ -0,0 +1,34 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (for-syntax (private type-effect-convenience)
(env init-envs)
scheme/base
(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"))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
[(mb (require . args) [id ty] ...)
(begin
(unless (andmap identifier? (syntax->list #'(id ...)))
(raise-syntax-error #f "not all ids"))
#'(#%plain-module-begin
(begin
(require . args)
(define-for-syntax e
(make-env [id ty] ...))
(begin-for-syntax
(initialize-type-env e)))))]
[(mb . rest)
#'(mb (require) . rest)]))
(provide #%module-begin
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"union.ss")))

9
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -13,7 +13,12 @@
(for-syntax macro-debugger/stxclass/stxclass)
(for-syntax scheme/base))
(provide (all-defined-out))
(provide (all-defined-out)
;; these should all eventually go away
make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
(define (one-of/c . args)
(apply Un (map -val args)))
(define (-vet id) (make-Var-True-Effect id))
(define (-vef id) (make-Var-False-Effect id))
@ -206,6 +211,8 @@
(define (-Tuple l)
(foldr -pair (-val '()) l))
(define -box make-Box)
(define -vec make-Vector)
(define Any-Syntax
(-mu x

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

@ -2,7 +2,7 @@
(require (rename-in "utils/utils.ss" [infer r:infer]))
(require (private base-env base-types)
(require (private #;base-env base-types)
(for-syntax
scheme/base
(private type-utils type-contract type-effect-convenience)