diff --git a/collects/rnrs/base-6.rkt b/collects/rnrs/base-6.rkt index 013416a5ee..6fd4e2249b 100644 --- a/collects/rnrs/base-6.rkt +++ b/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)])) ;; ---------------------------------------- diff --git a/collects/rnrs/control-6.rkt b/collects/rnrs/control-6.rkt index 8923ae442f..a87228971c 100644 --- a/collects/rnrs/control-6.rkt +++ b/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 diff --git a/collects/scribblings/guide/define.scrbl b/collects/scribblings/guide/define.scrbl index 95c5402aa7..cd44da6b71 100644 --- a/collects/scribblings/guide/define.scrbl +++ b/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 -before any expression, and the last @racket[_body] must be an -expression. +Expressions and internal definitions in a @racket[_body] sequence can +be mixed, as long as the last @racket[_body] is an expression. For example, the syntax of @racket[lambda] is diff --git a/collects/scribblings/reference/block.scrbl b/collects/scribblings/reference/block.scrbl index 9fa5168b43..5427b42cd4 100644 --- a/collects/scribblings/reference/block.scrbl +++ b/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, diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 2fd384d80d..e01475fed9 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/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 - accumulated definition forms are converted to a + and so on. The content of a @racket[begin] form is spliced into + 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 - context. + expression-form tail to the body to be expanded in expression + 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 diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 9115394f96..267d54e806 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/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] diff --git a/collects/tests/racket/macro.rktl b/collects/tests/racket/macro.rktl index 1dd990b027..a4200119fc 100644 --- a/collects/tests/racket/macro.rktl +++ b/collects/tests/racket/macro.rktl @@ -320,12 +320,14 @@ (define goo 10) 12)) -(syntax-test #'(let-syntax ([ohno (lambda (stx) #'(define z -10))]) - (let () - (define ohno 128) - ohno - (define-syntax (goo stx) #'ohno) - (printf "~a\n" ohno)))) +(test 128 apply (lambda () + (let-syntax ([ohno (lambda (stx) #'(define z -10))]) + (let () + (define ohno 128) + ohno + (define-syntax (goo stx) #'ohno) + ohno))) + null) (define-syntax (def-it stx) (syntax-case stx () diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index b815cd1dc4..77f216b411 100644 --- a/collects/tests/racket/syntax.rktl +++ b/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)) diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 8281967a14..23602ef738 100644 --- a/src/racket/src/cstartup.inc +++ b/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, -2,20,3,1,8,101,110,118,49,50,56,51,56,93,8,224,226,81,0,0,95, +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,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, -1,8,101,110,118,49,50,56,52,49,93,8,224,227,81,0,0,95,9,8,224, +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,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, -2,20,3,1,8,101,110,118,49,50,56,54,52,93,8,224,228,81,0,0,18, +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,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, diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 394c1d86d5..8053e8deff 100644 --- a/src/racket/src/eval.c +++ b/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, - "bad syntax (empty form)"); + if (!SCHEME_PAIRP(pre_exprs)) { + 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); - newforms = scheme_make_pair(first, newforms); - forms = scheme_datum_to_syntax(newforms, forms, forms, 0, -1); + if (SCHEME_PAIRP(pre_exprs)) + newforms = pre_exprs; + 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 * diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index fbc7451e4c..33387b1aa8 100644 --- a/src/racket/src/schpriv.h +++ b/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); diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index fd0ef5c703..ae0ce5b777 100644 --- a/src/racket/src/schvers.h +++ b/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) diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index fa0a63d87e..725daba10d 100644 --- a/src/racket/src/syntax.c +++ b/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 */ /**********************************************************************/