From 57358149cb90da530cb1a0110c532d3fa8f5088e Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sat, 14 Jul 2012 21:36:56 -0400
Subject: [PATCH] Don't shortcut simple `letrec` forms that aren't `lambda`s.

Closes PR 12841.

original commit: 2500dad8f124429fc5b035fc58add891f2bd7bb8
---
 collects/tests/typed-racket/fail/single-letrec.rkt |  5 +++++
 collects/typed-racket/typecheck/tc-expr-unit.rkt   | 12 +++++++++++-
 2 files changed, 16 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-racket/fail/single-letrec.rkt

diff --git a/collects/tests/typed-racket/fail/single-letrec.rkt b/collects/tests/typed-racket/fail/single-letrec.rkt
new file mode 100644
index 00000000..f7cec773
--- /dev/null
+++ b/collects/tests/typed-racket/fail/single-letrec.rkt
@@ -0,0 +1,5 @@
+#lang typed/racket
+
+(: f (Pair 'bad 'worse))
+(define f
+  (letrec ((y y)) y))
diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt
index 58973053..0f7ba022 100644
--- a/collects/typed-racket/typecheck/tc-expr-unit.rkt
+++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt
@@ -256,6 +256,15 @@
                           t))]
          [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
 (define/cond-contract (tc-expr/check/internal form expected)
   (--> syntax? tc-results? tc-results?)
@@ -356,7 +365,8 @@
         [(let-values ([(name ...) expr] ...) . body)
          (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
         [(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
            [(tc-result1: t)
             (with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]