From 1dc33167c221d5369bb7e2ab2500de59465b361d Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Fri, 23 May 2014 09:26:31 -0700 Subject: [PATCH] Add with-lexical-env/extend-props. --- .../typed-racket/env/lexical-env.rkt | 6 +--- .../typed-racket/typecheck/tc-envops.rkt | 14 +++++---- .../typed-racket/typecheck/tc-expr-unit.rkt | 2 +- .../typed-racket/typecheck/tc-let-unit.rkt | 29 +++++++++---------- 4 files changed, 25 insertions(+), 26 deletions(-) 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 18ef1453d0..69d1f8ac99 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 @@ -18,7 +18,7 @@ (except-in (types utils abbrev kw-types) -> ->* one-of/c)) (provide lexical-env with-lexical-env with-lexical-env/extend - with-lexical-env/extend/props update-type/lexical) + update-type/lexical) (provide/cond-contract [lookup-type/lexical ((identifier?) (prop-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]) @@ -33,10 +33,6 @@ (define-syntax-rule (with-lexical-env/extend is ts . b) (with-lexical-env (extend/values is ts (lexical-env)) . b)) -;; run code in an extended env and with replaced props -(define-syntax-rule (with-lexical-env/extend/props is ts ps . b) - (with-lexical-env (replace-props (extend/values is ts (lexical-env)) ps) . b)) - ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifier -> Type (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt index f4206fc0c7..3c74d461fa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt @@ -2,23 +2,24 @@ (require (rename-in "../utils/utils.rkt" [infer infer-in])) (require racket/match - unstable/list + (only-in unstable/list list-update) (contract-req) (infer-in infer) (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) (types resolve subtype remove-intersect union) - (only-in (env type-env-structs lexical-env) - env? update-type/lexical env-map env-props replace-props) + (env type-env-structs lexical-env) (rename-in (types abbrev) [-> -->] [->* -->*] [one-of/c -one-of/c]) (typecheck tc-metafunctions)) +(provide + with-lexical-env/extend-props) (provide/cond-contract - [env+ (([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)]) - #:pre (bx) (unbox bx) . ->i . [_ env?])]) + [env+ (([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)]) + #:pre (bx) (unbox bx) . ->i . [_ env?])]) (define/cond-contract (update t ft pos? lo) (Type/c Type/c boolean? (listof PathElem?) . -> . Type/c) @@ -76,3 +77,6 @@ x Γ)] [_ Γ]))) +;; run code in an extended env and with replaced props +(define-syntax-rule (with-lexical-env/extend-props ps . b) + (with-lexical-env (env+ (lexical-env) ps (box #t)) . b)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 4393403f8b..8c75c5ab67 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -352,7 +352,7 @@ (map -or f+ f-)] [(tc-results: _ (list (FilterSet: f+ f-) ...) _ _ _) (map -or f+ f-)])) - (with-lexical-env (env+ (lexical-env) props (box #t)) + (with-lexical-env/extend-props props (add-unconditional-prop (k) (apply -and props)))) ;; type-check a body of exprs, producing the type of the last one. 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 89068f20f9..eb47c2dff6 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 @@ -8,7 +8,7 @@ global-env type-env-structs scoped-tvar-env) (rep type-rep filter-rep) syntax/free-vars - (typecheck signatures tc-metafunctions tc-subst internal-forms) + (typecheck signatures tc-metafunctions tc-subst internal-forms tc-envops) (utils tarjan) racket/match (contract-req) racket/list @@ -60,23 +60,22 @@ (-imp (-filter (-val #f) n) f-))))))] [(tc-results: e-ts (list (NoFilter:) ...) _) (values e-ts null)])))) - (define-values (p1 p2) - (combine-props (apply append props) (env-props (lexical-env)) (box #t))) ;; extend the lexical environment for checking the body - (with-lexical-env/extend/props + (with-lexical-env/extend namess expected-types - (append p1 p2) - ;; type-check the rhs exprs - (for-each expr->type - exprs - expected-results) - ;; typecheck the body - (replace-names - (get-names+objects namess expected-results) - (if expected - (tc-body/check body (erase-filter expected)) - (tc-body body))))) + (with-lexical-env/extend-props + (apply append props) + ;; type-check the rhs exprs + (for-each expr->type + exprs + expected-results) + ;; typecheck the body + (replace-names + (get-names+objects namess expected-results) + (if expected + (tc-body/check body (erase-filter expected)) + (tc-body body)))))) (define (tc-expr/maybe-expected/t e names) (syntax-parse names