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

Fix handling of filters that refer to out-of-scope vars

Browse Source 
svn: r14574
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-21 16:13:00 +00:00
parent b1b5fe4816
commit 60325b670c
3 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -87,7 +87,7 @@
(+ 1 (car x)) (+ 1 (car x))
5)) 5))
N] N]
(tc-e (if (let ([y 12]) y) 3 4) -Integer)
(tc-e 3 -Integer) (tc-e 3 -Integer)
(tc-e "foo" -String) (tc-e "foo" -String)
(tc-e (+ 3 4) -Integer) (tc-e (+ 3 4) -Integer)
@ -496,10 +496,10 @@
[tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)] [tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)]
#;[tc-e #;[tc-e
(let ((x '(1 3 5 7 9))) (let ((x '(1 3 5 7 9)))
(do: : Number ((x : (list-of Number) x (cdr x)) (do: : Number ((x : (list-of Number) x (cdr x))
(sum : Number 0 (+ sum (car x)))) (sum : Number 0 (+ sum (car x))))
((null? x) sum))) ((null? x) sum)))
N] N]
@ -541,10 +541,10 @@
[tc-e `(4 ,@'(3)) (-pair N (-lst N))] [tc-e `(4 ,@'(3)) (-pair N (-lst N))]
[tc-e [tc-e
(let ((x '(1 3 5 7 9))) (let ((x '(1 3 5 7 9)))
(do: : Number ((x : (Listof Number) x (cdr x)) (do: : Number ((x : (Listof Number) x (cdr x))
(sum : Number 0 (+ sum (car x)))) (sum : Number 0 (+ sum (car x))))
((null? x) sum))) ((null? x) sum)))
N] N]
[tc-e (if #f 1 'foo) (-val 'foo)] [tc-e (if #f 1 'foo) (-val 'foo)]

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

@ -25,7 +25,7 @@
;; 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 [fail #f])
(lookup (lexical-env) i (lookup (lexical-env) i
(lambda (i) (lookup-type (lambda (i) (lookup-type
i (lambda () i (lambda ()
@ -33,7 +33,7 @@
=> =>
(lambda (a) (lambda (a)
(-lst (substitute Univ (cdr a) (car a))))] (-lst (substitute Univ (cdr a) (car a))))]
[else (lookup-fail i)])))))) [else ((or fail lookup-fail) i)]))))))
;; 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
@ -43,7 +43,7 @@
(define (update f k env) (define (update f k env)
(parameterize (parameterize
([current-orig-stx k]) ([current-orig-stx k])
(let* ([v (lookup-type/lexical k)] (let* ([v (lookup-type/lexical k (lambda _ Univ))]
[new-v (f k v)] [new-v (f k v)]
[new-env (extend env k new-v)]) [new-env (extend env k new-v)])
new-env))) new-env)))

6
collects/typed-scheme/typecheck/tc-if-unit.ss
View File

@ -45,7 +45,8 @@
(syntax-rules () (syntax-rules ()
[(check-rest f v) [(check-rest f v)
(with-update-type/lexical f v (loop (cdr effs)))] (with-update-type/lexical f v (loop (cdr effs)))]
[(check-rest f t v) (check-rest (type-op f t) v)])) [(check-rest f t v)
(check-rest (type-op f t) v)]))
(if (null? effs) (if (null? effs)
;; base case ;; base case
(let* ([reachable? (not (unbox flag))]) (let* ([reachable? (not (unbox flag))])
@ -83,7 +84,8 @@
;; just replace the type of v with (-val #f) ;; just replace the type of v with (-val #f)
[(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)] [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)]
;; v cannot have type (-val #f) ;; v cannot have type (-val #f)
[(Var-True-Effect: v) (check-rest *remove (-val #f) v)]))))) [(Var-True-Effect: v)
(check-rest *remove (-val #f) v)])))))
;; the main function ;; the main function
(define (tc/if-twoarm tst thn els) (define (tc/if-twoarm tst thn els)