add syntax-local-lift-module

pkgs/base/info.rkt

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

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

@@ -348,7 +348,12 @@ forms, and the expansion of @racket[stx] is the last expression in the
 @racket[begin]. The @racket[lift-ctx] value is reported by
 @racket[syntax-local-lift-context] during local expansion. The lifted
 expressions are not expanded, but instead left as provided in the
-@racket[begin] form.}
+@racket[begin] form.
+
+If @racket[context-v] is @racket['top-level] or @racket['module], then
+@racket[module] forms can appear in the result as added via
+@racket[syntax-local-lift-module]. If @racket[context-v] is
+@racket['module], then @racket[module*] forms can appear, too.}
 
 
 @defproc[(local-transformer-expand/capture-lifts [stx any/c]
@@ -578,6 +583,28 @@ for caching lift information to avoid redundant lifts.
 @transform-time[]}
 
 
+@defproc[(syntax-local-lift-module [stx syntax?])
+         void?]{
+
+Cooperates with the @racket[module] form or top-level expansion to add
+@racket[stx] as a module declaration in the enclosing module or top-level.
+The @racket[stx] form must start with @racket[module] or @racket[module*],
+where the latter is only allowed within the expansion of a module.
+
+The module is not immediately declared when
+@racket[syntax-local-lift-module] returns. Instead, the module
+declaration is recorded for processing when expansion returns to the
+enclosing module body or top-level sequence.
+
+@transform-time[] If the current expression being transformed is not
+within a @racket[module] form or within a top-level expansion, then
+the @exnraise[exn:fail:contract]. If @racket[stx] form does start with
+@racket[module] or @racket[module*], or if it starts with @racket[module*]
+in a top-level context, the @exnraise[exn:fail:contract].
+
+@history[#:added "6.2.900.10"]}
+
+
 @defproc[(syntax-local-lift-module-end-declaration [stx syntax?])
          void?]{
 

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

@@ -1019,6 +1019,66 @@
     (eval `(require 'm)))
   (test "2\n" get-output-string o))
 
+(parameterize ([current-namespace (make-base-namespace)])
+  (eval `(module m racket/base
+           (require (for-syntax racket/base))
+           (define x 10)
+           (let-syntax ([x (syntax-local-lift-module #'(module m racket/base 
+                                                         (provide x)
+                                                         (define x 10)))])
+             (void))))
+  (test 10 eval `(dynamic-require '(submod 'm m) 'x)))
+
+;; ----------------------------------------
+;; Check module lifting in a top-level context
+
+(define-syntax (do-lift-example-1 stx)
+  (syntax-local-lift-module
+   #'(module lift-example-1 racket/base
+       (provide x)
+       (define x 10)))
+  #'(void))
+(do-lift-example-1)
+(test 10 dynamic-require ''lift-example-1 'x)
+
+(test '(begin
+        (module lift-example-1 racket/base
+          (provide x)
+          (define x 10))
+        (#%app void))
+      'local-expand/capture-lifts
+      (let-syntax ([quote-local-expand
+                    (lambda (stx)
+                      (syntax-case stx ()
+                        [(_ e)
+                         #`(quote #,(local-expand/capture-lifts #'e 'top-level null))]))])
+        (quote-local-expand (do-lift-example-1))))
+
+(define-syntax (do-lift-example-1* stx)
+  (syntax-local-lift-module
+   #'(module* lift-example-1* racket/base
+       (provide x)
+       (define x 10)))
+  #'(void))
+
+(err/rt-test (expand '(do-lift-example-1*))
+             (lambda (exn)
+               (and (exn:fail:contract? exn)
+                    (regexp-match #rx"cannot lift.*module[*]" (exn-message exn)))))
+
+(test '(begin
+        (module* lift-example-1* racket/base
+          (provide x)
+          (define x 10))
+        (#%app void))
+      'local-expand/capture-lifts
+      (let-syntax ([quote-local-expand
+                    (lambda (stx)
+                      (syntax-case stx ()
+                        [(_ e)
+                         #`(quote #,(local-expand/capture-lifts #'e 'module null))]))])
+        (quote-local-expand (do-lift-example-1*))))
+
 ;; ----------------------------------------
 ;; Lifting should not introduce `#%top` around
 ;; the reference to the lifted identifier:

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

@@ -1430,6 +1430,54 @@ case of module-leve bindings; it doesn't cover local bindings.
 
 (test #t syntax? (expand-syntax (expand lifted-require-of-submodule)))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check module lifting
+
+(module module-lift-example-1 racket/base
+  (require (for-syntax racket/base))
+  (define-syntax (m stx)
+    (syntax-local-lift-module
+     #'(module m racket/base
+         (provide x)
+         (define x 10)))
+    #'(begin
+        (require 'm)
+        (define out x)
+        (provide out)))
+  (m))
+
+(test 10 dynamic-require ''module-lift-example-1 'out)
+
+(module module-lift-example-2 racket/base
+  (require (for-syntax racket/base))
+  (define-syntax (m stx)
+    (syntax-local-lift-module #'(module* sub #f
+                                  (provide s)
+                                  (define s (add1 a))))
+    #'(void))
+  (m)
+  (define a 1))
+
+(test 2 dynamic-require '(submod 'module-lift-example-2 sub) 's)
+
+
+(module module-lift-example-3 racket/base
+  (require (for-syntax racket/base))
+  (define-syntax (m stx)
+    (syntax-local-lift-module #'(module m racket/base
+                                  (provide x)
+                                  (define x 11)))
+    (syntax-local-lift-module-end-declaration
+     #'(let ()
+         (local-require (submod "." m))
+         (set! out x)))
+    #'(void))
+  (define out -10)
+  (m)
+  (provide out))
+
+(test 11 dynamic-require ''module-lift-example-3 'out)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check addition of 'disappeared-use by `provide`
 

racket/src/racket/src/compenv.c

@@ -398,7 +398,8 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
 
 void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, 
                                  Scheme_Object *end_stmts, Scheme_Object *context_key, 
-                                 Scheme_Object *requires, Scheme_Object *provides)
+                                 Scheme_Object *requires, Scheme_Object *provides,
+                                 Scheme_Object *module_lifts)
 {
   Scheme_Lift_Capture_Proc *pp;
   Scheme_Object *vec;
@@ -406,7 +407,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
   pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
   *pp = cp;
 
-  vec = scheme_make_vector(8, NULL);
+  vec = scheme_make_vector(9, NULL);
   SCHEME_VEC_ELS(vec)[0] = scheme_null;
   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
   SCHEME_VEC_ELS(vec)[2] = data;
@@ -415,6 +416,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
   SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
   SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
   SCHEME_VEC_ELS(vec)[7] = provides;
+  SCHEME_VEC_ELS(vec)[8] = module_lifts; /* #f => disallowed; #t or (void) => add to slot 0; (void) => `module*` allowed */
 
   env->lifts = vec;
 }
@@ -433,7 +435,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
 
     p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
 
-    vec = scheme_make_vector(8, NULL);
+    vec = scheme_make_vector(9, NULL);
     SCHEME_VEC_ELS(vec)[0] = scheme_false;
     SCHEME_VEC_ELS(vec)[1] = scheme_void;
     SCHEME_VEC_ELS(vec)[2] = scheme_void;
@@ -442,6 +444,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
     SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
     SCHEME_VEC_ELS(vec)[6] = scheme_null;
     SCHEME_VEC_ELS(vec)[7] = scheme_false;
+    SCHEME_VEC_ELS(vec)[8] = scheme_false;
 
     env->lifts = vec;
   }
@@ -457,6 +460,11 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
   return SCHEME_VEC_ELS(env->lifts)[3];
 }
 
+Scheme_Object *scheme_frame_get_modules(Scheme_Comp_Env *env)
+{
+  return SCHEME_VEC_ELS(env->lifts)[8];
+}
+
 Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
 {
   return SCHEME_VEC_ELS(env->lifts)[6];
@@ -2087,6 +2095,18 @@ Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env)
   return env;
 }
 
+static Scheme_Comp_Env *get_lift_env_for_module(Scheme_Comp_Env *env)
+{
+  while (env) {
+    if ((env->lifts)
+        && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[8]))
+      break;
+    env = env->next;
+  }
+
+  return env;
+}
+
 Scheme_Object *
 scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env)
 {
@@ -2113,6 +2133,63 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope,
   return scheme_void;
 }
 
+Scheme_Object *
+scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env)
+{
+  Scheme_Object *pr;
+  Scheme_Object *orig_expr;
+  int star_ok, slot;
+
+  env = get_lift_env_for_module(env);
+
+  if (!env)
+    scheme_contract_error("syntax-local-lift-module",
+                          "not currently transforming within a module declaration or top level",
+                          NULL);
+  
+  if (local_scope)
+    expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv));
+  orig_expr = expr;
+
+  star_ok = !SAME_OBJ(scheme_true, SCHEME_VEC_ELS(env->lifts)[8]);
+    
+  if (SCHEME_STX_PAIRP(expr)) {
+    pr = SCHEME_STX_CAR(expr);
+    if (scheme_stx_free_eq3(pr, scheme_module_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) {
+      /* ok */
+    } else if (scheme_stx_free_eq3(pr, scheme_modulestar_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) {
+      if (!star_ok)
+        scheme_contract_error("syntax-local-lift-module",
+                              "cannot lift `module*' to a top-level context",
+                              "syntax", 1, expr,
+                              NULL);
+      /* otherwise, ok */
+    } else
+      pr = NULL;
+  } else
+    pr = NULL;
+
+  if (!pr)
+    scheme_contract_error("syntax-local-lift-module",
+                          "not a module declaration",
+                          "syntax", 1, expr,
+                          NULL);
+
+  /* Add to separate list or mingle with definitions? */
+  if (SCHEME_NULLP(SCHEME_VEC_ELS(env->lifts)[8])
+      || SCHEME_PAIRP(SCHEME_VEC_ELS(env->lifts)[8]))
+    slot = 8;
+  else
+    slot = 0;
+  
+  pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[slot]);
+  SCHEME_VEC_ELS(env->lifts)[slot] = pr;
+
+  SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr);
+  
+  return scheme_void;
+}
+
 Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form,
                                          intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *cenv)
 {

racket/src/racket/src/compile.c

@@ -3508,7 +3508,8 @@ 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_top_level_lifts_key(env), scheme_null, scheme_false);
+                                scheme_false, scheme_top_level_lifts_key(env), scheme_null,
+                                scheme_false, scheme_true);
 
     if (rec[drec].comp) {
       scheme_init_compile_recs(rec, drec, recs, 1);
@@ -5589,7 +5590,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
   context_key = scheme_generate_lifts_key();
   
   scheme_frame_captures_lifts(inserted, scheme_pair_lifted, (Scheme_Object *)ip, scheme_false, 
-                              context_key, NULL, scheme_false);
+                              context_key, NULL, scheme_false, scheme_false);
 
   if (rec[drec].comp) {
     scheme_init_compile_recs(rec, drec, recs, 2);

racket/src/racket/src/env.c

@@ -114,6 +114,7 @@ static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
+static Scheme_Object *local_lift_module(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
@@ -804,6 +805,7 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-lift-module", local_lift_module, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env);
 
@@ -2772,6 +2774,25 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
   return scheme_local_lift_end_statement(expr, local_scope, env);
 }
 
+static Scheme_Object *
+local_lift_module(int argc, Scheme_Object *argv[])
+{
+  Scheme_Comp_Env *env;
+  Scheme_Object *local_scope, *expr;
+
+  expr = argv[0];
+  if (!SCHEME_STXP(expr))
+    scheme_wrong_contract("syntax-local-lift-module", "syntax?", 0, argc, argv);
+
+  env = scheme_current_thread->current_local_env;
+  local_scope = scheme_current_thread->current_local_scope;
+
+  if (!env)
+    not_currently_transforming("syntax-local-lift-module");
+
+  return scheme_local_lift_module(expr, local_scope, env);
+}
+
 static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env;

racket/src/racket/src/eval.c

@@ -4148,7 +4148,9 @@ 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_top_level_lifts_key(cenv), scheme_null, scheme_false);
+                                    scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false,
+                                    /* lifted modules like definitions: */
+                                    scheme_true);
 	form = scheme_check_immediate_macro(form,
 					    cenv, &rec, 0,
 					    &gval,
@@ -4195,7 +4197,9 @@ static void *compile_k(void)
 
       while (1) {
 	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
-                                    scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
+                                    scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false,
+                                    /* lifted modules like definitions: */
+                                    scheme_true);
 
 	scheme_init_compile_recs(&rec, 0, &rec2, 1);
 
@@ -4650,7 +4654,13 @@ static void *expand_k(void)
                                   data, 
                                   scheme_false, catch_lifts_key, 
                                   (!as_local && catch_lifts_key) ? scheme_null : NULL,
-                                  scheme_false);
+                                  scheme_false,
+                                  /* lifted modules like definitions: */
+                                  ((env->flags & SCHEME_TOPLEVEL_FRAME)
+                                   ? scheme_true /* lifted `module` like definition */
+                                   : ((env->flags & SCHEME_MODULE_FRAME)
+                                      ? scheme_void /* lifted `module[*]` like definition */
+                                      : scheme_false)));
     }
 
     if (just_to_top) {
@@ -5268,7 +5278,12 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
                                   data,
                                   scheme_top_level_lifts_key(env),
                                   catch_lifts_key, NULL,
-                                  scheme_false);
+                                  scheme_false,
+                                  ((kind & SCHEME_TOPLEVEL_FRAME)
+                                   ? scheme_true /* lifted `module` like definition */
+                                   : ((kind & SCHEME_MODULE_FRAME)
+                                      ? scheme_void /* lifted `module[*]` like definition */
+                                      : scheme_false))); /* no lifted modules */
     }
 
     memset(drec, 0, sizeof(drec));

racket/src/racket/src/module.c

@@ -8563,6 +8563,79 @@ static Scheme_Object *revert_use_site_scopes_via_context(Scheme_Object *o, Schem
                                                    SCHEME_STX_REMOVE);
 }
 
+static Scheme_Object *handle_submodule_form(const char *who,
+                                            Scheme_Object *e,
+                                            Scheme_Comp_Env *env, int phase,
+                                            Scheme_Object *rn_set, Scheme_Object *observer,
+                                            Module_Begin_Expand_State *bxs,
+                                            Scheme_Compile_Expand_Info *rec, int drec,
+                                            Scheme_Compile_Expand_Info *erec, int derec,
+                                            int *_kind)
+{
+  Scheme_Object *name = NULL, *fst, *p;
+  int is_star;
+
+  fst = SCHEME_STX_CAR(e);
+
+  is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase);
+
+  e = revert_use_site_scopes_via_context(e, rn_set, phase);
+
+  SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
+  if (is_star) {
+    SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer);
+  } else {
+    SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer);
+  }
+
+  if (SCHEME_STX_PAIRP(e)) {
+    p = SCHEME_STX_CDR(e);
+    if (SCHEME_STX_PAIRP(p)) {
+      name = SCHEME_STX_CAR(p);
+      p = SCHEME_STX_CDR(p);
+      if (!SCHEME_STX_SYMBOLP(name)
+          || !SCHEME_STX_PAIRP(p)) {
+        name = NULL;
+      }
+    }
+  }
+  if (!name) {
+    scheme_wrong_syntax(who, NULL, e, NULL);
+  }
+
+  if (!bxs->submodule_names) {
+    Scheme_Hash_Table *smn;
+    smn = scheme_make_hash_table(SCHEME_hash_ptr);
+    bxs->submodule_names = smn;
+  }
+  if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) {
+    scheme_wrong_syntax(who, name, fst, "duplicate submodule definition");
+  }
+  scheme_hash_set(bxs->submodule_names,
+                  SCHEME_STX_VAL(name),
+                  is_star ? scheme_void : scheme_true);
+
+  if (!is_star) {
+    p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env, 
+                          scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0, 
+                          bxs, !!erec);
+    if (erec)
+      e = SCHEME_CAR(p);
+    else
+      e = NULL;
+    *_kind = DONE_MODFORM_KIND;
+  } else {
+    p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), 
+                         bxs->saved_submodules);
+    bxs->saved_submodules = p;
+    *_kind = MODULE_MODFORM_KIND;
+  }
+
+  SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
+
+  return e;
+}
+
 static Scheme_Object *do_module_begin_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
@@ -8784,7 +8857,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
                 ? scheme_frame_get_provide_lifts(xenv)
                 : scheme_null);
       scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), 
-                                  p, lift_ctx, req_data, prev_p);
+                                  p, lift_ctx, req_data, prev_p, scheme_void);
       maybe_has_lifts = 1;
 
       {
@@ -8981,7 +9054,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
                                      0);
           if (!for_stx)
             scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, 
-                                        req_data, scheme_false);
+                                        req_data, scheme_false, scheme_false);
 
 	  oenv = env;
 	  
@@ -9220,63 +9293,14 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
                    || scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase)) {
 	  /************ module[*] *************/
           /* check outer syntax & name, then expand pre-module or remember for post-module pass */
-          Scheme_Object *name = NULL;
+          int k;
-          int is_star;
+          e = handle_submodule_form(who,
-
+                                    e, env, phase,
-          is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase);
+                                    rn_set, observer,
-
+                                    bxs,
-          e = revert_use_site_scopes_via_context(e, rn_set, phase);
+                                    rec, drec, erec, derec,
-
+                                    &k);
-          SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
+          kind = k;
-          if (is_star) {
-            SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer);
-          } else {
-            SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer);
-          }
-
-          if (SCHEME_STX_PAIRP(e)) {
-            p = SCHEME_STX_CDR(e);
-            if (SCHEME_STX_PAIRP(p)) {
-              name = SCHEME_STX_CAR(p);
-              p = SCHEME_STX_CDR(p);
-              if (!SCHEME_STX_SYMBOLP(name)
-                  || !SCHEME_STX_PAIRP(p)) {
-                name = NULL;
-              }
-            }
-          }
-          if (!name) {
-            scheme_wrong_syntax(who, NULL, e, NULL);
-          }
-
-          if (!bxs->submodule_names) {
-            Scheme_Hash_Table *smn;
-            smn = scheme_make_hash_table(SCHEME_hash_ptr);
-            bxs->submodule_names = smn;
-          }
-          if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) {
-            scheme_wrong_syntax(who, name, fst, "duplicate submodule definition");
-          }
-          scheme_hash_set(bxs->submodule_names, 
-                          SCHEME_STX_VAL(name), 
-                          is_star ? scheme_void : scheme_true);
-
-          if (!is_star) {
-            p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env, 
-                                  scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0, 
-                                  bxs, !!erec);
-            if (erec)
-              e = SCHEME_CAR(p);
-            else
-              e = NULL;
-            kind = DONE_MODFORM_KIND;
-          } else {
-            p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), 
-                                 bxs->saved_submodules);
-            bxs->saved_submodules = p;
-            kind = MODULE_MODFORM_KIND;
-          }
-          SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
 	} else {
 	  kind = EXPR_MODFORM_KIND;
           non_phaseless |= NON_PHASELESS_FORM;
@@ -9400,7 +9424,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
       ll = (maybe_has_lifts 
             ? scheme_frame_get_provide_lifts(cenv) 
             : scheme_null);
-      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll);
+      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll, scheme_void);
       maybe_has_lifts = 1;
 
       if (kind == DEFN_MODFORM_KIND)
@@ -9436,6 +9460,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
 	p = SCHEME_CDR(p);
       } else {
 	/* Lifts - insert them and try again */
+        Scheme_Object *fst;
         *bxs->all_simple_bindings = 0;
         SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
         if (erec) {
@@ -9447,7 +9472,29 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
           e = scheme_make_pair(e, scheme_make_integer(DONE_MODFORM_KIND)); /* don't re-compile/-expand */
 	SCHEME_CAR(p) = e;
 	for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
-	  e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(DEFN_MODFORM_KIND));
+          e = SCHEME_CAR(ll);
+          if (SCHEME_STX_PAIRP(SCHEME_CAR(e)))
+            fst = SCHEME_STX_CAR(SCHEME_CAR(e));
+          else
+            fst = NULL;
+          if (fst
+              && (scheme_stx_free_eq3(fst, scheme_module_stx, scheme_make_integer(phase), scheme_make_integer(0))
+                  || scheme_stx_free_eq3(fst, scheme_modulestar_stx, scheme_make_integer(phase), scheme_make_integer(0)))) {
+            /* a `module` or `module*` form; handle as in first pass */
+            int k;
+            e = handle_submodule_form(who,
+                                      e, env, phase,
+                                      rn_set, observer,
+                                      bxs,
+                                      rec, drec, erec, derec,
+                                      &k);
+            if (e)
+              e = scheme_make_pair(e, scheme_make_integer(k));
+            else
+              e = scheme_make_pair(scheme_void, DONE_MODFORM_KIND);
+          } else {
+            e = scheme_make_pair(e, scheme_make_integer(DEFN_MODFORM_KIND));
+          }
 	  SCHEME_CAR(ll) = e;
 	}
 	p = scheme_append(l, p);

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1133
+#define EXPECTED_PRIM_COUNT 1134
 #define EXPECTED_UNSAFE_COUNT 106
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -2835,6 +2835,8 @@ Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos,
 Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env);
 Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, 
                                                Scheme_Comp_Env *env);
+Scheme_Object *scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, 
+                                        Scheme_Comp_Env *env);
 Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form,
                                          intptr_t phase, Scheme_Object *local_scope, 
                                          Scheme_Comp_Env *env);
@@ -2890,10 +2892,12 @@ Scheme_Object *scheme_extract_foreign(Scheme_Object *o);
 typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
 void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, 
                                  Scheme_Object *end_stmts, Scheme_Object *context_key, 
-                                 Scheme_Object *require_lifts, Scheme_Object *provide_lifts);
+                                 Scheme_Object *require_lifts, Scheme_Object *provide_lifts,
+                                 Scheme_Object *module_lifts);
 void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
+Scheme_Object *scheme_frame_get_end_modules(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);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.2.900.9"
+#define MZSCHEME_VERSION "6.2.900.10"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 900
-#define MZSCHEME_VERSION_W 9
+#define MZSCHEME_VERSION_W 10
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)