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

Stratify environments to only include props when needed.

Browse Source 
original commit: 7e9763cf14cd180db251e48fc864b23768897442
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-21 17:44:15 -04:00
parent f581c7796d
commit 8676d0ac03
2 changed files with 35 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/env/lexical-env.rkt vendored
View File

@ -13,11 +13,11 @@
(provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical
with-lexical-env/extend/props)
(p/c
[lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]
[update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)])
[lookup-type/lexical ((identifier?) (lex-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]
[update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (lex-env?) . ->* . env?)])
;; the current lexical environment
(define lexical-env (make-parameter (make-empty-env (make-immutable-free-id-table))))
(define lexical-env (make-parameter (make-empty-lex-env (make-immutable-free-id-table))))
;; run code in a new env
(define-syntax-rule (with-lexical-env e . b)

50
collects/typed-scheme/env/type-environments.rkt vendored
View File

@ -20,28 +20,43 @@
env-keys+vals
env-props
replace-props
with-dotted-env/extend)
with-dotted-env/extend
lex-env? make-empty-lex-env)
;; eq? has the type of equal?, and l is an alist (with conses!)
;; props is a list of known propositions
(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)] [props (listof Filter/c)]) #:transparent)
(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)]) #:transparent)
(r:d-s/c (lex-env env) ([props (listof Filter/c)]) #:transparent)
(define (mk-env orig dict)
(match orig
[(lex-env _ p) (lex-env dict p)]
[_ (env dict)]))
(define (env-filter f e)
(match e
[(struct env (l props))
(make-env (for/fold ([h l])
([(k v) (in-dict l)]
#:when (not (f (cons k v))))
(dict-remove h k))
props)]))
[(env l)
(mk-env e
(for/fold ([h l])
([(k v) (in-dict l)]
#:when (not (f (cons k v))))
(dict-remove h k)))]))
(r:d/c (make-empty-env dict)
(dict? . -> . env?)
(make-env dict null))
(env dict))
(r:d/c (make-empty-lex-env dict)
(dict? . -> . lex-env?)
(lex-env dict null))
(r:d/c (env-props e)
(lex-env? . -> . (listof Filter/c))
(lex-env-props e))
(define (env-keys+vals e)
(match e
[(env l _) (for/list ([(k v) (in-dict l)]) (cons k v))]))
[(env l) (for/list ([(k v) (in-dict l)]) (cons k v))]))
;; the initial type variable environment - empty
;; this is used in the parsing of types
@ -55,29 +70,28 @@
(r:d/c (env-map f e)
((any/c any/c . -> . any/c) env? . -> . env?)
(make-env (dict-map f (env-l e)) (env-props e)))
(mk-env e (dict-map f (env-l e))))
;; extend that works on single arguments
(define (extend e k v)
(match e
[(env l p) (make-env (dict-set l k v) p)]
[(env l) (mk-env e (dict-set l k v))]
[_ (int-err "extend: expected environment, got ~a" e)]))
(define (extend-env ks vs e)
(match e
[(env l p) (make-env (for/fold ([h l])
([k (in-list ks)] [v (in-list vs)]) (dict-set h k v))
p)]
[(env l) (mk-env e (for/fold ([h l])
([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)))]
[_ (int-err "extend-env: expected environment, got ~a" e)]))
(define (replace-props e props)
(match e
[(env l p)
(make-env l props)]))
[(lex-env l p)
(lex-env l props)]))
(define (lookup e key fail)
(match e
[(env l p) (dict-ref l key (λ () (fail key)))]
[(env l) (dict-ref l key (λ () (fail key)))]
[_ (int-err "lookup: expected environment, got ~a" e)]))