add 'undefined-error-name property for letrec bindings

pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax.scrbl

@@ -1949,12 +1949,18 @@ distinct; later bindings shadow earlier bindings.
 
 Like @racket[let], including left-to-right evaluation of the @racket[val-expr]s,
 but the @tech{locations} for all @racket[id]s are
-created first and filled with @|undefined-const|, all
+created first, all
 @racket[id]s are bound in all @racket[val-expr]s as well as the
-@racket[body]s, and each @racket[id] is set immediately after the
+@racket[body]s, and each @racket[id] is initialized immediately after the
 corresponding @racket[val-expr] is evaluated. The @racket[id]s must be distinct according to
 @racket[bound-identifier=?].
 
+Referencing or assigning to an @racket[id] before its initialization
+raises @racket[exn:fail:contract:variable]. If an @racket[id] has an
+@indexed-racket['undefined-error-name] @tech{syntax property} whose
+value is a symbol, the symbol is used as the name of the variable for
+error reporting, instead of the symbolic form of @racket[id].
+
 @mz-examples[
 (letrec ([is-even? (lambda (n)
                      (or (zero? n)
@@ -1963,7 +1969,9 @@ corresponding @racket[val-expr] is evaluated. The @racket[id]s must be distinct
                     (and (not (zero? n))
                          (is-even? (sub1 n))))])
   (is-odd? 11))
-]}
+]
+
+@history[#:changed "6.0.1.2" @elem{Changed reference or assignment of an uninitialized @racket[id] to an error.}]}
 
 @defform[(let-values ([(id ...) val-expr] ...) body ...+)]{ Like
 @racket[let], except that each @racket[val-expr] must produce as many
@@ -1991,8 +1999,7 @@ for each @racket[id], all of which are bound in the later
 @defform[(letrec-values ([(id ...) val-expr] ...) body ...+)]{ Like
 @racket[letrec], except that each @racket[val-expr] must produce as
 many values as corresponding @racket[id]s. A separate @tech{location} is
-created for each @racket[id], all of which are initialized to
-@|undefined-const| and bound in all @racket[val-expr]s
+created for each @racket[id], all of which are bound in all @racket[val-expr]s
 and in the @racket[body]s.
 
 @mz-examples[

pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl

@@ -108,6 +108,22 @@
 (syntax-test #'(lambda (x . 5) x))
 (syntax-test #'(lambda (x) x . 5))
 
+(err/rt-test (letrec ([not-ready not-ready]) 5)
+             (lambda (exn)
+               (and (exn:fail:contract:variable? exn)
+                    (eq? 'not-ready (exn:fail:contract:variable-id exn)))))
+(err/rt-test (let-syntax ([m
+                           (lambda (stx)
+                             (with-syntax ([not-ready-id
+                                            (syntax-property #'not-ready
+                                                             'undefined-error-name
+                                                             'alice)])
+                               #'(letrec ([not-ready-id not-ready]) 5)))])
+               (m))
+             (lambda (exn)
+               (and (exn:fail:contract:variable? exn)
+                    (eq? 'alice (exn:fail:contract:variable-id exn)))))
+
 (let ([f
        (case-lambda
 	[() 'zero]

racket/src/racket/src/compile.c

@@ -63,6 +63,8 @@ ROSYM static Scheme_Object *quote_symbol;
 ROSYM static Scheme_Object *letrec_syntaxes_symbol;
 ROSYM static Scheme_Object *values_symbol;
 ROSYM static Scheme_Object *call_with_values_symbol;
+ROSYM static Scheme_Object *inferred_name_symbol;
+ROSYM static Scheme_Object *undefined_error_name_symbol;
 
 THREAD_LOCAL_DECL(static Scheme_Object *quick_stx);
 
@@ -165,6 +167,9 @@ void scheme_init_compile (Scheme_Env *env)
   REGISTER_SO(disappeared_binding_symbol);
   REGISTER_SO(compiler_inline_hint_symbol);
 
+  REGISTER_SO(inferred_name_symbol);
+  REGISTER_SO(undefined_error_name_symbol);
+
   scheme_undefined->type = scheme_undefined_type;
   
   lambda_symbol = scheme_intern_symbol("lambda");
@@ -178,6 +183,9 @@ void scheme_init_compile (Scheme_Env *env)
   disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding");
   compiler_inline_hint_symbol = scheme_intern_symbol("compiler-hint:cross-module-inline");
 
+  inferred_name_symbol = scheme_intern_symbol("inferred-name");
+  undefined_error_name_symbol = scheme_intern_symbol("undefined-error-name");
+
   scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax, 
 							    define_values_expand);
   scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax, 
@@ -367,13 +375,24 @@ Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *cu
 {
   Scheme_Object *name;
 
-  name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
+  name = scheme_stx_property(code, inferred_name_symbol, NULL);
   if (name && SCHEME_SYMBOLP(name))
     return name;
   else
     return current_val;
 }
 
+static Scheme_Object *get_local_name(Scheme_Object *id)
+{
+  Scheme_Object *name;
+
+  name = scheme_stx_property(id, undefined_error_name_symbol, NULL);
+  if (name && SCHEME_SYMBOLP(name))
+    return name;
+  else
+    return SCHEME_STX_VAL(id);
+}
+
 /**********************************************************************/
 /*                           lambda utils                             */
 /**********************************************************************/
@@ -498,7 +517,7 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Inf
 {
   Scheme_Object *name;
 
-  name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
+  name = scheme_stx_property(code, inferred_name_symbol, NULL);
   if (name && SCHEME_SYMBOLP(name)) {
     name = combine_name_with_srcloc(name, code, 0);
   } else if (name && SCHEME_VOIDP(name)) {
@@ -2260,7 +2279,9 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
          currently. It would be ok if we record extra names, though. */
       clv_names = MALLOC_N(Scheme_Object*, lv->count);
       for (m = pre_k; m < k; m++) {
-        clv_names[m - pre_k] = SCHEME_STX_SYM(names[m]);
+        Scheme_Object *ln;
+        ln = get_local_name(names[m]);
+        clv_names[m - pre_k] = ln;
       }
       lv->names = clv_names;
     }

racket/src/racket/src/fun.c

@@ -92,7 +92,6 @@ READ_ONLY Scheme_Object *scheme_apply_proc;
 READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
 READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
 READ_ONLY Scheme_Object *scheme_tail_call_waiting;
-READ_ONLY Scheme_Object *scheme_inferred_name_symbol;
 READ_ONLY Scheme_Object *scheme_default_prompt_tag;
 READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;
 
@@ -644,12 +643,10 @@ scheme_init_fun (Scheme_Env *env)
   none_symbol                = scheme_intern_symbol("none");
 
   REGISTER_SO(is_method_symbol);
-  REGISTER_SO(scheme_inferred_name_symbol);
   REGISTER_SO(cont_key);
   REGISTER_SO(barrier_prompt_key);
   REGISTER_SO(prompt_cc_guard_key);
   is_method_symbol = scheme_intern_symbol("method-arity-error");
-  scheme_inferred_name_symbol = scheme_intern_symbol("inferred-name");
   cont_key = scheme_make_symbol("k"); /* uninterned */
   barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */
   prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */

racket/src/racket/src/schpriv.h

@@ -3185,7 +3185,6 @@ void scheme_ill_formed(Mz_CPort *port);
 # define scheme_ill_formed_code(port) scheme_ill_formed(port)
 #endif
 
-extern Scheme_Object *scheme_inferred_name_symbol;
 Scheme_Object *scheme_check_name_property(Scheme_Object *stx, Scheme_Object *current_name);
 
 Scheme_Object *scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env);