Don't shortcut simple letrec
forms that aren't lambda
s.
Closes PR 12841.
This commit is contained in:
parent
9e097866bf
commit
2500dad8f1
5
collects/tests/typed-racket/fail/single-letrec.rkt
Normal file
5
collects/tests/typed-racket/fail/single-letrec.rkt
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
#lang typed/racket
|
||||||
|
|
||||||
|
(: f (Pair 'bad 'worse))
|
||||||
|
(define f
|
||||||
|
(letrec ((y y)) y))
|
|
@ -256,6 +256,15 @@
|
||||||
t))]
|
t))]
|
||||||
[else (tc-error/expr #:return (ret (Un)) #:stx stx (syntax-e msg))]))
|
[else (tc-error/expr #:return (ret (Un)) #:stx stx (syntax-e msg))]))
|
||||||
|
|
||||||
|
;; check that `expr` doesn't evaluate any references
|
||||||
|
;; to `name` that aren't under `lambda`
|
||||||
|
;; value-restriction? : syntax identifier -> boolean
|
||||||
|
(define (value-restriction? expr name)
|
||||||
|
(syntax-parse expr
|
||||||
|
[((~literal #%plain-lambda) . _) #true]
|
||||||
|
[((~literal case-lambda) . _) #true]
|
||||||
|
[_ #false]))
|
||||||
|
|
||||||
;; tc-expr/check : syntax tc-results -> tc-results
|
;; tc-expr/check : syntax tc-results -> tc-results
|
||||||
(define/cond-contract (tc-expr/check/internal form expected)
|
(define/cond-contract (tc-expr/check/internal form expected)
|
||||||
(--> syntax? tc-results? tc-results?)
|
(--> syntax? tc-results? tc-results?)
|
||||||
|
@ -356,7 +365,8 @@
|
||||||
[(let-values ([(name ...) expr] ...) . body)
|
[(let-values ([(name ...) expr] ...) . body)
|
||||||
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
|
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
|
||||||
[(letrec-values ([(name) expr]) name*)
|
[(letrec-values ([(name) expr]) name*)
|
||||||
#:when (and (identifier? #'name*) (free-identifier=? #'name #'name*))
|
#:when (and (identifier? #'name*) (free-identifier=? #'name #'name*)
|
||||||
|
(value-restriction? #'expr #'name))
|
||||||
(match expected
|
(match expected
|
||||||
[(tc-result1: t)
|
[(tc-result1: t)
|
||||||
(with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]
|
(with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]
|
||||||
|
|
Loading…
Reference in New Issue
Block a user