internal-definition contexts allow expressions mixed with definitions
while the new `#%stratified-body' form provides access to the old convention
This commit is contained in:
parent
a8062dc37d
commit
54216b5ced
|
@ -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)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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 *
|
||||
|
|
|
@ -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);
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 */
|
||||
/**********************************************************************/
|
||||
|
|
Loading…
Reference in New Issue
Block a user