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

Revise type environment propagation to use submodules.

Browse Source 
Each typed module now defines a submodule named `type-decl`.
This module performs the type environment initialization (along
with other environment updates) when invoked.  Additionall,
every typed module, when invoked, performs a for-syntax addition
to a list specifying the submodules that need invocation.
This invocation is then performed by the `#%module-begin` from
Typed Racket.

The `type-decl` module always goes at the beginning of the
expanded module, so that it's available at syntax-time for all
the other submodules.  This involved adding pre- and post-
syntaxes for the results of typechecking.

This allows significant runtime dependency reduction from the
main `typed/racket` and `typed/racket/base` languages (not yet
complete).
This commit is contained in:
Sam Tobin-Hochstadt 2012-07-06 12:13:09 -04:00
parent 88f5f4c836
commit 6bf141513f
13 changed files with 150 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-racket/succeed/submodules.rkt
View File

@ -5,7 +5,7 @@
(provide g) (provide g)
(module+ main (module* main #f
(g (assert (string->number (g (assert (string->number
(vector-ref (current-command-line-arguments) 0))))) (vector-ref (current-command-line-arguments) 0)))))

11
collects/typed-racket/core.rkt
View File

@ -9,6 +9,7 @@
(types utils convenience generalize) (types utils convenience generalize)
(typecheck provide-handling tc-toplevel tc-app-helper) (typecheck provide-handling tc-toplevel tc-app-helper)
(rep type-rep) (rep type-rep)
(env env-req)
(for-template (only-in (base-env prims) :type :print-type :query-result-type)) (for-template (only-in (base-env prims) :type :print-type :query-result-type))
(utils utils tc-utils arm) (utils utils tc-utils arm)
"tc-setup.rkt" "utils/debug.rkt") "tc-setup.rkt" "utils/debug.rkt")
@ -24,7 +25,7 @@
(parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
(and (attribute opt?) (syntax-e (attribute opt?))))]) (and (attribute opt?) (syntax-e (attribute opt?))))])
(tc-setup (tc-setup
stx pmb-form 'module-begin new-mod init tc-module after-code stx pmb-form 'module-begin new-mod init tc-module before-code after-code
(with-syntax* (with-syntax*
(;; pmb = #%plain-module-begin (;; pmb = #%plain-module-begin
[(pmb . body2) new-mod] [(pmb . body2) new-mod]
@ -42,7 +43,7 @@
'disappeared-use (disappeared-use-todo))]) 'disappeared-use (disappeared-use-todo))])
;; reconstruct the module with the extra code ;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing ;; use the regular %#module-begin from `racket/base' for top-level printing
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))])) (arm #`(#%module-begin #,before-code optimized-body ... #,after-code check-syntax-help))))))]))
(define did-I-suggest-:print-type-already? #f) (define did-I-suggest-:print-type-already? #f)
(define :print-type-message " ... [Use (:print-type <expr>) to see more.]") (define :print-type-message " ... [Use (:print-type <expr>) to see more.]")
@ -55,14 +56,14 @@
;; Prints the _entire_ type. May be quite large. ;; Prints the _entire_ type. May be quite large.
[(_ . ((~literal :print-type) e:expr)) [(_ . ((~literal :print-type) e:expr))
#`(display #,(format "~a\n" #`(display #,(format "~a\n"
(tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form type (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type
(match type (match type
[(tc-result1: t f o) t] [(tc-result1: t f o) t]
[(tc-results: t) (cons 'Values t)]))))] [(tc-results: t) (cons 'Values t)]))))]
;; given a function and a desired return type, fill in the blanks ;; given a function and a desired return type, fill in the blanks
[(_ . ((~literal :query-result-type) op:expr desired-type:expr)) [(_ . ((~literal :query-result-type) op:expr desired-type:expr))
(let ([expected (parse-type #'desired-type)]) (let ([expected (parse-type #'desired-type)])
(tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form type (tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form before type
(match type (match type
[(tc-result1: (and t (Function: _)) f o) [(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)]) (let ([cleaned (cleanup-type t expected)])
@ -75,7 +76,7 @@
[_ (error (format "~a: not a function" (syntax->datum #'op) ))])))] [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
[(_ . form) [(_ . form)
(tc-setup (tc-setup
stx #'form 'top-level body2 init tc-toplevel-form type stx #'form 'top-level body2 init tc-toplevel-form before type
(with-syntax* (with-syntax*
([optimized-body (car (maybe-optimize #`(#,body2)))]) ([optimized-body (car (maybe-optimize #`(#,body2)))])
(syntax-parse body2 (syntax-parse body2

23
collects/typed-racket/env/env-req.rkt vendored Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require racket/match)
(define module-name (make-parameter #f))
(define to-require null)
(define (add-mod! m)
;(printf ">> adding module ~v\n" m)
(set! to-require (cons m to-require)))
(define (fix m)
(match m
[`(file ,(? bytes? b))
`(file ,(bytes->string/utf-8 b))]
[_ m]))
(define (do-requires [ns (current-namespace)])
(parameterize ([current-namespace ns])
(for ([m (in-list to-require)]
#:when m)
;(printf ">> loading ~a\n" m)
(dynamic-require `(submod ,(fix m) type-decl) #f))))
(provide add-mod! do-requires module-name)

37
collects/typed-racket/env/init-envs.rkt vendored
View File

@ -7,7 +7,7 @@
"type-alias-env.rkt" "type-alias-env.rkt"
(rep type-rep object-rep filter-rep rep-utils) (rep type-rep object-rep filter-rep rep-utils)
(for-template (rep type-rep object-rep filter-rep) (for-template (rep type-rep object-rep filter-rep)
(types union) (types union numeric-tower)
racket/shared racket/base) racket/shared racket/base)
(types union convenience) (types union convenience)
racket/syntax racket/syntax
@ -72,56 +72,35 @@
(not mp)) (not mp))
#f))) #f)))
(define (when-typed stx)
(syntax-case stx ()
[(def) #'(begin)]
[(def body0 body ...)
;; FIXME workaround for submodule issue
#'(when #true #;(unbox typed-context?) def body0 body ...)]))
(define (tname-env-init-code) (define (tname-env-init-code)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty) (define (f id ty)
(if (bound-in-this-module id) (if (bound-in-this-module id)
#`(register #'#,id #,(datum->syntax #'here (print-convert ty))) #`(register-type-name #'#,id #,(datum->syntax #'here (print-convert ty)))
#f)) #f))
(parameterize ((current-print-convert-hook converter) (parameterize ((current-print-convert-hook converter)
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter values (type-name-env-map f))]) #`(begin #,@(filter values (type-name-env-map f)))))
(when-typed
#'((define register (dynamic-require 'typed-racket/env/type-name-env 'register-type-name))
. registers)))))
(define (talias-env-init-code) (define (talias-env-init-code)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty) (define (f id ty)
(if (bound-in-this-module id) (if (bound-in-this-module id)
#`(register #'#,id #,(datum->syntax #'here (print-convert ty))) #`(register-resolved-type-alias #'#,id #,(datum->syntax #'here (print-convert ty)))
#f)) #f))
(parameterize ((current-print-convert-hook converter) (parameterize ((current-print-convert-hook converter)
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter values (type-alias-env-map f))]) #`(begin #,@(filter values (type-alias-env-map f)))))
(when-typed
#'((define register (dynamic-require 'typed-racket/env/type-alias-env 'register-resolved-type-alias))
. registers)))))
(define (env-init-code syntax-provide? provide-tbl def-tbl) (define (env-init-code syntax-provide? provide-tbl def-tbl)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty) (define (f id ty)
(if (and (bound-in-this-module id) (if (bound-in-this-module id)
;; if there are no syntax provides, then we only need this identifier if it's provided #`(register-type #'#,id #,(datum->syntax #'here (print-convert ty)))
#;(or syntax-provide? (dict-ref provide-tbl id #f)))
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#f)) #f))
(parameterize ((current-print-convert-hook converter) (parameterize ((current-print-convert-hook converter)
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter values (type-env-map f))]) #`(begin #,@(filter values (type-env-map f)))))
(when-typed
#'((define register (dynamic-require 'typed-racket/env/global-env 'register-type))
. registers)))))

28
collects/typed-racket/env/type-alias-env.rkt vendored
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
syntax/boundmap syntax/id-table racket/dict
(utils tc-utils) (utils tc-utils)
racket/match) racket/match)
@ -17,9 +17,9 @@
;; a mapping from id -> alias-def (where id is the name of the type) ;; a mapping from id -> alias-def (where id is the name of the type)
(define the-mapping (define the-mapping
(make-module-identifier-mapping)) (make-free-id-table))
(define (mapping-put! id v) (module-identifier-mapping-put! the-mapping id v)) (define (mapping-put! id v) (dict-set! the-mapping id v))
;(trace mapping-put!) ;(trace mapping-put!)
@ -34,7 +34,7 @@
(define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))]) (define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])
(let/ec return (let/ec return
(match (module-identifier-mapping-get the-mapping id (lambda () (return (k)))) (match (dict-ref the-mapping id (lambda () (return (k))))
[(struct unresolved (stx #f)) [(struct unresolved (stx #f))
(resolve-type-alias id parse-type)] (resolve-type-alias id parse-type)]
[(struct unresolved (stx #t)) [(struct unresolved (stx #t))
@ -42,7 +42,7 @@
[(struct resolved (t)) t]))) [(struct resolved (t)) t])))
(define (resolve-type-alias id parse-type) (define (resolve-type-alias id parse-type)
(define v (module-identifier-mapping-get the-mapping id)) (define v (dict-ref the-mapping id))
(match v (match v
[(struct unresolved (stx _)) [(struct unresolved (stx _))
(set-unresolved-in-process! v #t) (set-unresolved-in-process! v #t)
@ -53,13 +53,17 @@
t])) t]))
(define (resolve-type-aliases parse-type) (define (resolve-type-aliases parse-type)
(module-identifier-mapping-for-each the-mapping (lambda (id _) (resolve-type-alias id parse-type)))) (free-id-table-for-each
the-mapping
(lambda (id k)
(resolve-type-alias id parse-type)))
#; ;; fixme – bug in free-id-mapping dict handling
(for ([(id _) (in-dict the-mapping)])
(resolve-type-alias id parse-type)))
;; map over the-mapping, producing a list ;; map over the-mapping, producing a list
;; (id type -> T) -> listof[T] ;; (id type -> T) -> listof[T]
(define (type-alias-env-map f) (define (type-alias-env-map f)
(define sym (gensym)) (for/list ([(id t) (in-dict the-mapping)]
(filter (lambda (e) (not (eq? sym e))) #:when (resolved? t))
(module-identifier-mapping-map the-mapping (lambda (id t) (if (resolved? t) (f id (resolved-ty t))))
(f id (resolved-ty t))
sym)))))

6
collects/typed-racket/env/type-name-env.rkt vendored
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(require "../utils/utils.rkt") (require "../utils/utils.rkt")
(require syntax/boundmap (require syntax/boundmap
racket/dict
(env type-alias-env) (env type-alias-env)
(utils tc-utils) (utils tc-utils)
(rep type-rep) (rep type-rep)
@ -23,7 +24,6 @@
;; add a name to the mapping ;; add a name to the mapping
;; identifier Type -> void ;; identifier Type -> void
(define (register-type-name id [type #t]) (define (register-type-name id [type #t])
;(printf "registering type ~a\n~a\n" (syntax-e id) id)
(mapping-put! id type)) (mapping-put! id type))
;; add a bunch of names to the mapping ;; add a bunch of names to the mapping
@ -46,5 +46,5 @@
(module-identifier-mapping-map the-mapping f)) (module-identifier-mapping-map the-mapping f))
(define (add-alias from to) (define (add-alias from to)
(when (lookup-type-name to (lambda () #f)) (when (lookup-type-name to (lambda () #f))
(register-resolved-type-alias from (make-Name to)))) (register-resolved-type-alias from (make-Name to))))

4
collects/typed-racket/private/parse-type.rkt
View File

@ -5,7 +5,7 @@
(rename-in (types convenience union utils printer filter-ops) [make-arr* make-arr]) (rename-in (types convenience union utils printer filter-ops) [make-arr* make-arr])
(utils tc-utils stxclass-util) (utils tc-utils stxclass-util)
syntax/stx (prefix-in c: racket/contract) syntax/stx (prefix-in c: racket/contract)
syntax/parse syntax/parse racket/dict
(env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env) (env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env)
racket/match racket/match
"parse-classes.rkt" "parse-classes.rkt"
@ -328,7 +328,7 @@
[(free-identifier=? #'id #'t:->) [(free-identifier=? #'id #'t:->)
(tc-error/delayed "Incorrect use of -> type constructor") (tc-error/delayed "Incorrect use of -> type constructor")
Err] Err]
[else [else
(tc-error/delayed (tc-error/delayed
"Unbound type name ~a" "Unbound type name ~a"
(syntax-e #'id)) (syntax-e #'id))

8
collects/typed-racket/tc-setup.rkt
View File

@ -6,7 +6,7 @@
(private type-contract) (private type-contract)
(types utils convenience) (types utils convenience)
(typecheck typechecker provide-handling tc-toplevel) (typecheck typechecker provide-handling tc-toplevel)
(env tvar-env type-name-env type-alias-env) (env tvar-env type-name-env type-alias-env env-req)
(r:infer infer) (r:infer infer)
(utils tc-utils disarm mutated-vars debug) (utils tc-utils disarm mutated-vars debug)
(rep type-rep) (rep type-rep)
@ -32,7 +32,7 @@
(do-time "Optimized"))) (do-time "Optimized")))
body)) body))
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker result . body) (define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body)
(let () (let ()
(set-box! typed-context? #t) (set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name)) ;(start-timing (syntax-property stx 'enclosing-module-name))
@ -47,6 +47,8 @@
[delay-errors? #t] [delay-errors? #t]
;; do we print the fully-expanded syntax? ;; do we print the fully-expanded syntax?
[print-syntax? #f] [print-syntax? #f]
;; the name of this module:
[module-name (syntax-property orig-stx 'enclosing-module-name)]
;; this parameter is just for printing types ;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues ;; this is a parameter to avoid dependency issues
[current-type-names [current-type-names
@ -70,6 +72,6 @@
[expanded-module-stx fully-expanded-stx] [expanded-module-stx fully-expanded-stx]
[debugging? #f]) [debugging? #f])
(do-time "Starting `checker'") (do-time "Starting `checker'")
(define result (checker fully-expanded-stx)) (define-values (pre-result post-result) (checker fully-expanded-stx))
(do-time "Typechecking Done") (do-time "Typechecking Done")
(let () . body)))))) (let () . body))))))

7
collects/typed-racket/typecheck/def-export.rkt
View File

@ -11,11 +11,4 @@
#'(define-syntax export-id #'(define-syntax export-id
(if (unbox typed-context?) (if (unbox typed-context?)
(renamer #'id #'cnt-id) (renamer #'id #'cnt-id)
(renamer #'cnt-id)))]
[(def-export export-id:identifier id:identifier cnt-id:identifier #:alias)
#'(define-syntax export-id
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(renamer #'id #'cnt-id))
(renamer #'cnt-id)))])) (renamer #'cnt-id)))]))

72
collects/typed-racket/typecheck/provide-handling.rkt
View File

@ -45,38 +45,42 @@
;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
(define mapping (make-free-id-table)) (define mapping (make-free-id-table))
;; mk : id [id] -> (values syntax id) ;; mk : id [id] -> (values syntax id aliases)
(define (mk internal-id [new-id (generate-temporary internal-id)]) (define (mk internal-id [new-id (generate-temporary internal-id)])
(define (mk-untyped-syntax b defn-id internal-id) (define (mk-untyped-syntax b defn-id internal-id)
(match b (match b
[(def-struct-stx-binding _ (? struct-info? si)) [(def-struct-stx-binding _ (? struct-info? si))
(define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same) (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
(match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
(let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) (define-values (defns new-ids aliases)
(mk e) (map/values 3
(values #'(begin) e))) (lambda (e) (if (identifier? e)
(list* type-desc constr pred super accs))]) (mk e)
(with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) (values #'(begin) e null)))
(if (identifier? i) (list* type-desc constr pred super accs)))
#`(syntax #,i) (define/with-syntax (type-desc* constr* pred* super* accs* ...)
i))]) (for/list ([i new-ids]) (if (identifier? i) #`(syntax #,i) i)))
#`(begin (values
#,@defns #`(begin
(define-syntax #,defn-id #,@defns
(let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))) (define-syntax #,defn-id
#,(if type-is-constructor? (let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*)))
#'(make-struct-info-self-ctor constr* info) #,(if type-is-constructor?
#'info)))))))] #'(make-struct-info-self-ctor constr* info)
#'info))))
(apply append aliases))]
[_ [_
#`(define-syntax #,defn-id (values
(lambda (stx) #`(define-syntax #,defn-id
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) (lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))
null)]))
(cond (cond
;; if it's already done, do nothing ;; if it's already done, do nothing
[(dict-ref mapping internal-id [(dict-ref mapping internal-id
;; if it wasn't there, put it in, and skip this case ;; if it wasn't there, put it in, and skip this case
(λ () (dict-set! mapping internal-id new-id) #f)) (λ () (dict-set! mapping internal-id new-id) #f))
=> (λ (mapped-id) (values #'(begin) mapped-id))] => (λ (mapped-id) (values #'(begin) mapped-id null))]
[(dict-ref defs internal-id #f) [(dict-ref defs internal-id #f)
=> =>
(match-lambda (match-lambda
@ -96,7 +100,8 @@
(quote-syntax export-id) (quote-syntax export-id)
(quote-syntax module-source))) (quote-syntax module-source)))
(def-export export-id id cnt-id))) (def-export export-id id cnt-id)))
new-id)] new-id
null)]
[(def-binding id ty) [(def-binding id ty)
(values (values
(with-syntax* ([id internal-id] (with-syntax* ([id internal-id]
@ -106,21 +111,26 @@
(define-syntax (error-id stx) (define-syntax (error-id stx)
(tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))
(def-export export-id id error-id))) (def-export export-id id error-id)))
new-id)] new-id
null)]
[(and b (def-stx-binding _)) [(and b (def-stx-binding _))
(with-syntax* ([id internal-id] (with-syntax* ([id internal-id]
[export-id new-id] [export-id new-id]
[untyped-id (generate-temporary #'id)] [untyped-id (generate-temporary #'id)])
[def (mk-untyped-syntax b #'untyped-id internal-id)]) (define-values (d aliases)
(mk-untyped-syntax b #'untyped-id internal-id))
(define/with-syntax def d)
(values (values
#`(begin def (def-export export-id id untyped-id #:alias)) #`(begin def (def-export export-id id untyped-id))
new-id))])] new-id
(cons (list #'export-id #'id) aliases)))])]
;; otherwise, not defined in this module, not our problem ;; otherwise, not defined in this module, not our problem
[else (values #'(begin) internal-id)])) [else (values #'(begin) internal-id null)]))
;; Build the final provide with auxilliary definitions ;; Build the final provide with auxilliary definitions
(for/list ([(internal-id external-ids) (in-dict provs)]) (for/lists (l l*) ([(internal-id external-ids) (in-dict provs)])
(define-values (defs id) (mk internal-id)) (define-values (defs id alias) (mk internal-id))
(define provide-forms (define provide-forms
(for/list ([external-id (in-list external-ids)]) (for/list ([external-id (in-list external-ids)])
#`(rename-out [#,id #,external-id]))) #`(rename-out [#,id #,external-id])))
#`(begin #,defs (provide #,@provide-forms)))) (values #`(begin #,defs (provide #,@provide-forms))
alias)))

53
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -3,7 +3,7 @@
(require (rename-in "../utils/utils.rkt" [infer r:infer]) (require (rename-in "../utils/utils.rkt" [infer r:infer])
syntax/kerncase syntax/kerncase
unstable/list racket/syntax syntax/parse unstable/list racket/syntax syntax/parse
mzlib/etc mzlib/etc racket/list
racket/match racket/match
"signatures.rkt" "signatures.rkt"
"tc-structs.rkt" "tc-structs.rkt"
@ -13,13 +13,14 @@
(rep type-rep) (rep type-rep)
(types utils convenience type-table) (types utils convenience type-table)
(private parse-type type-annotation type-contract) (private parse-type type-annotation type-contract)
(env global-env init-envs type-name-env type-alias-env lexical-env) (env global-env init-envs type-name-env type-alias-env lexical-env env-req)
syntax/id-table syntax/id-table
(utils tc-utils mutated-vars) (utils tc-utils mutated-vars)
"provide-handling.rkt" "provide-handling.rkt"
"def-binding.rkt" "def-binding.rkt"
(prefix-in c: racket/contract) (prefix-in c: racket/contract)
racket/dict racket/dict
syntax/location
(for-template (for-template
"internal-forms.rkt" "internal-forms.rkt"
syntax/location syntax/location
@ -27,9 +28,9 @@
racket/base)) racket/base))
(c:provide/contract (c:provide/contract
[type-check (syntax? . c:-> . syntax?)] [type-check (syntax? . c:-> . (values syntax? syntax?))]
[tc-module (syntax? . c:-> . syntax?)] [tc-module (syntax? . c:-> . (values syntax? syntax?))]
[tc-toplevel-form (syntax? . c:-> . c:any/c)]) [tc-toplevel-form (syntax? . c:-> . (values #f c:any/c))])
(define unann-defs (make-free-id-table)) (define unann-defs (make-free-id-table))
@ -264,6 +265,9 @@
(values #'nm #'ty)] (values #'nm #'ty)]
[_ (int-err "not define-type-alias")])) [_ (int-err "not define-type-alias")]))
;; actually do the work on a module
;; produces prelude and post-lude syntax objects
;; syntax-list -> (values syntax syntax)
(define (type-check forms0) (define (type-check forms0)
(define forms (syntax->list forms0)) (define forms (syntax->list forms0))
(define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs) (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs)
@ -328,25 +332,38 @@
[_ (int-err "unknown provide form")])))] [_ (int-err "unknown provide form")])))]
[_ (int-err "non-provide form! ~a" (syntax->datum p))]))) [_ (int-err "non-provide form! ~a" (syntax->datum p))])))
;; compute the new provides ;; compute the new provides
(define new-stx (define-values (new-stx/pre new-stx/post)
(with-syntax* (with-syntax*
([the-variable-reference (generate-temporary #'blame)] ([the-variable-reference (generate-temporary #'blame)])
[(new-provs ...) (define-values (code aliasess)
(generate-prov def-tbl provide-tbl #'the-variable-reference)]) (generate-prov def-tbl provide-tbl #'the-variable-reference))
(define aliases (apply append aliasess))
(define/with-syntax (new-provs ...) code)
(values
#`(begin
(begin-for-syntax
(module* type-decl #f
(require typed-racket/types/numeric-tower typed-racket/env/type-name-env
typed-racket/env/global-env typed-racket/env/type-alias-env)
#,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(talias-env-init-code)
#,(tname-env-init-code)
#,(make-struct-table-code)
#,@(for/list ([a (in-list aliases)])
(match a
[(list from to)
#`(add-alias (quote-syntax #,from) (quote-syntax #,to))]))))
(begin-for-syntax (add-mod! (quote-module-path))))
#`(begin #`(begin
#,(if (null? (syntax-e #'(new-provs ...))) #,(if (null? (syntax-e #'(new-provs ...)))
#'(begin) #'(begin)
#'(define the-variable-reference (quote-module-name))) #'(define the-variable-reference (quote-module-name)))
(begin-for-syntax #,(env-init-code syntax-provide? provide-tbl def-tbl) new-provs ...))))
#,(tname-env-init-code)
#,(talias-env-init-code)
#,(make-struct-table-code))
(begin new-provs ...))))
(do-time "finished provide generation") (do-time "finished provide generation")
new-stx) (values new-stx/pre new-stx/post))
;; typecheck a whole module ;; typecheck a whole module
;; syntax -> syntax ;; syntax -> (values syntax syntax)
(define (tc-module stx) (define (tc-module stx)
(syntax-parse stx (syntax-parse stx
[(pmb . forms) (type-check #'forms)])) [(pmb . forms) (type-check #'forms)]))
@ -356,6 +373,6 @@
;; syntax -> void ;; syntax -> void
(define (tc-toplevel-form form) (define (tc-toplevel-form form)
(tc-toplevel/pass1 form) (tc-toplevel/pass1 form)
(begin0 (tc-toplevel/pass2 form) (begin0 (values #f (tc-toplevel/pass2 form))
(report-all-errors))) (report-all-errors)))

5
collects/typed-racket/typed-racket.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require (require
(for-syntax racket/base "utils/timing.rkt") ;; only for timing/debugging (for-syntax racket/base "utils/timing.rkt" "env/env-req.rkt") ;; only for timing/debugging
;; the below requires are needed since they provide identifiers ;; the below requires are needed since they provide identifiers
;; that may appear in the residual program ;; that may appear in the residual program
(for-syntax "typecheck/renamer.rkt") (for-syntax "typecheck/renamer.rkt")
@ -26,7 +26,8 @@
(do-time "Finshed base-env-numeric") (do-time "Finshed base-env-numeric")
((dynamic-require 'typed-racket/base-env/base-special-env 'initialize-special)) ((dynamic-require 'typed-racket/base-env/base-special-env 'initialize-special))
(do-time "Finished base-special-env") (do-time "Finished base-special-env")
(set! initialized #t))) (set! initialized #t))
(do-requires))
(define-syntax-rule (drivers [name sym] ...) (define-syntax-rule (drivers [name sym] ...)
(begin (begin

8
collects/typed-racket/types/type-table.rkt
View File

@ -7,7 +7,13 @@
(rep type-rep object-rep) (rep type-rep object-rep)
(types utils union) (types utils union)
(utils tc-utils) (utils tc-utils)
(env init-envs)) (env init-envs)
(for-template
racket/base
(rep type-rep object-rep)
(types utils union)
(utils tc-utils)
(env init-envs)))
(define table (make-hasheq)) (define table (make-hasheq))