change `syntax-local-lift-context' to distinguish top-level environments

Although not documented as such, the implementation used to return
form did not take the special meaning of #f into account. It seems
better to fix `syntax-local-lift-context' to match its documentation.

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

@@ -1034,14 +1034,15 @@
      (with-syntax ([id (syntax-local-lift-expression #'(set! lifted-output "lifted!"))])
        #'(list lifted-output id))]))
 
-(test (list #f 2) '@@foo (@@foo 2))
-(test (list #f 2) eval-syntax #'(@@foo 2))
-(test (list #f 2) eval (expand-once #'(@@foo 2)))
-(test (list #f 2) eval (expand-syntax-once #'(@@foo 2)))
-(test (list #f 2) eval (expand #'(@@foo 2)))
-(test (list #f 2) eval (expand-syntax #'(@@foo 2)))
-(test (list #f 2) eval (expand-to-top-form #'(@@foo 2)))
-(test (list #f 2) eval (expand-syntax-to-top-form #'(@@foo 2)))
+(let ([res (@@foo 2)])
+  (test res '@@foo (@@foo 2))
+  (test res eval-syntax #'(@@foo 2))
+  (test res eval (expand-once #'(@@foo 2)))
+  (test res eval (expand-syntax-once #'(@@foo 2)))
+  (test res eval (expand #'(@@foo 2)))
+  (test res eval (expand-syntax #'(@@foo 2)))
+  (test res eval (expand-to-top-form #'(@@foo 2)))
+  (test res eval (expand-syntax-to-top-form #'(@@foo 2))))
 (test (list "lifted!" (void)) '@@goo (@@goo))
 (set! lifted-output #f)
 (test (list "lifted!" (void)) eval (expand-once #'(@@goo)))
@@ -1148,14 +1149,43 @@
      (mk null)
      (mk #f))))
 
-(test '(#f 1) 'let-foo (let ([x 5]) (@@foo 1)))
-(test '(#f 1) eval (expand #'(let ([x 5]) (@@foo 1))))
+(let ([res (let ([x 5]) (@@foo 1))])
+  (test res 'let-foo (let ([x 5]) (@@foo 1)))
+  (test res eval (expand #'(let ([x 5]) (@@foo 1)))))
 (test '(the-key 1) 'local-foo (let ([x 5]) (@@local-top (@@foo 1))))
 (test '(the-key 1) eval (expand #'(let ([x 5]) (@@local-top (@@foo 1)))))
 (test '(the-key 1) eval (expand #'(@@local-top (@@foo 1))))
 (test '(the-key 1) eval (expand #'(@@local-top2 (@@foo 1))))
 (test '(the-key 1) eval (expand #'(@@local-top3 (@@foo 1))))
 
+;; Check for distinct top-level contexts for different namespaces:
+(module example-that-uses-the-lift-context racket/base
+  (require (for-syntax racket/base))
+  (provide m)
+  (define-for-syntax ht (make-hash))
+  (define-syntax (m stx)
+    (or (hash-ref ht (syntax-local-lift-context) #f)
+        (let ([id (syntax-local-lift-expression #`(quote #,(current-inexact-milliseconds)))])
+          (hash-set! ht (syntax-local-lift-context) id)
+          id))))
+(dynamic-require ''example-that-uses-the-lift-context 0)
+(let ([go
+       (lambda ()
+         (define orig-ns (current-namespace))
+         (parameterize ([current-namespace (make-base-namespace)])
+           (namespace-attach-module orig-ns ''example-that-uses-the-lift-context)
+           (namespace-require ''example-that-uses-the-lift-context)
+           (test (eval 'm) eval 'm)
+           (eval '(module extra-module racket/base
+                    (require 'example-that-uses-the-lift-context)))
+           (dynamic-require ''extra-module 0)
+           (let ([ns (module->namespace ''extra-module)])
+             (test (eval 'm ns) eval 'm ns)
+             (test #f = (eval 'm) (eval 'm ns)))))])
+  (go)
+  (go)
+  (go))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check interaction of macro-introduced/lifted names and
 ;;  module->namespace

racket/src/racket/src/compile.c

@@ -3394,7 +3394,7 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
 
   while (1) {
     scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env),
-                                scheme_false, scheme_false, scheme_null, scheme_false);
+                                scheme_false, scheme_top_level_lifts_key(env), scheme_null, scheme_false);
 
     if (rec[drec].comp) {
       scheme_init_compile_recs(rec, drec, recs, 1);

racket/src/racket/src/eval.c

@@ -3967,7 +3967,7 @@ static void *compile_k(void)
 	 before the rest. */
       while (1) {
 	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
-                                    scheme_false, scheme_false, scheme_null, scheme_false);
+                                    scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
 	form = scheme_check_immediate_macro(form, 
 					    cenv, &rec, 0,
 					    0, &gval, NULL, NULL);
@@ -4009,7 +4009,7 @@ static void *compile_k(void)
 
       while (1) {
 	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
-                                    scheme_false, scheme_false, scheme_null, scheme_false);
+                                    scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
 
 	scheme_init_compile_recs(&rec, 0, &rec2, 1);
 
@@ -4406,6 +4406,9 @@ static void *expand_k(void)
   p->ku.k.p3 = NULL;
   p->ku.k.p4 = NULL;
 
+  if (SCHEME_FALSEP(catch_lifts_key))
+    catch_lifts_key = scheme_top_level_lifts_key(env);
+
   if (!SCHEME_STXP(obj))
     obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
 
@@ -4510,7 +4513,7 @@ static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
 Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env)
 {
   return r_expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
-		  -1, 1, 0, scheme_true, -1, 0);
+		  -1, 1, 0, scheme_false, -1, 0);
 }
 
 Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj)
@@ -4707,6 +4710,16 @@ Scheme_Object *scheme_generate_lifts_key(void)
   return scheme_make_symbol(buf); /* uninterned */
 }
 
+Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env)
+{
+  if (!env->genv->lift_key) {
+    Scheme_Object *o;
+    o = scheme_generate_lifts_key();
+    env->genv->lift_key = o;
+  }
+  return env->genv->lift_key;
+}
+
 Scheme_Object *
 scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env)
 {
@@ -4996,7 +5009,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
       scheme_frame_captures_lifts(env, 
                                   (catch_lifts < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, 
                                   data,
-                                  scheme_false, 
+                                  scheme_top_level_lifts_key(env),
                                   catch_lifts_key, NULL,
                                   scheme_false);
     }

racket/src/racket/src/mzmark_type.inc

@@ -2286,6 +2286,8 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) {
 
   gcMARK2(e->shadowed_syntax, gc);
 
+  gcMARK2(e->lift_key, gc);
+
   gcMARK2(e->link_midx, gc);
   gcMARK2(e->require_names, gc);
   gcMARK2(e->et_require_names, gc);
@@ -2329,6 +2331,8 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) {
 
   gcFIXUP2(e->shadowed_syntax, gc);
 
+  gcFIXUP2(e->lift_key, gc);
+
   gcFIXUP2(e->link_midx, gc);
   gcFIXUP2(e->require_names, gc);
   gcFIXUP2(e->et_require_names, gc);

racket/src/racket/src/mzmarksrc.c

@@ -925,6 +925,8 @@ namespace_val {
 
   gcMARK2(e->shadowed_syntax, gc);
 
+  gcMARK2(e->lift_key, gc);
+
   gcMARK2(e->link_midx, gc);
   gcMARK2(e->require_names, gc);
   gcMARK2(e->et_require_names, gc);

racket/src/racket/src/schpriv.h

@@ -2744,6 +2744,7 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_generate_lifts_key(void);
+Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env);
 
 Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, 
                                                   intptr_t phase,
@@ -3248,6 +3249,8 @@ struct Scheme_Env {
 
   Scheme_Hash_Table *shadowed_syntax; /* top level only */
 
+  Scheme_Object *lift_key; /* for `syntax-local-lift-context' */
+
   /* Per-instance: */
   intptr_t phase, mod_phase;
   Scheme_Object *link_midx;