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

fix bugs

Browse Source 
add env+

svn: r13994
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-06 21:27:05 +00:00
parent d293635cb7
commit aa32d9b928
3 changed files with 19 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/typed-scheme/env/lexical-env.ss vendored
View File

@ -23,8 +23,8 @@
;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; find the type of identifier i, looking first in the lexical env, then in the top-level env
;; identifer -> Type ;; identifer -> Type
(define (lookup-type/lexical i) (define (lookup-type/lexical i [env (lexical-env)])
(lookup (lexical-env) i (lookup env i
(lambda (i) (lookup-type (lambda (i) (lookup-type
i (lambda () i (lambda ()
(cond [(lookup (dotted-env) i (lambda _ #f)) (cond [(lookup (dotted-env) i (lambda _ #f))
@ -35,7 +35,7 @@
;; refine the type of i in the lexical env ;; refine the type of i in the lexical env
;; (identifier type -> type) identifier -> environment ;; (identifier type -> type) identifier -> environment
(define (update-type/lexical f i) (define (update-type/lexical f i [env (lexical-env)])
;; do the updating on the given env ;; do the updating on the given env
;; (identifier type -> type) identifier environment -> environment ;; (identifier type -> type) identifier environment -> environment
(define (update f k env) (define (update f k env)
@ -48,9 +48,9 @@
;; check if i is ever the target of a set! ;; check if i is ever the target of a set!
(if (is-var-mutated? i) (if (is-var-mutated? i)
;; if it is, we do nothing ;; if it is, we do nothing
(lexical-env) env
;; otherwise, refine the type ;; otherwise, refine the type
(update f i (lexical-env)))) (update f i env)))
;; convenience macro for typechecking in the context of an updated env ;; convenience macro for typechecking in the context of an updated env
(define-syntax with-update-type/lexical (define-syntax with-update-type/lexical

5
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -2,12 +2,14 @@
(provide current-tvars (provide current-tvars
extend extend
env?
lookup lookup
make-empty-env make-empty-env
extend-env extend-env
extend/values extend/values
dotted-env dotted-env
initial-tvar-env initial-tvar-env
env-map
with-dotted-env/extend) with-dotted-env/extend)
(require (prefix-in r: "../utils/utils.ss")) (require (prefix-in r: "../utils/utils.ss"))
@ -29,7 +31,8 @@
;; the environment for types of ... variables ;; the environment for types of ... variables
(define dotted-env (make-parameter (make-empty-env free-identifier=?))) (define dotted-env (make-parameter (make-empty-env free-identifier=?)))
(define (env-map f env)
(make-env (env-eq? env) (map f (env-l env))))
;; extend that works on single arguments ;; extend that works on single arguments
(define (extend e k v) (define (extend e k v)

11
collects/typed-scheme/typecheck/tc-envops.ss
View File

@ -1,12 +1,13 @@
#lang scheme/base #lang scheme/base
(require (rename-in "../utils/utils.ss" [infer infer-in])) (require (rename-in "../utils/utils.ss" [infer infer-in]))
(require (rename-in (types subtype convenience remove-intersect) (require (rename-in (types subtype convenience remove-intersect union)
[-> -->] [-> -->]
[->* -->*] [->* -->*]
[one-of/c -one-of/c]) [one-of/c -one-of/c])
(infer-in infer) (infer-in infer)
(rep type-rep) (rep type-rep)
(only-in (env type-environments lexical-env) env? update-type/lexical env-map)
scheme/contract scheme/match scheme/contract scheme/match
stxclass/util stxclass/util
(for-syntax scheme/base)) (for-syntax scheme/base))
@ -42,3 +43,11 @@
(restrict t u)] (restrict t u)]
[(t (NotTypeFilter: u (list) _)) [(t (NotTypeFilter: u (list) _))
(remove t u)])) (remove t u)]))
(define/contract (env+ env fs)
(env? (listof Filter/c) . -> . env?)
(for/fold ([Γ env]) ([f fs])
(match f
[(Bot:) (env-map (lambda (_) (Un)) Γ)]
[(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))
(update-type/lexical (lambda (x t) (update t f)) x Γ)])))