allow different phases for `free-identifier=?' arguments

collects/scribblings/reference/stx-comp.scrbl

@@ -33,15 +33,19 @@ suitable expression context at the @tech{phase level} indicated by
 
 
 @defproc[(free-identifier=? [a-id syntax?] [b-id syntax?]
-                            [phase-level (or/c exact-integer? #f)
+                            [a-phase-level (or/c exact-integer? #f)
-                                         (syntax-local-phase-level)])
+                                           (syntax-local-phase-level)]
+                            [b-phase-level (or/c exact-integer? #f)
+                                           a-phase-level])
          boolean?]{
 
 Returns @racket[#t] if @racket[a-id] and @racket[b-id] access the same
 @tech{local binding}, @tech{module binding}, or @tech{top-level
 binding}---perhaps via @tech{rename transformers}---at the @tech{phase
-level} indicated by @racket[phase-level]. A @racket[#f] value for
+levels} indicated by @racket[a-phase-level] and
-@racket[phase-level] corresponds to the @tech{label phase level}.
+@racket[b-phase-level], respectively. A @racket[#f] value for
+@racket[a-phase-level] or @racket[b-phase-level] corresponds to the
+@tech{label phase level}.
 
 ``Same module binding'' means that the identifiers refer to the same
 original definition site, and not necessarily to the same

collects/syntax/kerncase.rkt

@@ -32,16 +32,8 @@
                             free-identifier=?]
                            [(and #,(syntax-e #'rel?) (= p 1)) 
                             free-transformer-identifier=?]
-                           [else (let ([id (namespace-module-identifier p)])
+                           [else (lambda (a b)
-                                   (lambda (a b)
+                                   (free-identifier=? a b p '#,(syntax-local-phase-level)))]))
-                                     (free-identifier=? (datum->syntax id 
-                                                                       (let ([s (syntax-e b)])
-                                                                         (case s
-                                                                           [(#%plain-app) '#%app]
-                                                                           [(#%plain-lambda) 'lambda]
-                                                                           [else s])))
-                                                        a
-                                                        p)))]))
             clause ...))])))
   
   (define-syntax kernel-syntax-case

collects/tests/racket/stx.rktl

@@ -1269,6 +1269,11 @@
           (test #t eval '(free-identifier=? (f) #'x))
           (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id))))))))
 
+(test #t free-identifier=? #'lambda #'lambda 0 1)
+(test #f free-identifier=? #'lambda #'lambda 0 4)
+(require (for-meta 4 racket/base))
+(test #t free-identifier=? #'lambda #'lambda 0 4)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  certification example from the manual
 

src/racket/src/schpriv.h

@@ -1008,6 +1008,9 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist);
 
 int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase);
 int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym);
+int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b, 
+                          Scheme_Object *a_phase, Scheme_Object *b_phase,
+                          Scheme_Object *asym);
 Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase);
 Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur,
                                       Scheme_Object **name, Scheme_Object *phase,
@@ -1026,6 +1029,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs);
 
 int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase);
 int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase);
+int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, 
+                             Scheme_Object *a_phase, Scheme_Object *b_phase);
 
 Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source);
 

src/racket/src/syntax.c

@@ -425,8 +425,8 @@ void scheme_init_stx(Scheme_Env *env)
 
   GLOBAL_IMMED_PRIM("make-syntax-delta-introducer"     , scheme_syntax_make_transfer_intro, 2, 3, env);
 
-  GLOBAL_IMMED_PRIM("bound-identifier=?"               , bound_eq                  , 2, 3, env);
+  GLOBAL_IMMED_PRIM("bound-identifier=?"               , bound_eq                  , 2, 4, env);
-  GLOBAL_IMMED_PRIM("free-identifier=?"                , module_eq                 , 2, 3, env);
+  GLOBAL_IMMED_PRIM("free-identifier=?"                , module_eq                 , 2, 4, env);
   GLOBAL_IMMED_PRIM("free-transformer-identifier=?"    , module_trans_eq           , 2, 2, env);
   GLOBAL_IMMED_PRIM("free-template-identifier=?"       , module_templ_eq           , 2, 2, env);
   GLOBAL_IMMED_PRIM("free-label-identifier=?"          , module_label_eq           , 2, 2, env);
@@ -4485,7 +4485,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
   }
 }
 
-int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
+int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b, 
+                          Scheme_Object *a_phase, Scheme_Object *b_phase, 
+                          Scheme_Object *asym)
 {
   Scheme_Object *bsym;
   Scheme_Hash_Table *free_id_recur;
@@ -4498,7 +4500,7 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
       free_id_recur = make_recur_table();
     else
       free_id_recur = NULL;
-    bsym = get_module_src_name(b, phase, free_id_recur);
+    bsym = get_module_src_name(b, b_phase, free_id_recur);
     if (!asym)
       release_recur_table(free_id_recur);
   } else
@@ -4506,7 +4508,7 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
   if (!asym) {
     if (SCHEME_STXP(a)) {
       free_id_recur = make_recur_table();
-      asym = get_module_src_name(a, phase, free_id_recur);
+      asym = get_module_src_name(a, a_phase, free_id_recur);
       release_recur_table(free_id_recur);
     } else
       asym = a;
@@ -4520,11 +4522,11 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
     return 1;
 
   free_id_recur = make_recur_table();
-  a = resolve_env(a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
+  a = resolve_env(a, a_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
   release_recur_table(free_id_recur);
 
   free_id_recur = make_recur_table();
-  b = resolve_env(b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
+  b = resolve_env(b, b_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
   release_recur_table(free_id_recur);
 
   if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
@@ -4536,9 +4538,14 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
   return SAME_OBJ(a, b);
 }
 
+int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
+{
+  return scheme_stx_module_eq3(a, b, phase, phase, NULL);
+}
+
 int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase)
 {
-  return scheme_stx_module_eq2(a, b, scheme_make_integer(phase), NULL);
+  return scheme_stx_module_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase), NULL);
 }
 
 Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase)
@@ -4647,7 +4654,8 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
   return scheme_false;
 }
 
-int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
+int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, 
+                             Scheme_Object *a_phase, Scheme_Object *b_phase)
      /* If uid is given, it's the environment for b. */
 {
   Scheme_Object *asym, *bsym, *ae, *be;
@@ -4668,13 +4676,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
   if (!SAME_OBJ(asym, bsym))
     return 0;
 
-  ae = resolve_env(a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
+  ae = resolve_env(a, a_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
   /* No need to module_resolve ae, because we ignored module renamings. */
 
   if (uid)
     be = uid;
   else {
-    be = resolve_env(b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
+    be = resolve_env(b, b_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
     /* No need to module_resolve be, because we ignored module renamings. */
   }
 
@@ -4695,9 +4703,14 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
   return 1;
 }
 
+int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
+{
+  return scheme_stx_env_bound_eq2(a, b, uid, phase, phase);
+}
+
 int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase)
 {
-  return scheme_stx_env_bound_eq(a, b, NULL, phase);
+  return scheme_stx_env_bound_eq2(a, b, NULL, phase, phase);
 }
 
 #if EXPLAIN_RESOLVE
@@ -8116,14 +8129,14 @@ static Scheme_Object *bound_eq(int argc, Scheme_Object **argv)
 
   phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0);
 
-  return (scheme_stx_bound_eq(argv[0], argv[1], phase)
+  return (scheme_stx_env_bound_eq2(argv[0], argv[1], NULL, phase, phase)
 	  ? scheme_true
 	  : scheme_false);
 }
 
 static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_Object **argv)
 {
-  Scheme_Object *phase;
+  Scheme_Object *phase, *phase2;
 
   if (!SCHEME_STX_IDP(argv[0]))
     scheme_wrong_type(who, "identifier syntax", 0, argc, argv);
@@ -8135,8 +8148,12 @@ static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_
                          ? scheme_false 
                          : scheme_make_integer(delta)),
                         0);
+  if (argc > 3)
+    phase2 = extract_phase(who, 3, argc, argv, phase, 0);
+  else
+    phase2 = phase;
 
-  return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL)
+  return (scheme_stx_module_eq3(argv[0], argv[1], phase, phase2, NULL)
 	  ? scheme_true
 	  : scheme_false);
 }