add `identifier-bindig-symbol'; fix free-id-table for renames

The implement of `free-id-table' uses `identifier-binding'
to decide on a symbolic name as a key for each identifier,
but `identifier-binding' doesn't provide enough information
for local and top-level bindings. The new `identifier-binding-symbol'
function provides that information.

Closes PR 13911

pkgs/racket-pkgs/racket-doc/scribblings/reference/stx-comp.scrbl

@@ -218,4 +218,19 @@ Same as @racket[(identifier-binding id-stx (sub1 (syntax-local-phase-level)))].}
 
 Same as @racket[(identifier-binding id-stx #f)].}
 
+
+@defproc[(identifier-binding-symbol [id-stx syntax?]
+                                    [phase-level (or/c exact-integer? #f)
+                                                 (syntax-local-phase-level)])
+         symbol?]{
+
+Like @racket[identifier-binding], but produces a symbol that
+corresponds to the binding. The symbol result is the same for any
+identifiers that are @racket[free-identifier=?].
+
+When @racket[identifier-binding] would produce a list, then the second
+element of that list is the result that
+@racket[identifier-binding-symbol] produces.}
+
+
 @close-eval[stx-eval]

pkgs/racket-pkgs/racket-test/tests/racket/id-table-test.rktl

@@ -328,4 +328,11 @@
 
     ))
 
+(let ()
+  (define-syntax name 'dummy)
+  (define-syntax alias (make-rename-transformer #'name))
+  (define table (make-free-id-table))
+  (free-id-table-set! table #'alias 0)
+  (test 0 free-id-table-ref table #'name))
+
 (report-errs)

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

@@ -614,6 +614,21 @@
   (test eval 'expand-to-top-form (eval (expand-syntax-to-top-form #'eval)))
   (test #t syntax? (expand-syntax-to-top-form (datum->syntax #f 'eval))))
 
+(let ()
+  (define-syntax name 'dummy)
+  (define-syntax alias (make-rename-transformer #'name))
+  (test (identifier-binding-symbol #'name)
+        identifier-binding-symbol #'alias))
+
+(require (only-in racket/base [add1 increment-by-one]))
+(test (identifier-binding-symbol #'add1)
+      identifier-binding-symbol #'increment-by-one)
+
+(define top-level-add1 add1)
+(define-syntax top-level-increment-by-one (make-rename-transformer #'top-level-add1))
+(test (identifier-binding-symbol #'top-level-add1)
+      identifier-binding-symbol #'top-level-increment-by-one)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; origin tracking
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

racket/lib/collects/racket/HISTORY.txt

@@ -1,3 +1,6 @@
+Version 5.3.900.6
+Added identifier-binding-symbol
+
 Version 5.3.900.5
 Added call-with-default-reading-parameterization
 racket/file: added call-with-atomic-output-file

racket/lib/collects/syntax/private/id-table.rkt

@@ -402,10 +402,7 @@ Notes (FIXME?):
            bound-identifier=?)
 
 (define (free-identifier->symbol id phase)
-  (let ([binding (identifier-binding id phase)])
+  (identifier-binding-symbol id phase))
-    (if (pair? binding)
-        (cadr binding)
-        (syntax-e id))))
 
 (make-code free-id-table
            free-identifier->symbol

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1108
+#define EXPECTED_PRIM_COUNT 1109
 #define EXPECTED_UNSAFE_COUNT 100
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.900.5"
+#define MZSCHEME_VERSION "5.3.900.6"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 900
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/syntax.c

@@ -88,6 +88,7 @@ static Scheme_Object *module_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv);
+static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv);
 static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv);
 static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv);
 static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
@@ -446,6 +447,8 @@ void scheme_init_stx(Scheme_Env *env)
   GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune          , 1, 2, env);
   GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env);
 
+  GLOBAL_IMMED_PRIM("identifier-binding-symbol"        , module_binding_symbol     , 1, 2, env);
+
   GLOBAL_NONCM_PRIM("syntax-source-module"             , syntax_src_module         , 1, 2, env);
 
   GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env);
@@ -2042,6 +2045,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
   Scheme_Object *rename_insp;
 
   if (scheme_hash_get(free_id_recur, id)) {
+    *_sealed = 1;
     return id;
   }
   scheme_hash_set(free_id_recur, id, id);
@@ -4041,7 +4045,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
           EXPLAIN(fprintf(stderr, "%d  search result: %p\n", depth, rename));
             	  
 	  if (rename) {
-            if (mrn->sealed < STX_SEAL_BOUND)
+            if ((mrn->sealed < STX_SEAL_BOUND) && is_in_module)
               mresult_depends_unsealed = 1;
 
 	    if (mrn->kind == mzMOD_RENAME_MARKED) {
@@ -4159,7 +4163,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
               get_names[6] = (mrn->insp ? mrn->insp : mresult_insp);
             EXPLAIN(fprintf(stderr, "%d  mresult_insp %p %p\n", depth, mresult_insp, mrn->insp));
           } else {
-            if (mrn->sealed < STX_SEAL_ALL)
+            if ((mrn->sealed < STX_SEAL_ALL) && is_in_module)
               mresult_depends_unsealed = 1;
 	    mresult = scheme_false;
             mresult_skipped = -1;
@@ -6314,6 +6318,12 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
                                                          free_id_recur);
                       release_recur_table(free_id_recur);
                       if (!sealed) {
+                        free_id_recur = make_recur_table();
+                        extract_module_free_id_binding((Scheme_Object *)mrn,
+                                                       mrn->free_id_renames->keys[i],
+                                                       mrn->free_id_renames->vals[i],
+                                                       &sealed,
+                                                       free_id_recur);
                         scheme_signal_error("write: unsealed local-definition or module context"
                                             " found in syntax object");
                       }
@@ -8560,7 +8570,8 @@ static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv)
   return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv);
 }
 
-static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, Scheme_Object *dphase)
+static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, 
+                                        Scheme_Object *dphase, int get_symbol)
 {
   Scheme_Object *a, *m, *nom_mod, *nom_a, *phase;
   Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase;
@@ -8601,6 +8612,14 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
                              NULL,
                              NULL);
 
+  if (get_symbol) {
+    if ((!m || SAME_OBJ(m, scheme_undefined)) && nom_a) 
+      a = nom_a;
+    if (SCHEME_STXP(a))
+      a = SCHEME_STX_VAL(a);
+    return a;
+  }
+
   if (!m)
     return scheme_false;
   else if (SAME_OBJ(m, scheme_undefined)) {
@@ -8616,22 +8635,27 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
 
 static Scheme_Object *module_binding(int argc, Scheme_Object **argv)
 {
-  return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0));
+  return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0);
 }
 
 static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv)
 {
-  return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1));
+  return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0);
 }
 
 static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv)
 {
-  return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1));
+  return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0);
 }
 
 static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv)
 {
-  return do_module_binding("identifier-label-binding", argc, argv, scheme_false);
+  return do_module_binding("identifier-label-binding", argc, argv, scheme_false, 0);
+}
+
+static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv)
+{
+  return do_module_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1);
 }
 
 static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv)