suzanne.soy/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
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-21 17:44:15 -04:00
parent 647c4eef59
commit 7e9763cf14
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 (provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical
with-lexical-env/extend/props) with-lexical-env/extend/props)
(p/c (p/c
[lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))] [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?) (env?) . ->* . env?)]) [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (lex-env?) . ->* . env?)])
;; the current lexical environment ;; 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 ;; run code in a new env
(define-syntax-rule (with-lexical-env e . b) (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-keys+vals
env-props env-props
replace-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!) ;; eq? has the type of equal?, and l is an alist (with conses!)
;; props is a list of known propositions ;; 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) (define (env-filter f e)
(match e (match e
[(struct env (l props)) [(env l)
(make-env (for/fold ([h l]) (mk-env e
([(k v) (in-dict l)] (for/fold ([h l])
#:when (not (f (cons k v)))) ([(k v) (in-dict l)]
(dict-remove h k)) #:when (not (f (cons k v))))
props)])) (dict-remove h k)))]))
(r:d/c (make-empty-env dict) (r:d/c (make-empty-env dict)
(dict? . -> . env?) (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) (define (env-keys+vals e)
(match 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 ;; the initial type variable environment - empty
;; this is used in the parsing of types ;; this is used in the parsing of types
@ -55,29 +70,28 @@
(r:d/c (env-map f e) (r:d/c (env-map f e)
((any/c any/c . -> . any/c) env? . -> . env?) ((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 ;; extend that works on single arguments
(define (extend e k v) (define (extend e k v)
(match e (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)])) [_ (int-err "extend: expected environment, got ~a" e)]))
(define (extend-env ks vs e) (define (extend-env ks vs e)
(match e (match e
[(env l p) (make-env (for/fold ([h l]) [(env l) (mk-env e (for/fold ([h l])
([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)) ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)))]
p)]
[_ (int-err "extend-env: expected environment, got ~a" e)])) [_ (int-err "extend-env: expected environment, got ~a" e)]))
(define (replace-props e props) (define (replace-props e props)
(match e (match e
[(env l p) [(lex-env l p)
(make-env l props)])) (lex-env l props)]))
(define (lookup e key fail) (define (lookup e key fail)
(match e (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)])) [_ (int-err "lookup: expected environment, got ~a" e)]))