diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt index 366cda8bb1..329c765fb3 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt @@ -7,7 +7,6 @@ ;; but split here for performance (require "../utils/utils.rkt" - syntax/id-table racket/keyword-transform racket/list (for-syntax syntax/parse racket/base) (contract-req) @@ -20,10 +19,10 @@ (provide lexical-env with-lexical-env with-lexical-env/extend update-type/lexical) (provide/cond-contract - [lookup-type/lexical ((identifier?) (prop-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]) + [lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]) ;; the current lexical environment -(define lexical-env (make-parameter (make-empty-prop-env (make-immutable-free-id-table)))) +(define lexical-env (make-parameter empty-prop-env)) ;; run code in a new env (define-syntax-rule (with-lexical-env e . b) @@ -31,7 +30,8 @@ ;; run code in an extended env (define-syntax-rule (with-lexical-env/extend is ts . b) - (with-lexical-env (extend/values is ts (lexical-env)) . b)) + (with-lexical-env (extend/values (lexical-env) is ts) . b)) + ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifier -> Type diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-env-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-env-structs.rkt index b0fa17806f..979e17d627 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-env-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-env-structs.rkt @@ -1,102 +1,54 @@ #lang racket/base (require racket/dict racket/match - (prefix-in r: "../utils/utils.rkt") - (r:contract-req) - (r:rep filter-rep) - (except-in (r:utils tc-utils) make-env)) + syntax/id-table + (except-in "../utils/utils.rkt" env) + (contract-req) + (rep filter-rep type-rep) + (except-in (utils tc-utils) make-env)) -(provide extend - env? - lookup - extend-env - extend/values - env-map - make-empty-env - env-filter - env-keys+vals - env-props - replace-props - prop-env? make-empty-prop-env) - -;; eq? has the type of equal?, and l is an alist (with conses!) +;; types is a free-id-table of identifiers to types ;; props is a list of known propositions -(r:define-struct/cond-contract env ([l (and/c (not/c dict-mutable?) dict?)]) - #:transparent - #:property prop:custom-write - (lambda (e prt mode) - (fprintf prt "(env ~a)" (dict-map (env-l e) list)))) -(r:define-struct/cond-contract (prop-env env) ([props (listof Filter/c)]) - #:transparent - #:property prop:custom-write - (lambda (e prt mode) - (fprintf prt "(env ~a ~a)" (dict-map (env-l e) list) (prop-env-props e)))) +(define-struct/cond-contract env ([types immutable-free-id-table?] [props (listof Filter/c)]) + #:transparent + #:property prop:custom-write + (lambda (e prt mode) + (fprintf prt "(env ~a ~a)" (free-id-table-map (env-types e) list) (env-props e)))) -(define (mk-env orig dict) - (match orig - [(prop-env _ p) (prop-env dict p)] - [_ (env dict)])) +(provide/cond-contract + [env? predicate/c] + [extend (env? identifier? Type/c . -> . env?)] + [extend/values (env? (listof identifier?) (listof Type/c) . -> . env?)] + [lookup (env? identifier? (identifier? . -> . any) . -> . any)] + [env-props (env? . -> . (listof Filter/c))] + [replace-props (env? (listof Filter/c) . -> . env?)] + [empty-prop-env env?]) -(define (env-filter f e) - (match e - [(env l) - (mk-env e - (for/fold ([h l]) - ([(k v) (in-dict l)] - #:unless (f (cons k v))) - (dict-remove h k)))])) +(define empty-prop-env + (env + (make-immutable-free-id-table) + null)) -(r:define/cond-contract (make-empty-env dict) - (dict? . -> . env?) - (env dict)) - -(r:define/cond-contract (make-empty-prop-env dict) - (dict? . -> . prop-env?) - (prop-env dict null)) - -(r:define/cond-contract (env-props e) - (prop-env? . -> . (listof Filter/c)) - (prop-env-props e)) - -(define (env-keys+vals e) - (match e - [(env l) (for/list ([(k v) (in-dict l)]) (cons k v))])) - -(r:define/cond-contract (env-map f e) - ((any/c any/c . -> . any/c) env? . -> . env?) - (mk-env e (dict-map f (env-l e)))) - -;; extend that works on single arguments -(define (extend e k v) - (match e - [(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) (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 - [(prop-env l p) - (prop-env l props)])) + [(env tys _) + (env tys props)])) (define (lookup e key fail) (match e - [(env l) (dict-ref l key (λ () (fail key)))] - [_ (int-err "lookup: expected environment, got ~a" e)])) + [(env tys _) (free-id-table-ref tys key (λ () (fail key)))])) -;; takes two lists of sets to be added, which are either added one at a time, if the -;; elements are not lists, or all at once, if the elements are lists -(define (extend/values kss vss env) - (foldr (lambda (ks vs env) - (cond [(and (list? ks) (list? vs)) - (extend-env ks vs env)] - [(or (list? ks) (list? vs)) - (int-err "not both lists in extend/values: ~a ~a" ks vs)] - [else (extend env ks vs)])) - env kss vss)) +;; extend that works on single arguments +(define (extend e k v) + (extend/values e (list k) (list v))) +;; takes two lists of identifiers and types to be added +(define (extend/values e ks vs) + (match e + [(env tys p) + (env + (for/fold ([tys tys]) ([k (in-list ks)] [v (in-list vs)]) + (free-id-table-set tys k v)) + p)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 40bb187e90..b47e7e8646 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -67,8 +67,8 @@ (values e-ts null)])))) ;; extend the lexical environment for checking the body (with-lexical-env/extend - namess - expected-types + (append* namess) + (append* expected-types) (replace-names (get-names+objects namess expected-results) (with-lexical-env/extend-props