371.3

svn: r7350

collects/mzscheme/lang/info.ss

@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "MzScheme #lang"))

collects/mzscheme/lang/reader.ss

@@ -0,0 +1,26 @@
+(module reader mzscheme
+  (provide (rename *read read)
+           (rename *read-syntax read-syntax))
+
+  (define (*read in)
+    (wrap in read))
+
+  (define (*read-syntax src in)
+    (wrap in (lambda (in)
+               (read-syntax src in))))
+
+  (define (wrap port read)
+    (let ([body
+           (let loop ([a null])
+             (let ([v (read port)])
+               (if (eof-object? v)
+                   (reverse a)
+                   (loop (cons v a)))))])
+      (let* ([p-name (object-name port)]
+             [name (if (path? p-name)
+                       (let-values ([(base name dir?) (split-path p-name)])
+                         (string->symbol (path->string (path-replace-suffix name #""))))
+                       'page)]
+             [id 'doc])
+        `(module ,name mzscheme
+           . ,body)))))

collects/scribble/doc/lang/reader.ss

@@ -0,0 +1,4 @@
+(module reader mzscheme
+  (require (prefix doc: (lib "docreader.ss" "scribble")))
+  (provide (rename doc:read read)
+           (rename doc:read-syntax read-syntax)))

collects/scribblings/reference/syntax.scrbl

@@ -1172,7 +1172,7 @@ Legal only in a @tech{module begin context}, and handled by the
 
 @section-index["modules" "imports"]
 
-@defform/subs[#:literals (only only-rename prefix all-except prefix-all-except rename lib file planet)
+@defform/subs[#:literals (only only-rename prefix except rename lib file planet)
               (require require-spec ...)
               ([require-spec module-path
                              (only require-spec id-maybe-renamed ...)

collects/scribblings/scribble/how-to.scrbl

@@ -1,4 +1,4 @@
-#reader(lib "docreader.ss" "scribble")
+#lang scribble/doc
 @require[(lib "manual.ss" "scribble")
          (lib "bnf.ss" "scribble")]
 @require["utils.ss"]
@@ -18,7 +18,7 @@ To document a collection or @|PLaneT| package:
 
  @item{Start @file{manual.scrbl} like this:
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))]
 
   @title{My Library}
@@ -125,7 +125,7 @@ means
 For more information on the syntax of @litchar["@"], see
 @secref["reader"].
 
-In a document that starts @tt{#reader(lib "docreader.ss" "scribble")},
+In a document that starts @tt{#lang scribble/doc},
 the top level is a text-mode sequence. The parsed sequence is further
 decoded to turn it into a hierarchy of sections and paragraphs. For
 example, a linear sequence of @scheme[section] declarations with
@@ -161,7 +161,7 @@ document. Such links require no information about where and how a
 binding is documented elsewhere:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big"))]
 
@@ -177,7 +177,7 @@ so it ignores the source formatting of the expression. The
 and it preserves the expression's formatting from the document source.
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big"))]
 
@@ -208,7 +208,7 @@ hyperlink with text other than the section title.
 The following example illustrates section hyperlinks:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big"))]
 
@@ -248,7 +248,7 @@ following example links to a section in the PLT Scheme reference
 manual:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big"))
          (define ref-src
@@ -281,7 +281,7 @@ of @file{helper.ss}. Then use @scheme[defproc] to document the
 procedure:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big")
                             "helper.ss")]
@@ -349,7 +349,7 @@ from the previous section, then @file{helper.ss} must be imported both
 via @scheme[require-for-label] and @scheme[require]:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble")
                   (lib "eval.ss" "scribble")  ; <--- added
                   "helper.ss")                ; <--- added
@@ -383,7 +383,7 @@ as a sub-part of the enclosing part.
 In @file{manual.scrbl}:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))]
 
   @title{My Library}
@@ -396,7 +396,7 @@ EOS
 In @file{cows.scrbl}:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))]
 
   @title{Cows}
@@ -408,7 +408,7 @@ EOS
 In @file{aardvarks.scrbl}:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))
          (require-for-label (lib "lang.ss" "big")
                             "helper.ss")]
@@ -440,7 +440,7 @@ sub-sections.
 Revising @file{cows.scrbl} from the previous section:
 
 @verbatim[#<<EOS
-  #reader(lib "docreader.ss" "scribble")
+  #lang scribble/doc
   @begin[(require (lib "manual.ss" "scribble"))]
 
   @title[#:style '(toc)]{Cows}

collects/scribblings/scribble/scribble.scrbl

@@ -1,4 +1,4 @@
-#reader(lib "docreader.ss" "scribble")
+#lang scribble/doc
 @require[(lib "manual.ss" "scribble")]
 @require[(lib "bnf.ss" "scribble")]
 @require["utils.ss"]

collects/tests/mzscheme/optimize.ss

@@ -530,6 +530,16 @@
            '(let ([f (lambda (x) x)])
               (list f)))
 
+(test-comp '(procedure-arity-includes? integer? 1)
+           #t)
+
+(test-comp '(module m mzscheme
+              (define foo integer?)
+              (display (procedure-arity-includes? foo 1)))
+           '(module m mzscheme
+              (define foo integer?)
+              (display #t)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check bytecode verification of lifted functions
 

collects/tests/mzscheme/stx.ss

@@ -914,12 +914,15 @@
 ;; lifting expressions
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define prev-ctx #f)
+
 (define-syntax (@@foo stx)
   (syntax-case stx ()
     [(_ n)
      (if (zero? (syntax-e #'n))
 	 #'0
 	 (with-syntax ([m (sub1 (syntax-e #'n))])
+           (eval `(set! prev-ctx ',(syntax-local-lift-context)))
 	   (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
 
 (define lifted-output #f) 
@@ -931,6 +934,7 @@
        #'(list lifted-output id))]))
 
 (test 2 '@@foo (@@foo 2))
+(test #t values prev-ctx)
 (test 2 eval (expand-once #'(@@foo 2)))
 (test 2 eval (expand #'(@@foo 2)))
 (test 2 eval (expand-to-top-form #'(@@foo 2)))
@@ -990,6 +994,8 @@
 (require @@p)
 (test 10 '@@goo (@@goo))
 
+(set! prev-ctx #f)
+
 (module @@m mzscheme
   (define-syntax (@@foo stx)
     (syntax-case stx ()
@@ -997,6 +1003,11 @@
        (if (zero? (syntax-e #'n))
 	   #'0
 	   (with-syntax ([m (sub1 (syntax-e #'n))])
+             (let ([prev (eval 'prev-ctx)])
+               (if prev
+                   (unless (eq? prev (syntax-local-lift-context))
+                     (error "context mismatch!"))
+                   (eval `(set! prev-ctx ',(syntax-local-lift-context)))))
 	     (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
   (define @@local #f)
   (define (set-local v)
@@ -1006,18 +1017,24 @@
 
 (require @@m)
 (test 2 '@@local @@local)
+(test #t symbol? prev-ctx)
 
+(set! prev-ctx #f)
 (define-syntax (@@local-top stx)
   (syntax-case stx ()
     [(_ expr)
      (local-expand/capture-lifts #'expr
 				 (list (gensym))
-				 (list #'begin #'#%top))]))
+				 (list #'begin #'#%top)
+                                 #f
+                                 'the-key)]))
 
 (test 1 'let-foo (let ([x 5]) (@@foo 1)))
 (test 1 eval (expand #'(let ([x 5]) (@@foo 1))))
 (test 1 'local-foo (let ([x 5]) (@@local-top (@@foo 1))))
+(test 'the-key values prev-ctx)
 (test 1 eval (expand #'(let ([x 5]) (@@local-top (@@foo 1)))))
+(test 'the-key values prev-ctx)
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check interaction of macro-introduced/lifted names and

doc/release-notes/mzscheme/HISTORY

@@ -1,3 +1,7 @@
+Version 371.3
+Added syntax-local-lift-context
+Added #lang
+
 Version 371.2
 Added require-for-label, provide-for-syntax, provide-for-label,
  identifier-label-binding, module-label-identifier=?

src/mred/wxme/wx_media.cxx

@@ -2622,6 +2622,9 @@ wxchar *wxMediaEdit::GetText(long start, long end, Bool flatt, Bool forceCR, lon
   if (end < start)
     end = start;
 
+  if (end > len)
+    end = len;
+
   count = end - start;
 
   if (!flatt) {
@@ -2903,7 +2906,9 @@ void StandardWordbreak(wxMediaEdit *win, long *startp, long *endp,
       if (lstart < 0)
 	lstart = 0;
     }
-    lend = start + 1;
+    lend = win->LastPosition();
+    if (start + 1 < lend)
+      lend = start + 1;
 
     if (start - lstart > MAX_DIST_TRY)
       tstart = start - MAX_DIST_TRY;

src/mzscheme/src/env.c

@@ -86,6 +86,7 @@ static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_certify(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_expr(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 *make_introducer(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
@@ -582,6 +583,11 @@ static void make_init_env(void)
 						      "syntax-local-lift-expression",
 						      1, 1), 
 			     env);
+  scheme_add_global_constant("syntax-local-lift-context", 
+			     scheme_make_prim_w_arity(local_lift_context, 
+						      "syntax-local-lift-context",
+						      0, 0), 
+			     env);
 
   scheme_add_global_constant("syntax-local-lift-module-end-declaration", 
 			     scheme_make_prim_w_arity(local_lift_end_statement, 
@@ -1248,7 +1254,8 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
   frame->skip_table = NULL;
 }
 
-void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts)
+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_Lift_Capture_Proc *pp;
   Scheme_Object *vec;
@@ -1256,11 +1263,12 @@ 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(4, NULL);
+  vec = scheme_make_vector(5, NULL);
   SCHEME_VEC_ELS(vec)[0] = scheme_null;
   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
   SCHEME_VEC_ELS(vec)[2] = data;
   SCHEME_VEC_ELS(vec)[3] = end_stmts;
+  SCHEME_VEC_ELS(vec)[4] = context_key;
 
   COMPILE_DATA(env)->lifts = vec;
 }
@@ -4166,6 +4174,27 @@ local_lift_expr(int argc, Scheme_Object *argv[])
   return id;
 }
 
+static Scheme_Object *
+local_lift_context(int argc, Scheme_Object *argv[])
+{
+  Scheme_Comp_Env *env;
+
+  env = scheme_current_thread->current_local_env;
+
+  if (!env)
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
+		     "syntax-local-lift-context: not currently transforming");
+
+  while (env && !COMPILE_DATA(env)->lifts) {
+    env = env->next;
+  }
+
+  if (!env)
+    return scheme_false;
+  
+  return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4];
+}
+
 static Scheme_Object *
 local_lift_end_statement(int argc, Scheme_Object *argv[])
 {

src/mzscheme/src/eval.c

@@ -402,7 +402,7 @@ scheme_init_eval (Scheme_Env *env)
   scheme_add_global_constant("local-expand/capture-lifts", 
 			     scheme_make_prim_w_arity(local_expand_catch_lifts, 
 						      "local-expand/capture-lifts",
-						      3, 4), 
+						      3, 5), 
 			     env);
   scheme_add_global_constant("local-transformer-expand", 
 			     scheme_make_prim_w_arity(local_transformer_expand, 
@@ -412,7 +412,7 @@ scheme_init_eval (Scheme_Env *env)
   scheme_add_global_constant("local-transformer-expand/capture-lifts", 
 			     scheme_make_prim_w_arity(local_transformer_expand_catch_lifts, 
 						      "local-transformer-expand/capture-lifts",
-						      3, 4), 
+						      3, 5), 
 			     env);
   scheme_add_global_constant("expand-once", 
 			     scheme_make_prim_w_arity(expand_once, 
@@ -3772,7 +3772,7 @@ static void *compile_k(void)
 	 find one, break it up to eval first expression
 	 before the rest. */
       while (1) {
-	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
+	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_true);
 	form = scheme_check_immediate_macro(form, 
 					    cenv, &rec, 0,
 					    0, &gval, NULL, NULL);
@@ -3809,7 +3809,7 @@ static void *compile_k(void)
       Scheme_Object *l, *prev_o = NULL;
 
       while (1) {
-	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
+	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_true);
 
 	scheme_init_compile_recs(&rec, 0, &rec2, 1);
 
@@ -4843,7 +4843,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
 				Scheme_Expand_Info *rec, int drec)
 {
   Scheme_Expand_Info recs[2];
-  Scheme_Object *l, *orig_form = form;
+  Scheme_Object *l, *orig_form = form, *context_key;
   Scheme_Comp_Env *inserted, **ip;
 
   /* This function only works when `env' has no lexical bindings,
@@ -4897,7 +4897,9 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
   ip = MALLOC_N(Scheme_Comp_Env *, 1);
   *ip = inserted;
 
-  scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false);
+  context_key = scheme_generate_lifts_key();
+  
+  scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key);
 
   if (rec[drec].comp) {
     scheme_init_compile_recs(rec, drec, recs, 2);
@@ -7443,22 +7445,23 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
 static void *expand_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
-  Scheme_Object *obj, *certs, *observer;
+  Scheme_Object *obj, *certs, *observer, *catch_lifts_key;
   Scheme_Comp_Env *env;
   Scheme_Expand_Info erec1;
-  int depth, rename, just_to_top, catch_lifts;
+  int depth, rename, just_to_top;
 
   obj = (Scheme_Object *)p->ku.k.p1;
   env = (Scheme_Comp_Env *)p->ku.k.p2;
   depth = p->ku.k.i1;
   rename = p->ku.k.i2;
   just_to_top = p->ku.k.i3;
-  catch_lifts = p->ku.k.i4;
+  catch_lifts_key = p->ku.k.p4;
   certs = (Scheme_Object *)p->ku.k.p3;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
+  p->ku.k.p4 = NULL;
 
   if (!SCHEME_STXP(obj))
     obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
@@ -7479,8 +7482,8 @@ static void *expand_k(void)
     erec1.certs = certs;
     erec1.observer = observer;
 
-    if (catch_lifts)
+    if (catch_lifts_key)
-      scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false);
+      scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
   
     if (just_to_top) {
       Scheme_Object *gval;
@@ -7488,7 +7491,7 @@ static void *expand_k(void)
     } else
       obj = scheme_expand_expr(obj, env, &erec1, 0);
 
-    if (catch_lifts) {
+    if (catch_lifts_key) {
       Scheme_Object *l;
       l = scheme_frame_get_lifts(env);
       if (SCHEME_PAIRP(l)) {
@@ -7514,7 +7517,7 @@ static void *expand_k(void)
 
 static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env, 
 			      int depth, int rename, int just_to_top, 
-			      int catch_lifts, int eb,
+			      Scheme_Object *catch_lifts_key, int eb,
 			      Scheme_Object *certs)
 {
   Scheme_Thread *p = scheme_current_thread;
@@ -7524,7 +7527,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
   p->ku.k.i1 = depth;
   p->ku.k.i2 = rename;
   p->ku.k.i3 = just_to_top;
-  p->ku.k.i4 = catch_lifts;
+  p->ku.k.p4 = catch_lifts_key;
   p->ku.k.p3 = certs;
 
   return (Scheme_Object *)scheme_top_level_do(expand_k, eb);
@@ -7533,7 +7536,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
 Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env)
 {
   return _expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
-		 -1, 1, 0, 1, -1, NULL);
+		 -1, 1, 0, scheme_true, -1, NULL);
 }
 
 Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj)
@@ -7701,7 +7704,8 @@ static Scheme_Object *expand(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), -1, 1, 0, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 -1, 1, 0, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
@@ -7712,8 +7716,9 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
     scheme_wrong_type("expand-syntax", "syntax", 0, argc, argv);
 
   env = scheme_get_env(NULL);
-
+  
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), -1, -1, 0, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 -1, -1, 0, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, 
@@ -7740,6 +7745,14 @@ Scheme_Object *scheme_get_stop_expander(void)
   return stop_expander;
 }
 
+Scheme_Object *scheme_generate_lifts_key(void)
+{
+  static int cnt = 0;
+  char buf[20];
+  sprintf(buf, "lifts%d", cnt++);
+  return scheme_make_symbol(buf); /* uninterned */
+}
+
 Scheme_Object *
 scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env)
 {
@@ -7763,7 +7776,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
   int cnt, pos, kind;
   int bad_sub_env = 0;
-  Scheme_Object *observer;
+  Scheme_Object *observer, *catch_lifts_key = NULL;
 
   env = scheme_current_thread->current_local_env;
   orig_env = env;
@@ -7806,8 +7819,16 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
 	env = stx_env;
       }
     }
+
+    if (argc > 4) {
+      /* catch_lifts */
+      catch_lifts_key = argv[4];
+    }
   }
 
+  if (catch_lifts && !catch_lifts_key)
+    catch_lifts_key = scheme_generate_lifts_key();
+
   /* For each given stop-point identifier, shadow any potential syntax
      in the environment with an identity-expanding syntax expander. */
 
@@ -7911,7 +7932,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   } else {
     /* Expand the expression. depth = -2 means expand all the way, but
        preserve letrec-syntax. */
-    l = _expand(l, env, -2, 0, 0, catch_lifts, 0, scheme_current_thread->current_local_certs);
+    l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs);
   }
 
   SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
@@ -7991,7 +8012,8 @@ expand_once(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, 1, 0, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 1, 1, 0, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *
@@ -8004,7 +8026,8 @@ expand_stx_once(int argc, Scheme_Object **argv)
   
   env = scheme_get_env(NULL);
 
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 0, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 1, -1, 0, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *
@@ -8014,7 +8037,8 @@ expand_to_top_form(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, 1, 1, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 1, 1, 1, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *
@@ -8027,7 +8051,8 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv)
   
   env = scheme_get_env(NULL);
 
-  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 1, 1, 0, NULL);
+  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+                 1, -1, 1, scheme_true, 0, NULL);
 }
 
 static Scheme_Object *do_eval_string_all(const char *str, Scheme_Env *env, int cont, int w_prompt)

src/mzscheme/src/module.c

@@ -4300,6 +4300,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   Scheme_Object *exclude_hint = scheme_false, *lift_data;
   Scheme_Hash_Table *et_mn;
   Scheme_Object **exis;
+  Scheme_Object *lift_ctx;
   int exicount;
   char *exps;
   int all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1, dt_all_simple_renames = 1;
@@ -4464,6 +4465,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   form = scheme_add_rename(form, post_ex_dt_rn);
 
   maybe_has_lifts = 0;
+  lift_ctx = scheme_generate_lifts_key();
   
   /* Pass 1 */
 
@@ -4485,7 +4487,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
       p = (maybe_has_lifts 
            ? scheme_frame_get_end_statement_lifts(xenv) 
            : scheme_null);
-      scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p);
+      scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx);
       maybe_has_lifts = 1;
 
       {
@@ -4980,7 +4982,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
       l = (maybe_has_lifts 
            ? scheme_frame_get_end_statement_lifts(cenv) 
            : scheme_null);
-      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l);
+      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx);
       maybe_has_lifts = 1;
 
       if (kind == 2)

src/mzscheme/src/port.c

@@ -4146,6 +4146,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
 	nll = -1;
       }
     } else {
+      whence = SEEK_SET; /* not used */
       nll = -1;
     }
 

src/mzscheme/src/read.c

@@ -213,6 +213,11 @@ static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
 				  Scheme_Hash_Table **ht,
 				  Scheme_Object *indentation,
 				  ReadParams *params);
+static Scheme_Object *read_lang(Scheme_Object *port, Scheme_Object *stxsrc,
+                                long line, long col, long pos,
+                                Scheme_Hash_Table **ht,
+                                Scheme_Object *indentation,
+                                ReadParams *params);
 static Scheme_Object *read_compiled(Scheme_Object *port, Scheme_Object *stxsrc,
 				    long line, long col, long pos,
 				    Scheme_Hash_Table **ht,
@@ -1305,6 +1310,46 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	    }
 	  }
 	  break;
+        case 'l':
+          {
+            mzchar found[5];
+            int fl = 1;
+            found[0] = 'l';
+            ch = scheme_getc_special_ok(port);
+            found[fl] = ch;
+	    if (ch == 'a') {
+              ch = scheme_getc_special_ok(port);
+              found[fl++] = ch;
+              if (ch == 'n') {
+                ch = scheme_getc_special_ok(port);
+                found[fl++] = ch;
+                if (ch == 'g') {
+                  ch = scheme_getc_special_ok(port);
+                  found[fl++] = ch;
+                  if (ch == ' ') {
+                    /* #lang */
+                    Scheme_Object *v;
+                    if (!params->can_read_reader) {
+                      scheme_read_err(port, stxsrc, line, col, pos, 6, 0, indentation,
+                                      "read: #lang expressions not currently enabled");
+                      return NULL;
+                    }
+                    v = read_lang(port, stxsrc, line, col, pos, ht, indentation, params);
+                    if (!v) {
+                      if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
+                        return NULL;
+                      goto start_over;
+                    }
+                    return v;
+                  }
+                }
+              }
+            }
+            scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation,
+                            "read: bad input: `%u'",
+                            found, fl);
+          }
+          break;
 	case 'r':
 	case 'p':
 	  if (!params->honu_mode) {
@@ -5731,21 +5776,13 @@ static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv)
 			     1, NULL, NULL, 0);
 }
 
-/* "#reader" has been read */
+static Scheme_Object *do_reader(Scheme_Object *modpath,
-static Scheme_Object *read_reader(Scheme_Object *port,
+                                Scheme_Object *port,
-				  Scheme_Object *stxsrc, long line, long col, long pos,
+                                Scheme_Object *stxsrc, long line, long col, long pos,
-				  Scheme_Hash_Table **ht,
+                                Scheme_Hash_Table **ht,
-				  Scheme_Object *indentation, ReadParams *params)
+                                Scheme_Object *indentation, ReadParams *params)
 {
-  Scheme_Object *modpath, *name, *a[2], *proc, *v;
+  Scheme_Object *name, *a[2], *proc, *v;
-
-  modpath = scheme_read(port);
-
-  if (SCHEME_EOFP(modpath)) {
-    scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, 
-		    "read: expected a datum after #reader, found end-of-file");
-    return NULL;
-  }
 
   proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD);
 
@@ -5779,6 +5816,96 @@ static Scheme_Object *read_reader(Scheme_Object *port,
     return v;
 }
 
+/* "#reader" has been read */
+static Scheme_Object *read_reader(Scheme_Object *port,
+				  Scheme_Object *stxsrc, long line, long col, long pos,
+				  Scheme_Hash_Table **ht,
+				  Scheme_Object *indentation, ReadParams *params)
+{
+  Scheme_Object *modpath;
+
+  modpath = scheme_read(port);
+
+  if (SCHEME_EOFP(modpath)) {
+    scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, 
+		    "read: expected a datum after #reader, found end-of-file");
+    return NULL;
+  }
+
+  return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params);
+}
+
+/* "#lang" has been read */
+static Scheme_Object *read_lang(Scheme_Object *port,
+                                Scheme_Object *stxsrc, long line, long col, long pos,
+                                Scheme_Hash_Table **ht,
+                                Scheme_Object *indentation, ReadParams *params)
+{
+  int size, len;
+  mzchar *buf, *naya, ch;
+  Scheme_Object *modpath;
+
+  size = 32;
+  buf = MALLOC_N_ATOMIC(mzchar, size);
+  len = 0;
+
+  while (1) {
+    ch = scheme_getc_special_ok(port);
+    if (ch == EOF) {
+      break;
+    } else if (ch == SCHEME_SPECIAL) {
+      scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
+                      "read: found non-character while reading `#lang'");
+    } else if (scheme_isspace(ch)) {
+      break;
+    } else {
+      if ((ch < 128)
+          && (scheme_isalpha(ch)
+              || scheme_isdigit(ch)
+              || (ch == '-')
+              || (ch == '+')
+              || (ch == '_')
+              || (ch == '/'))) {
+        if (len + 1 >= size) {
+          size *= 2;
+          naya = MALLOC_N_ATOMIC(mzchar, size);
+          memcpy(naya, buf, len);
+          buf = naya;
+        }
+        buf[len++] = ch;
+      } else {
+        scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
+                        "read: expected alphanumberic, `-', `+', `_', or `/' for `#lang', found %c",
+                        ch);
+        return NULL;
+      }
+    }
+  }
+
+  if (!len) {
+    scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
+                    "read: a non-empty sequence of alphanumberic, `-', `+', `_', or `/' after `#lang '");
+    return NULL;
+  }
+  if (buf[0] == '/') {
+    scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
+                    "read: a name that does not start `/' after `#lang'");
+    return NULL;
+  }
+  if (buf[len - 1] == '/') {
+    scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, 
+                    "read: a name that does not end `/' after `#lang'");
+    return NULL;
+  }
+
+  modpath = scheme_make_pair(scheme_intern_symbol("lib"),
+                             scheme_make_pair(scheme_make_utf8_string("lang/reader.ss"),
+                                              scheme_make_pair(scheme_make_sized_char_string(buf, len, 0),
+                                                               scheme_null)));
+
+  return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params);
+}
+
 static int is_placeholder(Scheme_Object *a, Scheme_Object *src)
 {
   if (src && SCHEME_STXP(a))

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 910
+#define EXPECTED_PRIM_COUNT 911
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schpriv.h

@@ -1892,9 +1892,11 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
 Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
 
 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);
+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 *scheme_frame_get_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
+Scheme_Object *scheme_generate_lifts_key(void);
 
 void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
 void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 371
-#define MZSCHEME_VERSION_MINOR 2
+#define MZSCHEME_VERSION_MINOR 3
 
-#define MZSCHEME_VERSION "371.2" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "371.3" _MZ_SPECIAL_TAG