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

Fix name escape in tc/rec-lambda/check.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-22 09:37:27 -07:00
parent ebd7f8dc92
commit 684bde6c6e
2 changed files with 16 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -4,9 +4,11 @@
racket/dict racket/list syntax/parse racket/syntax syntax/stx racket/dict racket/list syntax/parse racket/syntax syntax/stx
racket/match syntax/id-table racket/set racket/match syntax/id-table racket/set
(contract-req) (contract-req)
(except-in (rep type-rep) make-arr) (rep type-rep)
(rename-in (except-in (types abbrev utils union) -> ->* one-of/c) (rename-in (types abbrev utils union)
[make-arr* make-arr]) [-> t:->]
[->* t:->*]
[one-of/c t:one-of/c])
(private type-annotation syntax-properties) (private type-annotation syntax-properties)
(types type-table) (types type-table)
(typecheck signatures tc-metafunctions tc-subst) (typecheck signatures tc-metafunctions tc-subst)
@ -30,7 +32,7 @@
(if rest (list (first rest)) null) (if rest (list (first rest)) null)
(if drest (list (first drest)) null) (if drest (list (first drest)) null)
kw-id)]) kw-id)])
(make-arr (make-arr*
arg-tys arg-tys
(abstract-results body arg-names) (abstract-results body arg-names)
#:kws (map make-Keyword kw kw-ty req?) #:kws (map make-Keyword kw kw-ty req?)
@ -532,11 +534,9 @@
;; Returns both the tc-results of the function and of the body ;; Returns both the tc-results of the function and of the body
(define (tc/rec-lambda/check formals* body name args return) (define (tc/rec-lambda/check formals* body name args return)
(define formals (syntax->list formals*)) (define formals (syntax->list formals*))
(define ft (t:->* args (tc-results->values return)))
(with-lexical-env/extend (with-lexical-env/extend
formals args (cons name formals) (cons ft args)
(let* ([ft (->* args (tc-results->values return))]
(with-lexical-env/extend
(list name) (list ft)
(values (values
(replace-names (map (λ (f) (list f -empty-obj)) formals) (ret ft)) (replace-names (map (λ (f) (list f -empty-obj)) (cons name formals)) (ret ft))
(replace-names (map (λ (f) (list f -empty-obj)) formals) (tc-body/check body return))))))) (replace-names (map (λ (f) (list f -empty-obj)) (cons name formals)) (tc-body/check body return)))))

5
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2987,7 +2987,12 @@
#:ret (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f)))) #:ret (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))
#:expected (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))] #:expected (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))]
[tc-e
((letrec ([lp (lambda (x) lp)]) lp) 'y)
#:ret (ret (t:-> -Symbol Univ))
#:expected (ret (t:-> -Symbol Univ) -no-filter -no-obj)]
) )
(test-suite (test-suite
"tc-literal tests" "tc-literal tests"
(tc-l 5 -PosByte) (tc-l 5 -PosByte)