identifier-binding: add mode to report top-level binding info

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.6.0.3")
+(define version "6.6.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -95,18 +95,21 @@ is @racket[#f].}
 
 @defproc[(identifier-binding [id-stx identifier?]
                              [phase-level (or/c exact-integer? #f)
-                                          (syntax-local-phase-level)])
+                                          (syntax-local-phase-level)]
+                             [top-level-symbol? any/c #f])
          (or/c 'lexical
                #f
-               (listof module-path-index?
+               (list/c module-path-index?
                        symbol?
                        module-path-index?
                        symbol?
                        exact-nonnegative-integer?
                        (or/c exact-integer? #f)
-                       (or/c exact-integer? #f)))]{
+                       (or/c exact-integer? #f))
+               (list/c symbol?))]{
 
-Returns one of three kinds of values, depending on the binding of
+Returns one of three (if @racket[top-level-symbol?] is @racket[#f])
+or four (if @racket[top-level-symbol?] is true) kinds of values, depending on the binding of
 @racket[id-stx] at the @tech{phase level} indicated by
 @racket[phase-level] (where a @racket[#f] value for
 @racket[phase-level] corresponds to the @tech{label phase level}):
@@ -166,19 +169,29 @@ Returns one of three kinds of values, depending on the binding of
 
         ]}
 
+      @item{The result is @racket[(list _source-id)] if @racket[id-stx] has a
+            @tech{top-level binding} and @racket[top-level-symbol?] is true.}
+
       @item{The result is @racket[#f] if @racket[id-stx] has a
-            @tech{top-level binding} (or, equivalently, if it is
+            @tech{top-level binding} and @racket[top-level-symbol?] is
-            @tech{unbound}).}
+            @racket[#f] or if @racket[id-stx] is @tech{unbound}. An
+            unbound identifier is typically treated the same as an
+            identifier whose top-level binding is a variable.}
 
       ]
 
 If @racket[id-stx] is bound to a @tech{rename-transformer}, the result
 from @racket[identifier-binding] is for the identifier in the
 transformer, so that @racket[identifier-binding] is consistent with
-@racket[free-identifier=?].}
+@racket[free-identifier=?].
+
+@history[#:changed "6.6.0.4" @elem{Added the @racket[top-level-symbol?] argument to report
+                                   information on top-level bindings.}]}
 
 
-@defproc[(identifier-transformer-binding [id-stx identifier?])
+@defproc[(identifier-transformer-binding [id-stx identifier?]
+                                         [rt-phase-level (or/c exact-integer? #f)
+                                                         (syntax-local-phase-level)])
          (or/c 'lexical
                #f
                (listof module-path-index?
@@ -189,7 +202,7 @@ transformer, so that @racket[identifier-binding] is consistent with
                        (or/c exact-integer? #f)
                        (or/c exact-integer? #f)))]{
 
-Same as @racket[(identifier-binding id-stx (add1 (syntax-local-phase-level)))].}
+Same as @racket[(identifier-binding id-stx (and rt-phase-level (add1 rt-phase-level)))].}
 
 
 @defproc[(identifier-template-binding [id-stx identifier?])

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

@@ -578,6 +578,21 @@
   (test 'x cadddr b)
   (test #t equal? (car b) (caddr b)))
 
+;; Top-level bindings:
+(test #f identifier-binding #'test 0)
+(test #f identifier-binding #'test 0 #f)
+(test '(test) identifier-binding #'test 0 #t)
+(test '#f identifier-binding #'this-identifier-is-never-defined 0 #t)
+
+(define-syntax-rule (introduce-a-definition-of-x bind-id)
+  (begin
+    (define x 10)
+    (define bind-id (identifier-binding #'x 0 #t))))
+(introduce-a-definition-of-x sym-list-for-x)
+(test #t pair? sym-list-for-x)
+(test #t symbol? (car sym-list-for-x))
+(test #f eq? 'x (car sym-list-for-x)) ; since macro-introduced
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; identifier-binding and (nominal) phase reporting
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.6.0.3"
+#define MZSCHEME_VERSION "6.6.0.4"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 6
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #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

@@ -358,7 +358,7 @@ void scheme_init_stx(Scheme_Env *env)
   GLOBAL_IMMED_PRIM("free-template-identifier=?"       , free_templ_eq           , 2, 2, env);
   GLOBAL_IMMED_PRIM("free-label-identifier=?"          , free_label_eq           , 2, 2, env);
 
-  GLOBAL_IMMED_PRIM("identifier-binding"               , free_binding            , 1, 2, env);
+  GLOBAL_IMMED_PRIM("identifier-binding"               , free_binding            , 1, 3, env);
   GLOBAL_IMMED_PRIM("identifier-transformer-binding"   , free_trans_binding      , 1, 2, env);
   GLOBAL_IMMED_PRIM("identifier-template-binding"      , free_templ_binding      , 1, 1, env);
   GLOBAL_IMMED_PRIM("identifier-label-binding"         , free_label_binding      , 1, 1, env);
@@ -8481,6 +8481,7 @@ static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv
 {
   Scheme_Object *a, *m, *nom_mod, *nom_a, *phase;
   Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase;
+  int top_level_as_symbol = 0;
 
   a = argv[0];
 
@@ -8506,6 +8507,9 @@ static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv
       phase = scheme_bin_plus(dphase, phase);
   }
 
+  if (argc > 2)
+    top_level_as_symbol = SCHEME_TRUEP(argv[2]);
+
   m = scheme_stx_lookup_w_nominal(a, phase, 0,
                                   NULL, NULL, NULL, NULL,
                                   &nom_mod, &nom_a,
@@ -8529,7 +8533,9 @@ static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv
     m = SCHEME_VEC_ELS(m)[0];
 
     if (SCHEME_FALSEP(m)) {
-      /* loses information; improve API in the future? */
+      if (top_level_as_symbol)
+        return CONS(a, scheme_null);
+      else 
         return scheme_false;
     }