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

Load environments dynamically in residual code.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-06-25 15:49:05 -04:00
parent 88ff5fee69
commit 794bfa50ec
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) ... (provide nm) ...
(begin-for-syntax (begin-for-syntax
(initialize-type-name-env ((dynamic-require 'typed-racket/env/init-envs
'initialize-type-name-env)
(list (list #'nm ty) ...)))))])) (list (list #'nm ty) ...)))))]))
(provide #%module-begin (provide #%module-begin

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

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(provide (all-defined-out)) (provide (all-defined-out))
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
"../utils/tc-utils.rkt"
"global-env.rkt" "global-env.rkt"
"type-name-env.rkt" "type-name-env.rkt"
"type-alias-env.rkt" "type-alias-env.rkt"
@ -71,40 +72,56 @@
(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-type-name #'#,id #,(datum->syntax #'here (print-convert ty))) #`(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 (lambda (x) x) (type-name-env-map f))]) (with-syntax ([registers (filter values (type-name-env-map f))])
#'(begin-for-syntax . registers)))) (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-resolved-type-alias #'#,id #,(datum->syntax #'here (print-convert ty))) #`(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 (lambda (x) x) (type-alias-env-map f))]) (with-syntax ([registers (filter values (type-alias-env-map f))])
#'(begin-for-syntax . registers)))) (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 (and (bound-in-this-module id)
;; if there are no syntax provides, then we only need this identifier if it's provided ;; 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))) #;(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)) #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))]) (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 #`(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)))
#,(env-init-code syntax-provide? provide-tbl def-tbl) (begin-for-syntax #,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code) #,(tname-env-init-code)
#,(talias-env-init-code) #,(talias-env-init-code)
(begin-for-syntax #,(make-struct-table-code)) #,(make-struct-table-code))
(begin new-provs ...)))) (begin new-provs ...))))
(do-time "finished provide generation") (do-time "finished provide generation")
new-stx) new-stx)

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

@ -63,13 +63,16 @@
(define (make-struct-table-code) (define (make-struct-table-code)
(parameterize ([current-print-convert-hook converter] (parameterize ([current-print-convert-hook converter]
[show-sharing #f]) [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)) #:when (bound-in-this-module k))
(match v (match v
[(list pe mut?) [(list pe mut?)
#`(add-struct-fn! (quote-syntax #,k) #`(add! (quote-syntax #,k)
#,(print-convert pe) #,(print-convert pe)
#,mut?)]))))) #,mut?)]))
(void))))
;; keeps track of expressions that always evaluate to true or always evaluate ;; keeps track of expressions that always evaluate to true or always evaluate