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

Reduce duplication in init-env code and clean up its interface.

Browse Source 
original commit: 695f73bad765be104296bda63ebb9dbdea5d6b6a
This commit is contained in:
Eric Dobson 2013-11-16 22:46:31 -08:00
parent 0e57618c26
commit 8ebfb53cd2
2 changed files with 26 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -120,52 +120,38 @@
(not mp))
#f)))
(define (tname-env-init-code)
(define (f id ty)
(if (bound-in-this-module id)
#`(register-type-name #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(define (make-init-code map f)
(define (bound-f id v)
(and (bound-in-this-module id) (f id v)))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
#`(begin #,@(filter values (type-name-env-map f)))))
#`(begin #,@(filter values (map bound-f)))))
(define (quote-type ty)
(datum->syntax #'here (print-convert ty)))
(define (tname-env-init-code)
(make-init-code
type-name-env-map
(λ (id ty) #`(register-type-name #'#,id #,(quote-type ty)))))
(define (tvariance-env-init-code)
(define (f id var)
(if (bound-in-this-module id)
#`(register-type-variance! #'#,id (list #,@(map variance->binding var)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
#`(begin #,@(filter values (type-variance-env-map f)))))
(make-init-code
type-variance-env-map
(λ (id var) #`(register-type-variance! #'#,id (list #,@(map variance->binding var))))))
(define (talias-env-init-code)
(define (f id ty)
(if (bound-in-this-module id)
#`(register-resolved-type-alias #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
#`(begin #,@(filter values (type-alias-env-map f)))))
(make-init-code
type-alias-env-map
(λ (id ty) #`(register-resolved-type-alias #'#,id #,(quote-type ty)))))
(define (env-init-code syntax-provide? provide-tbl def-tbl)
(define (f id ty)
(if (bound-in-this-module id)
#`(register-type #'#,id #,(datum->syntax #'here (print-convert ty)))
#f))
(parameterize ((current-print-convert-hook converter)
(show-sharing #f)
(booleans-as-true/false #f))
#`(begin #,@(filter values (type-env-map f)))))
(define (env-init-code)
(make-init-code
type-env-map
(λ (id ty) #`(register-type #'#,id #,(quote-type ty)))))
(define (mvar-env-init-code mvar-env)
(define (f id v)
(and v (bound-in-this-module id)
#`(register-mutated-var #'#,id)))
#`(begin #,@(filter values (dict-map mvar-env f))))
(make-init-code
(λ (f) (dict-map mvar-env f))
(lambda (id v) (and v #`(register-mutated-var #'#,id)))))

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -286,7 +286,6 @@
(check-all-registered-types)
;; report delayed errors
(report-all-errors)
(define syntax-provide? #f)
(define provide-tbl
(for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)])
(define-syntax-class unknown-provide-form
@ -303,12 +302,8 @@
(parameterize ([current-orig-stx f])
(syntax-parse f
[i:id
(when (def-stx-binding? (dict-ref def-tbl #'i #f))
(set! syntax-provide? #t))
(dict-update h #'i (lambda (tail) (cons #'i tail)) '())]
[((~datum rename) in out)
(when (def-stx-binding? (dict-ref def-tbl #'in #f))
(set! syntax-provide? #t))
(dict-update h #'in (lambda (tail) (cons #'out tail)) '())]
[(name:unknown-provide-form . _)
(tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))]
@ -331,7 +326,7 @@
typed-racket/env/global-env typed-racket/env/type-alias-env
typed-racket/types/struct-table typed-racket/types/abbrev
(rename-in racket/private/sort [sort raw-sort]))
#,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(env-init-code)
#,(talias-env-init-code)
#,(tname-env-init-code)
#,(tvariance-env-init-code)