internal-definition contexts allow expressions mixed with definitions

while the new `#%stratified-body' form provides access to the old
 convention

collects/rnrs/base-6.rkt

@@ -38,7 +38,7 @@
  ;; 11.4.6
  let let*
  (rename-out [r6rs:letrec letrec]
-             [letrec letrec*]
+             [r6rs:letrec* letrec*]
              [r6rs:let-values let-values]
              [r6rs:let*-values let*-values])
  
@@ -458,7 +458,10 @@
 ;;   Need bindings like R5RS, but int-def body like Racket
 
 (define-syntax-rule (r6rs:letrec bindings . body)
-  (r5rs:letrec bindings (let () . body)))
+  (r5rs:letrec bindings (#%stratified-body . body)))
+
+(define-syntax-rule (r6rs:letrec* bindings . body)
+  (letrec bindings (#%stratified-body . body)))
 
 ;; ----------------------------------------
 ;; let[*]-values
@@ -508,7 +511,7 @@
                                              (values . #,ids)))])))
                               (syntax->list #'(formals ...))
                               (syntax->list #'(expr ...)))])
-            #'(dest:let-values bindings body0 body ...))]))]))
+            #'(dest:let-values bindings (#%stratified-body body0 body ...)))]))]))
 
 ;; ----------------------------------------
 ;; lambda & define
@@ -518,9 +521,9 @@
   (syntax-case stx ()
     [(_ (id ...) . body)
      (andmap identifier? (syntax->list #'(id ...)))
-     (syntax/loc stx (lambda (id ...) . body))]
+     (syntax/loc stx (lambda (id ...) (#%stratified-body . body)))]
     [(_ args . body)
-     (syntax/loc stx (r5rs:lambda args (let () . body)))]))
+     (syntax/loc stx (r5rs:lambda args (#%stratified-body . body)))]))
 
 (define-for-syntax (check-label id orig-stx def)
   ;; This test shouldn't be needed, and it interferes
@@ -543,7 +546,7 @@
     [(_ (name . args) . body)
      (check-label #'name
                   stx
-                  (syntax/loc stx (r5rs:define (name . args) (let () . body))))]
+                  (syntax/loc stx (r5rs:define (name . args) (#%stratified-body . body))))]
     [(_ . rest) #'(define . rest)]))
 
 ;; ----------------------------------------

collects/rnrs/control-6.rkt

@@ -23,12 +23,12 @@
                               (andmap identifier? (syntax->list #'(id ...))))
                          #`[formals 
                             (let ([rest (list->mlist rest)])
-                              body1 body ...)]]
+                              (#%stratified-body body1 body ...))]]
                         [rest
                          (identifier? #'rest)
                          #`[formals 
                             (let ([rest (list->mlist rest)])
-                              body1 body ...)]]
+                              (#%stratified-body body1 body ...))]]
                         [_
                          (raise-syntax-error
                           #f

collects/scribblings/guide/define.scrbl

@@ -198,9 +198,8 @@ When the grammar for a syntactic form specifies @racket[_body], then
 the corresponding form can be either a definition or an expression.
 A definition as a @racket[_body] is an @defterm{internal definition}.
 
-All internal definitions in a @racket[_body] sequence must appear
+Expressions and internal definitions in a @racket[_body] sequence can
-before any expression, and the last @racket[_body] must be an
+be mixed, as long as the last @racket[_body] is an expression.
-expression.
 
 For example, the syntax of @racket[lambda] is
 

collects/scribblings/reference/block.scrbl

@@ -6,14 +6,15 @@
 @(define ev (make-base-eval))
 @(ev '(require racket/block))
 
-@title[#:tag "block"]{Blocks}
+@title[#:tag "block"]{Blocks: @racket[block]}
 
 @note-lib-only[racket/block]
 
 @defform[(block defn-or-expr ...)]{
 
 Supports a mixture of expressions and mutually recursive definitions,
-as in a @scheme[module] body. 
+as in a @scheme[module] body. Unlike an @tech{internal-definition
+context}, the last @racket[defn-or-expr] need not be an expression.
 
 The result of the @scheme[block] form is the result
 of the last @scheme[defn-or-expr] if it is an expression,

collects/scribblings/reference/syntax-model.scrbl

@@ -614,12 +614,17 @@ recursively expands only until the form becomes one of the following:
  @item{A @racket[define-values] or @racket[define-syntaxes] form, for
        any form other than the last one: The definition form is not
        expanded further. Instead, the next form is expanded partially,
-       and so on. As soon as an expression form is found, the
+       and so on. The content of a @racket[begin] form is spliced into
-       accumulated definition forms are converted to a
+       the body-form sequence. After all forms are partially expanded,
+       the accumulated definition forms are converted to a
        @racket[letrec-values] (if no @racket[define-syntaxes] forms
        were found) or @racket[letrec-syntaxes+values] form, moving the
-       expression forms to the body to be expanded in expression
+       expression-form tail to the body to be expanded in expression
-       context.
+       context. An expression @racket[_expr] that appears before a
+       definition is converted to a @racket[letrec-values] clause
+       @racket[[() (begin _expr (values))]], so that the expression
+       can produce any number of values, and its evaluation order is
+       preserved relative to definitions.
 
        When a @racket[define-values] form is discovered, the lexical
        context of all syntax objects for the body sequence is

collects/scribblings/reference/syntax.scrbl

@@ -2428,5 +2428,18 @@ provides a hook to control interactive evaluation through
 @;------------------------------------------------------------------------
 @include-section["block.scrbl"]
 
+@;------------------------------------------------------------------------
+@section[#:tag "stratified-body"]{Internal-Definition Limiting: @racket[#%stratified-body]}
+
+@defform[(#%stratified-body defn-or-expr ...)]{
+
+Like @racket[(let () defn-or-expr ...)] for an
+@tech{internal-definition context} sequence, except that an expression
+is not allowed to precede a definition.
+
+The @racket[#%stratified-body] form is useful for implementing
+syntactic forms or languages that supply a more limited kind of
+@tech{internal-definition context}.}
+
 @close-eval[require-eval]
 @close-eval[meta-in-eval]

collects/tests/racket/macro.rktl

@@ -320,12 +320,14 @@
 		 (define goo 10)
 		 12))
 
-(syntax-test #'(let-syntax ([ohno (lambda (stx) #'(define z -10))])
+(test 128 apply (lambda ()
-		 (let ()
+                  (let-syntax ([ohno (lambda (stx) #'(define z -10))])
-		   (define ohno 128)
+                    (let ()
-		   ohno
+                      (define ohno 128)
-		   (define-syntax (goo stx) #'ohno)
+                      ohno
-		   (printf "~a\n" ohno))))
+                      (define-syntax (goo stx) #'ohno)
+                      ohno)))
+      null)
 
 (define-syntax (def-it stx)
   (syntax-case stx ()

collects/tests/racket/syntax.rktl

@@ -854,7 +854,8 @@
 
 (syntax-test #'(lambda () (define x 10) (begin)))
 (syntax-test #'(lambda () (define x 10) (begin) (begin)))
-(syntax-test #'(lambda () (define x 10) (begin) (begin x) (begin)))
+(syntax-test #'(lambda () (#%stratified-syntax (define x 10) (begin) (begin x) (begin))))
+(syntax-test #'(lambda () (#%stratified-syntax (define x 10) x (define y 12) y)))
 (syntax-test #'(lambda () (define-values (x) . 10) x))
 (syntax-test #'(lambda () (define-values (x) 10) (begin 1 . 2) x))
 (syntax-test #'(lambda () (begin (define-values (x) 10) . 2) x))
@@ -863,6 +864,11 @@
 (syntax-test #'(lambda () (define-values x 10) x))
 (syntax-test #'(lambda () (define-values (1) 10) x))
 
+(test '(10 12) apply (lambda () (define x 10) (random 3) (define y 12) (list x y)) null)
+(test 10 apply (lambda () (define x 10) (begin) (begin x) (begin)) null)
+
+(test '(11 18) apply (lambda () (define x 11) (values 1 2 3) (define y 18) (list x y)) null)
+
 (test 87 (lambda () (define x 87) (begin) (begin x)))
 
 (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))

src/racket/src/cstartup.inc

@@ -1,5 +1,5 @@
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,55,51,0,0,0,1,0,0,10,0,13,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,56,51,0,0,0,1,0,0,10,0,13,0,
 22,0,27,0,40,0,47,0,51,0,55,0,58,0,65,0,72,0,77,0,82,
 0,88,0,102,0,116,0,119,0,125,0,129,0,131,0,142,0,144,0,158,0,
 165,0,187,0,189,0,203,0,14,1,43,1,54,1,65,1,75,1,111,1,144,
@@ -19,7 +19,7 @@
 2,5,2,2,2,7,2,2,2,8,2,2,2,6,2,2,2,10,2,2,2,
 9,2,2,2,11,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240,218,
 81,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2,2,
-2,3,96,38,11,8,240,218,81,0,0,16,0,96,11,11,8,240,218,81,0,
+2,3,96,11,11,8,240,218,81,0,0,16,0,96,38,11,8,240,218,81,0,
 0,16,0,13,16,4,36,29,11,11,2,2,11,18,16,2,99,64,104,101,114,
 101,8,32,8,31,8,30,8,29,8,28,93,8,224,225,81,0,0,95,9,8,
 224,225,81,0,0,2,2,27,248,22,147,4,195,249,22,140,4,80,158,39,36,
@@ -29,15 +29,15 @@
 22,79,193,20,15,159,37,36,37,28,248,22,79,248,22,73,194,248,22,72,193,
 249,22,140,4,80,158,39,36,251,22,81,2,17,248,22,72,199,249,22,71,2,
 7,248,22,73,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8,28,
-16,4,11,11,2,19,3,1,8,101,110,118,49,50,56,51,55,16,4,11,11,
+16,4,11,11,2,19,3,1,8,101,110,118,49,50,56,56,56,16,4,11,11,
-2,20,3,1,8,101,110,118,49,50,56,51,56,93,8,224,226,81,0,0,95,
+2,20,3,1,8,101,110,118,49,50,56,56,57,93,8,224,226,81,0,0,95,
 9,8,224,226,81,0,0,2,2,27,248,22,73,248,22,147,4,196,28,248,22,
 79,193,20,15,159,37,36,37,28,248,22,79,248,22,73,194,248,22,72,193,249,
 22,140,4,80,158,39,36,250,22,81,2,21,248,22,81,249,22,81,248,22,81,
 2,22,248,22,72,201,251,22,81,2,17,2,22,2,22,249,22,71,2,9,248,
 22,73,204,18,16,2,101,11,8,32,8,31,8,30,8,29,8,28,16,4,11,
-11,2,19,3,1,8,101,110,118,49,50,56,52,48,16,4,11,11,2,20,3,
+11,2,19,3,1,8,101,110,118,49,50,56,57,49,16,4,11,11,2,20,3,
-1,8,101,110,118,49,50,56,52,49,93,8,224,227,81,0,0,95,9,8,224,
+1,8,101,110,118,49,50,56,57,50,93,8,224,227,81,0,0,95,9,8,224,
 227,81,0,0,2,2,248,22,147,4,193,27,248,22,147,4,194,249,22,71,248,
 22,81,248,22,72,196,248,22,73,195,27,248,22,73,248,22,147,4,23,197,1,
 249,22,140,4,80,158,39,36,28,248,22,56,248,22,141,4,248,22,72,23,198,
@@ -67,8 +67,8 @@
 26,248,22,73,202,251,22,81,2,17,28,249,22,185,8,248,22,141,4,248,22,
 72,200,64,101,108,115,101,10,248,22,72,197,250,22,82,2,21,9,248,22,73,
 200,249,22,71,2,4,248,22,73,202,100,8,32,8,31,8,30,8,29,8,28,
-16,4,11,11,2,19,3,1,8,101,110,118,49,50,56,54,51,16,4,11,11,
+16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,49,52,16,4,11,11,
-2,20,3,1,8,101,110,118,49,50,56,54,52,93,8,224,228,81,0,0,18,
+2,20,3,1,8,101,110,118,49,50,57,49,53,93,8,224,228,81,0,0,18,
 16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,228,81,0,0,2,
 2,27,248,22,73,248,22,147,4,196,249,22,140,4,80,158,39,36,28,248,22,
 56,248,22,141,4,248,22,72,197,250,22,81,2,27,248,22,81,248,22,72,199,
@@ -99,7 +99,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 2024);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,55,65,0,0,0,1,0,0,8,0,21,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,56,65,0,0,0,1,0,0,8,0,21,0,
 26,0,43,0,58,0,76,0,92,0,102,0,120,0,140,0,156,0,174,0,205,
 0,234,0,0,1,14,1,20,1,34,1,39,1,49,1,57,1,85,1,117,1,
 123,1,168,1,213,1,237,1,20,2,22,2,188,2,22,4,63,4,136,5,222,
@@ -400,7 +400,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 6245);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,55,9,0,0,0,1,0,0,10,0,16,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,56,9,0,0,0,1,0,0,10,0,16,0,
 29,0,44,0,58,0,72,0,86,0,128,0,0,0,57,1,0,0,69,35,37,
 98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67,35,37,117,
 116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114,107,11,29,
@@ -420,7 +420,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 352);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,55,74,0,0,0,1,0,0,7,0,18,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,48,46,56,74,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,162,0,180,0,200,
 0,212,0,228,0,251,0,7,1,38,1,45,1,50,1,55,1,60,1,65,1,
 70,1,79,1,84,1,88,1,94,1,101,1,107,1,115,1,124,1,145,1,166,

src/racket/src/eval.c

@@ -150,9 +150,6 @@
 # include "future.h"
 #endif
 
-#define EMBEDDED_DEFINES_START_ANYWHERE 0
-
-
 /* globals */
 SHARED_OK int scheme_startup_use_jit = 1;
 void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit =  v; }
@@ -194,6 +191,7 @@ ROSYM static Scheme_Object *internal_define_symbol;
 ROSYM static Scheme_Object *module_symbol;
 ROSYM static Scheme_Object *module_begin_symbol;
 ROSYM static Scheme_Object *expression_symbol;
+ROSYM static Scheme_Object *values_symbol;
 ROSYM static Scheme_Object *protected_symbol;
 ROSYM Scheme_Object *scheme_stack_dump_key;
 READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */
@@ -317,6 +315,7 @@ scheme_init_eval (Scheme_Env *env)
   REGISTER_SO(letrec_syntaxes_symbol);
   REGISTER_SO(begin_symbol);
   REGISTER_SO(let_values_symbol);
+  REGISTER_SO(values_symbol);
   
   define_values_symbol    = scheme_intern_symbol("define-values");
   letrec_values_symbol    = scheme_intern_symbol("letrec-values");
@@ -327,6 +326,7 @@ scheme_init_eval (Scheme_Env *env)
   quote_symbol            = scheme_intern_symbol("quote");
   letrec_syntaxes_symbol  = scheme_intern_symbol("letrec-syntaxes+values");
   begin_symbol            = scheme_intern_symbol("begin");
+  values_symbol           = scheme_intern_symbol("values");
   
   REGISTER_SO(module_symbol);
   REGISTER_SO(module_begin_symbol);
@@ -7720,13 +7720,14 @@ scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
 
 static Scheme_Object *
 scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
-			    Scheme_Compile_Expand_Info *rec, int drec)
+			    Scheme_Compile_Expand_Info *rec, int drec,
+                            int mixed)
 /* This ugly code parses a block of code, transforming embedded
    define-values and define-syntax into letrec and letrec-syntax.
    It is espcailly ugly because we have to expand macros
    before deciding what we have. */
 {
-  Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms;
+  Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms, *pre_exprs = scheme_null;
   void **d;
   Scheme_Comp_Env *xenv = NULL;
   Scheme_Compile_Info recs[2];
@@ -7818,13 +7819,18 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
       SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms);
 
       if (SCHEME_STX_NULLP(forms)) {
-	scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, 
+        if (!SCHEME_PAIRP(pre_exprs)) {
-			    "bad syntax (empty form)");
+          scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, 
+                              "bad syntax (empty form)");
+          return NULL;
+        } else {
+          /* fall through to handle expressions without definitions */
+        }
+      } else {
+        forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0);
+        
+        goto try_again;
       }
-
-      forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0);
-
-      goto try_again;
     } else if (SAME_OBJ(gval, scheme_define_values_syntax)
 	       || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) {
       /* Turn defines into a letrec: */
@@ -7836,6 +7842,40 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
       while (1) {
 	int cnt;
 
+        if (!SCHEME_NULLP(pre_exprs)) {
+          Scheme_Object *begin_stx, *values_app_stx;
+
+          pre_exprs = scheme_reverse(pre_exprs);
+
+          begin_stx = scheme_datum_to_syntax(begin_symbol, 
+                                             scheme_false, 
+                                             scheme_sys_wraps(env), 
+                                             0, 0);
+          values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null),
+                                                  scheme_false, 
+                                                  scheme_sys_wraps(env), 
+                                                  0, 0);
+
+          while (SCHEME_PAIRP(pre_exprs)) {
+            v = scheme_make_pair(scheme_null,
+                                 scheme_make_pair(scheme_make_pair(begin_stx,
+                                                                   scheme_make_pair(SCHEME_CAR(pre_exprs),
+                                                                                    scheme_make_pair(values_app_stx,
+                                                                                                     scheme_null))),
+                                                  scheme_null));
+            v = scheme_datum_to_syntax(v, SCHEME_CAR(pre_exprs), SCHEME_CAR(pre_exprs), 0, 0);
+          
+            link = scheme_make_pair(v, scheme_null);
+            if (!start)
+              start = link;
+            else
+              SCHEME_CDR(l) = link;
+            l = link;
+
+            pre_exprs = SCHEME_CDR(pre_exprs);
+          }
+        }
+
 	is_val = SAME_OBJ(gval, scheme_define_values_syntax);
 	
 	v = SCHEME_STX_CDR(first);
@@ -7979,7 +8019,13 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	      result = scheme_flatten_begin(first, result);
 	      SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result);
               goto define_try_again;
-	    } else {
+	    } else if (mixed) {
+              /* accumulate expr for either sequence after definitions
+                 or made-up empty bindings before the next definition */
+              pre_exprs = scheme_make_pair(first, pre_exprs);
+              result = SCHEME_STX_CDR(result);
+              goto define_try_again;
+            } else {
 	      /* Keep partially expanded `first': */
 	      result = SCHEME_STX_CDR(result);
 	      result = scheme_make_pair(first, result);
@@ -7990,15 +8036,19 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	  break;
       }
 
-      if (SCHEME_STX_PAIRP(result)) {
+      if (SCHEME_STX_PAIRP(result) || SCHEME_PAIRP(pre_exprs)) {
 	if (!start)
 	  start = scheme_null;
+
+        if (SCHEME_PAIRP(pre_exprs))
+          result = scheme_reverse(pre_exprs); /* from mixed mode */
+
+        if (!mixed) {
+          result = scheme_make_pair(scheme_make_pair(scheme_intern_symbol("#%stratified-body"),
+                                                     result),
+                                    scheme_null);
+        }
         
-	/* I think the following was intended as an optimization for `expand',
-           since the syntax definition will be dropped. But it breaks
-           `local-expand':
-           if (stx_start && !(rec[drec].comp || (rec[drec].depth == -1)))
-             stx_start = scheme_null; */
 	if (stx_start) {
 	  result = scheme_make_pair(letrec_syntaxes_symbol,
                                     scheme_make_pair(stx_start,
@@ -8015,6 +8065,18 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 	scheme_wrong_syntax(scheme_begin_stx_string, NULL, orig, 
 			    "no expression after a sequence of internal definitions");
       }
+    } else if (mixed) {
+      /* accumulate expr for either an expr-only sequence or made-up
+         empty bindings before a definition that appears later */
+      pre_exprs = scheme_make_pair(first, pre_exprs);
+      forms = SCHEME_STX_CDR(forms);
+      if (SCHEME_STX_NULLP(forms)) {
+        /* fall through to handle expressions without definitions */
+      } else {
+        goto try_again;
+      }
+    } else {
+      /* fall through to handle just expressions in non-mixed mode */
     }
 
     if (!more) {
@@ -8042,6 +8104,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 
   scheme_stx_seal_rib(rib);
 
+  if (SCHEME_PAIRP(pre_exprs))
+    pre_exprs = scheme_reverse(pre_exprs);
+
   if (rec[drec].comp) {
     Scheme_Object *vname, *rest;
 
@@ -8049,47 +8114,27 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
     scheme_compile_rec_done_local(rec, drec);
     scheme_init_compile_recs(rec, drec, recs, 2);
 
-    rest = SCHEME_STX_CDR(forms);
+    if (SCHEME_NULLP(pre_exprs))
+      rest = SCHEME_STX_CDR(forms);
+    else {
+      first = SCHEME_CAR(pre_exprs);
+      rest = SCHEME_CDR(pre_exprs);
+    }
+
     if (SCHEME_STX_NULLP(rest))
       recs[0].value_name = vname;
     else
       recs[1].value_name = vname;
 
-    rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0);
+    rest = scheme_datum_to_syntax(rest, orig, orig, 0, 0);
 
     first = scheme_compile_expr(first, env, recs, 0);
 
-#if EMBEDDED_DEFINES_START_ANYWHERE
-    forms = scheme_compile_expand_block(rest, env, recs, 1);
-#else
     forms = scheme_compile_list(rest, env, recs, 1);
-#endif
     
     scheme_merge_compile_recs(rec, drec, recs, 2);
     return scheme_make_pair(first, forms);
   } else {
-#if EMBEDDED_DEFINES_START_ANYWHERE
-    /* Expand-observe not implemented for this case,
-       so fix that if it's ever enabled. */
-    Scheme_Object *rest, *vname;
-
-    vname = rec[drec].value_name;
-    rec[drec].value_name = scheme_false;
-    scheme_init_expand_recs(rec, drec, recs, 2);
-
-    rest = SCHEME_STX_CDR(forms);
-
-    if (SCHEME_STX_NULLP(rest))
-      recs[0].value_name = vname;
-    else
-      recs[1].value_name = vname;
-
-    first = scheme_expand_expr(first, env, recs, 0);
-
-    rest = scheme_datum_to_syntax(rest, forms, forms, 0, -1);
-    forms = scheme_compile_expand_block(rest, env, recs, 1);
-    return scheme_make_pair(first, forms);
-#else
     Scheme_Object *newforms, *vname;
 
     vname = rec[drec].value_name;
@@ -8098,9 +8143,14 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 
     recs[0].value_name = vname;
 
-    newforms = SCHEME_STX_CDR(forms);
+    if (SCHEME_PAIRP(pre_exprs))
-    newforms = scheme_make_pair(first, newforms);
+      newforms = pre_exprs;
-    forms = scheme_datum_to_syntax(newforms, forms, forms, 0, -1);
+    else {
+      newforms = SCHEME_STX_CDR(forms);
+      newforms = scheme_make_pair(first, newforms);
+    }
+
+    forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1);
     
     if (scheme_stx_proper_list_length(forms) < 0)
       scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
@@ -8108,7 +8158,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
     SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms);
     forms = scheme_expand_list(forms, env, recs, 0);
     return forms;
-#endif
   }
 }
 
@@ -8116,13 +8165,26 @@ Scheme_Object *
 scheme_compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
 		     Scheme_Compile_Info *rec, int drec)
 {
-  return scheme_compile_expand_block(forms, env, rec, drec);
+  return scheme_compile_expand_block(forms, env, rec, drec, 1);
 }
 
 Scheme_Object *
 scheme_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
 {
-  return scheme_compile_expand_block(forms, env, erec, drec);
+  return scheme_compile_expand_block(forms, env, erec, drec, 1);
+}
+
+Scheme_Object *
+scheme_compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
+                                Scheme_Compile_Info *rec, int drec)
+{
+  return scheme_compile_expand_block(forms, env, rec, drec, 0);
+}
+
+Scheme_Object *
+scheme_expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
+{
+  return scheme_compile_expand_block(forms, env, erec, drec, 0);
 }
 
 Scheme_Object *

src/racket/src/schpriv.h

@@ -2494,6 +2494,8 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *en
 			      Scheme_Compile_Info *rec, int drec);
 Scheme_Object *scheme_compile_block(Scheme_Object *forms, Scheme_Comp_Env *env,
 			      Scheme_Compile_Info *rec, int drec);
+Scheme_Object *scheme_compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env,
+                                               Scheme_Compile_Info *rec, int drec);
 Scheme_Object *scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env,
 			      Scheme_Compile_Info *rec, int drec);
 
@@ -2606,6 +2608,8 @@ Scheme_Object *scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env,
 				  Scheme_Expand_Info *erec, int drec);
 Scheme_Object *scheme_expand_block(Scheme_Object *form, Scheme_Comp_Env *env,
 				   Scheme_Expand_Info *erec, int drec);
+Scheme_Object *scheme_expand_stratified_block(Scheme_Object *form, Scheme_Comp_Env *env,
+                                              Scheme_Expand_Info *erec, int drec);
 Scheme_Object *scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
 					      Scheme_Expand_Info *erec, int drec);
 

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.0.7"
+#define MZSCHEME_VERSION "5.0.0.8"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#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)

src/racket/src/syntax.c

@@ -86,6 +86,8 @@ static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, S
 static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
 static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
 static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
+static Scheme_Object *stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
+static Scheme_Object *stratified_body_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
 static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
 static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
 
@@ -426,6 +428,10 @@ scheme_init_syntax (Scheme_Env *env)
   scheme_add_global_keyword("begin", 
 			    scheme_begin_syntax, 
 			    env);
+  scheme_add_global_keyword("#%stratified-body", 
+                            scheme_make_compiled_syntax(stratified_body_syntax, 
+                                                        stratified_body_expand), 
+			    env);
 
   scheme_add_global_keyword("begin0", 
 			    scheme_make_compiled_syntax(begin0_syntax, 
@@ -5130,6 +5136,24 @@ begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *r
   return do_begin_syntax("begin0", form, env, rec, drec, 1);
 }
 
+static Scheme_Object *
+stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
+{
+  Scheme_Object *body;
+
+  check_form(form, form);
+
+  body = SCHEME_STX_CDR(form);
+  body = scheme_datum_to_syntax(body, form, form, 0, 0);
+
+  body = scheme_compile_stratified_block(body, env, rec, drec);
+
+  if (SCHEME_NULLP(SCHEME_CDR(body)))
+    return SCHEME_CAR(body);
+  else
+    return scheme_make_sequence_compilation(body, 1);
+}
+
 static Scheme_Object *
 do_begin_expand(char *name,
 		Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec,
@@ -5217,6 +5241,27 @@ begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
   return do_begin_expand("begin0", form, env, erec, drec, 1);
 }
 
+static Scheme_Object *
+stratified_body_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
+{
+  Scheme_Object *body;
+
+  check_form(form, form);
+
+  body = SCHEME_STX_CDR(form);
+  body = scheme_datum_to_syntax(body, form, form, 0, 0);
+  
+  body = scheme_expand_stratified_block(body, env, erec, drec);
+
+  if (SCHEME_STX_NULLP(SCHEME_STX_CDR(body)))
+    return SCHEME_STX_CAR(body);
+  else {
+    body = cons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
+                body);
+    return scheme_datum_to_syntax(body, form, form, 0, 0);
+  }
+}
+
 /**********************************************************************/
 /*                    top-level splicing begin                        */
 /**********************************************************************/