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

Load environments dynamically in residual code.

Browse Source 
original commit: 794bfa50ecf854eb36bb2195c99202cc1a7f879f
This commit is contained in:
Sam Tobin-Hochstadt 2012-06-25 15:49:05 -04:00
parent d6f1c0eb1b
commit 76f157026a
4 changed files with 39 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-racket/base-env/type-env-lang.rkt
View File

@ -18,7 +18,8 @@
...
(provide nm) ...
(begin-for-syntax
(initialize-type-name-env
((dynamic-require 'typed-racket/env/init-envs
'initialize-type-name-env)
(list (list #'nm ty) ...)))))]))
(provide #%module-begin

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

@ -1,6 +1,7 @@
#lang racket/base
(provide (all-defined-out))
(require "../utils/utils.rkt"
"../utils/tc-utils.rkt"
"global-env.rkt"
"type-name-env.rkt"
"type-alias-env.rkt"
@ -71,40 +72,56 @@
(not mp))
#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/with-syntax register (generate-temporary 'register))
(define (f id ty)
(if (bound-in-this-module id)
#`(register-type-name #'#,id #,(datum->syntax #'here (print-convert ty)))
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
(with-syntax ([registers (filter (lambda (x) x) (type-name-env-map f))])
#'(begin-for-syntax . registers))))
(with-syntax ([registers (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/with-syntax register (generate-temporary 'register))
(define (f id ty)
(if (bound-in-this-module id)
#`(register-resolved-type-alias #'#,id #,(datum->syntax #'here (print-convert ty)))
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
(with-syntax ([registers (filter (lambda (x) x) (type-alias-env-map f))])
#'(begin-for-syntax . registers))))
(with-syntax ([registers (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/with-syntax register (generate-temporary 'register))
(define (f id ty)
(if (and (bound-in-this-module id)
;; if there are no syntax provides, then we only need this identifier if it's provided
#;(or syntax-provide? (dict-ref provide-tbl id #f)))
#`(register-type #'#,id #,(datum->syntax #'here (print-convert ty)))
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
(with-syntax ([registers (filter values (type-env-map f))])
#'(begin-for-syntax . registers))))
(when-typed
#'((define register (dynamic-require 'typed-racket/env/global-env 'register-type))
. registers)))))

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

@ -336,11 +336,11 @@
#`(begin
#,(if (null? (syntax-e #'(new-provs ...)))
#'(begin)
#'(define the-variable-reference (quote-module-name)))
#,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code)
#,(talias-env-init-code)
(begin-for-syntax #,(make-struct-table-code))
#'(define the-variable-reference (quote-module-name)))
(begin-for-syntax #,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code)
#,(talias-env-init-code)
#,(make-struct-table-code))
(begin new-provs ...))))
(do-time "finished provide generation")
new-stx)

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

@ -63,13 +63,16 @@
(define (make-struct-table-code)
(parameterize ([current-print-convert-hook converter]
[show-sharing #f])
#`(begin #,@(for/list ([(k v) (in-dict struct-fn-table)]
#`(when (unbox typed-context?)
(define add! (dynamic-require 'typed-racket/types/type-table 'add-struct-fn!))
#,@(for/list ([(k v) (in-dict struct-fn-table)]
#:when (bound-in-this-module k))
(match v
[(list pe mut?)
#`(add-struct-fn! (quote-syntax #,k)
#,(print-convert pe)
#,mut?)])))))
#`(add! (quote-syntax #,k)
#,(print-convert pe)
#,mut?)]))
(void))))
;; keeps track of expressions that always evaluate to true or always evaluate