add syntax-transforming-module-expression?', variable-reference->module-base-phase'

collects/scribblings/reference/namespaces.scrbl

@@ -413,3 +413,13 @@ result is @racket[#f].}
 Returns the @tech{phase} of the variable referenced by @racket[varref].}
 
 
+@defproc[(variable-reference->module-base-phase [varref variable-reference?])
+         exact-nonnegative-integer?]{
+
+Returns the @tech{phase} in which the module is instantiated for the
+variable referenced by @racket[varref], or @racket[0] if the variable
+for @racket[varref] is not within a module.
+
+For a variable with a module, the result is less than the result of
+@racket[(variable-reference->phase varref)] by @math{n} when the
+variable is bound at @tech{phase level} @math{n} within the module.}

collects/scribblings/reference/stx-trans.scrbl

@@ -11,7 +11,8 @@
 
 @(define (transform-time) @t{This procedure must be called during the
 dynamic extent of a @tech{syntax transformer} application by the
-expander or while a module is @tech{visit}ed, otherwise the
+expander or while a module is @tech{visit}ed (see 
+@racket[syntax-transforming?]), otherwise the
 @exnraise[exn:fail:contract].})
 
 
@@ -516,7 +517,7 @@ transformed is not in the module top-level, then @racket[stx] is
 eventually expanded in an expression context.
 
 @transform-time[] If the current expression being transformed is not
-within a @racket[module] form, or if it is not a run-time expression,
+within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), 
 then the @exnraise[exn:fail:contract].}
 
 
@@ -554,8 +555,8 @@ Lifts a @racket[#%provide] form corresponding to
 expanded or to an enclosing @racket[begin-for-syntax].
 
 @transform-time[] If the current expression being transformed is not
-within a @racket[module] form, or if it is not a run-time expression,
+within a @racket[module] form (see @racket[syntax-transforming-module-expression?]),
-then the @exnraise[exn:fail:contract]. }
+then the @exnraise[exn:fail:contract].}
 
 @defproc[(syntax-local-name) any/c]{
 
@@ -654,6 +655,13 @@ transformer} application by the expander and while a module is being
 @tech{visit}ed, @racket[#f] otherwise.}
 
 
+@defproc[(syntax-transforming-module-expression?) boolean?]{
+
+Returns @racket[#t] during the dynamic extent of a @tech{syntax
+transformer} application by the expander for an expression
+within a @racket[module] form, @racket[#f] otherwise.}
+
+
 @defproc[(syntax-local-introduce [stx syntax?]) syntax?]{
 
 Produces a syntax object that is like @racket[stx], except that a

collects/tests/racket/namespac.rktl

@@ -140,9 +140,12 @@
 (module phaser scheme/base 
   (define x (variable-reference->phase
              (#%variable-reference x)))
-  (provide x))
+  (define y (variable-reference->module-base-phase
+             (#%variable-reference y)))
+  (provide x y))
 
 (test 0 dynamic-require ''phaser 'x)
+(test 0 dynamic-require ''phaser 'y)
 
 (let ([s (open-output-string)])
   (parameterize ([current-output-port s])
@@ -157,8 +160,24 @@
             (let ([ns (make-base-namespace)])
               (namespace-attach-module (current-namespace) ''phaser ns)
               (eval '(require 'phaser) ns)
-              (display (eval 'x ns))))))
+              (display (eval 'x ns))
-  (test "1" get-output-string s))
+              (display (eval 'y ns))))))
+  (test "11" get-output-string s))
+
+(let ([s (open-output-string)])
+  (parameterize ([current-output-port s])
+    (let ([ns (make-base-namespace)])
+      (eval '(module m racket/base
+               (require (for-syntax racket/base))
+               (begin-for-syntax
+                (define x 10)
+                (displayln (variable-reference->phase
+                            (#%variable-reference x)))
+                (displayln (variable-reference->module-base-phase
+                            (#%variable-reference x))))))
+      (eval '(require (for-syntax 'm)))
+      (eval '(begin-for-syntax 10))))
+  (test "1\n0\n2\n1\n" get-output-string s))
 
 ;; ----------------------------------------
 

collects/tests/racket/stx.rktl

@@ -1586,6 +1586,31 @@
                   (let-syntax ([g (lambda (stx) nonesuch)])
                     10))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; `syntax-transforming?' and `syntax-transforming-module-expression?'
+
+(test #f syntax-transforming?)
+(test #f syntax-transforming-module-expression?)
+(test #t 'trans (let-syntax ([m (lambda (stx)
+                                  (datum->syntax stx (syntax-transforming?)))])
+                  (m)))
+(test #f 'trans-mod (let-syntax ([m (lambda (stx)
+                                      (datum->syntax stx (syntax-transforming-module-expression?)))])
+                      (m)))
+(let ([o (open-output-string)])
+  (parameterize ([current-output-port o])
+    (eval `(module m racket/base
+             (require (for-syntax racket/base))
+             (define-syntax (m stx)
+               (displayln (syntax-transforming-module-expression?))
+               #'1)
+             (m)))
+    (eval `(module m racket/base
+             (require (for-syntax racket/base))
+             (begin-for-syntax
+              (displayln (syntax-transforming-module-expression?))))))
+  (test "#t\n#f\n" get-output-string o))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/racket/src/compenv.c

@@ -2213,12 +2213,8 @@ scheme_local_lift_context(Scheme_Comp_Env *env)
   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4];
 }
 
-Scheme_Object *
+Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env)
-scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env)
 {
-  Scheme_Object *pr;
-  Scheme_Object *orig_expr;
-
   while (env) {
     if ((COMPILE_DATA(env)->lifts)
         && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]))
@@ -2226,10 +2222,21 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark,
     env = env->next;
   }
 
+  return env;
+}
+
+Scheme_Object *
+scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env)
+{
+  Scheme_Object *pr;
+  Scheme_Object *orig_expr;
+
+  env = scheme_get_module_lift_env(env);
+
   if (!env)
     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
 		     "syntax-local-lift-module-end-declaration: not currently transforming"
-                     " a run-time expression in a module declaration");
+                     " an expression within a module declaration");
   
   expr = scheme_add_remove_mark(expr, local_mark);
   orig_expr = expr;

src/racket/src/cstartup.inc

@@ -1,5 +1,5 @@
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,13,0,17,
 0,22,0,29,0,42,0,49,0,54,0,59,0,63,0,70,0,73,0,82,0,
 85,0,91,0,105,0,119,0,122,0,128,0,132,0,134,0,145,0,147,0,161,
@@ -99,7 +99,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 2018);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,109,0,0,0,1,0,0,8,0,21,0,26,
 0,43,0,65,0,94,0,109,0,127,0,143,0,157,0,179,0,195,0,212,0,
 234,0,245,0,251,0,4,1,11,1,18,1,30,1,46,1,70,1,102,1,120,
@@ -599,7 +599,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 10420);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0,57,
 0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,175,1,
 0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,
@@ -626,7 +626,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 496);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,65,0,0,0,1,0,0,7,0,18,0,45,
 0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,158,0,170,0,185,0,
 201,0,219,0,239,0,251,0,11,1,34,1,46,1,77,1,84,1,89,1,94,
@@ -927,7 +927,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 6241);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,29,
 0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,94,1,0,0,
 69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67,

src/racket/src/env.c

@@ -77,8 +77,10 @@ static Scheme_Object *variable_module_source(int, Scheme_Object *[]);
 static Scheme_Object *variable_namespace(int, Scheme_Object *[]);
 static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]);
 static Scheme_Object *variable_phase(int, Scheme_Object *[]);
+static Scheme_Object *variable_base_phase(int, Scheme_Object *[]);
 static Scheme_Object *variable_const_p(int, Scheme_Object *[]);
 static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]);
+static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]);
@@ -641,6 +643,7 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("variable-reference->module-base-phase", variable_base_phase, 1, 1, env);
 
   REGISTER_SO(scheme_varref_const_p_proc);
   scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, 
@@ -649,6 +652,7 @@ static void make_kernel_env(void)
   scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env);
 
   GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env);
+  GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);
@@ -1675,6 +1679,8 @@ static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, S
   ph = env->phase;
   if (tl == 2) {
     return scheme_make_integer(ph);
+  } else if (tl == 3) {
+    return scheme_make_integer(ph - env->mod_phase);
   } else if (tl) {
     /* return env directly; need to set up  */
     if (!env->phase && env->module)
@@ -1705,6 +1711,11 @@ static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[])
   return do_variable_namespace("variable-reference->phase", 2, argc, argv);
 }
 
+static Scheme_Object *variable_base_phase(int argc, Scheme_Object *argv[])
+{
+  return do_variable_namespace("variable-reference->phase", 3, argc, argv);
+}
+
 static Scheme_Object *variable_const_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v;
@@ -1780,6 +1791,14 @@ now_transforming(int argc, Scheme_Object *argv[])
 	  : scheme_false);
 }
 
+static Scheme_Object *
+now_transforming_module(int argc, Scheme_Object *argv[])
+{
+  if (scheme_get_module_lift_env(scheme_current_thread->current_local_env))
+    return scheme_true;
+  return scheme_false;
+}
+
 static Scheme_Object *
 do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur)
 {

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1031
+#define EXPECTED_PRIM_COUNT 1033
 #define EXPECTED_UNSAFE_COUNT 78
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 11

src/racket/src/schpriv.h

@@ -2427,6 +2427,7 @@ Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *ori
                                          Scheme_Comp_Env *env);
 Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, 
                                          Scheme_Comp_Env *env);
+Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env);
 
 void scheme_check_identifier(const char *formname, Scheme_Object *id,
 			     const char *where,

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.1.3.7"
+#define MZSCHEME_VERSION "5.1.3.8"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 7
+#define MZSCHEME_VERSION_W 8
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)