suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

internal-definition contexts allow expressions mixed with definitions

Browse Source 
while the new `#%stratified-body' form provides access to the old
 convention
This commit is contained in:
Matthew Flatt 2010-07-07 11:58:56 -06:00
parent a8062dc37d
commit 54216b5ced
13 changed files with 229 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/rnrs/base-6.rkt
View File

@ -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)]))
;; ----------------------------------------

4
collects/rnrs/control-6.rkt
View File

@ -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

5
collects/scribblings/guide/define.scrbl
View File

@ -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

5
collects/scribblings/reference/block.scrbl
View File

@ -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,

13
collects/scribblings/reference/syntax-model.scrbl
View File

@ -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

13
collects/scribblings/reference/syntax.scrbl
View File

@ -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]

14
collects/tests/racket/macro.rktl
View File

@ -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 ()

8
collects/tests/racket/syntax.rktl
View File

@ -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))

22
src/racket/src/cstartup.inc
View File

@ -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,

166
src/racket/src/eval.c
View File

@ -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 *

4
src/racket/src/schpriv.h
View File

@ -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);

4
src/racket/src/schvers.h
View File

@ -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)

45
src/racket/src/syntax.c
View File

@ -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 */
/**********************************************************************/