diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 755ecf4a77..621ce25a87 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -586,8 +586,8 @@ binding} at @tech{phase level} 0). @subsection[#:tag "partial-expansion"]{Partial Expansion} In certain contexts, such as an @tech{internal-definition context} or -@tech{module context}, forms are partially expanded to determine -whether they represent definitions, expressions, or other declaration +@tech{module context}, @deftech{partial expansion} is used to determine +whether forms represent definitions, expressions, or other declaration forms. Partial expansion works by cutting off the normal recursion expansion when the relevant binding is for a primitive syntactic form. @@ -600,46 +600,35 @@ then expansion stops without adding the identifier. @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @subsection[#:tag "intdef-body"]{Internal Definitions} -An @tech{internal-definition context} corresponds to a partial expansion step -(see @secref["partial-expansion"]). Forms that allow internal definitions document -such positions using the @racket[_body] meta-variable. A form that supports internal -definitions starts by expanding its first form in an -internal-definition context, but only partially. That is, it -recursively expands only until the form becomes one of the following: +An @tech{internal-definition context} supports local definitions mixed +with expressions. Forms that allow internal definitions document such +positions using the @racket[_body] meta-variable. Definitions in an +internal-definition context are equivalent to local binding via +@racket[letrec-syntaxes+values]; macro expansion converts internal +definitions to a @racket[letrec-syntaxes+values] form. + +Expansion of an internal-definition context relies on @tech{partial +expansion} of each @racket[_body] in an internal-definition sequence. +Partial expansion of each @racket[_body] produces a form matching one +of the following cases: @itemize[ - @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. 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-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. + @item{A @racket[define-values] form: The lexical context of all + syntax objects for the body sequence is immediately enriched + with bindings for the @racket[define-values] form. Further + expansion of the definition is deferred, and partial expansion + continues with the rest of the body.} - When a @racket[define-values] form is discovered, the lexical - context of all syntax objects for the body sequence is - immediately enriched with bindings for the - @racket[define-values] form before expansion continues. When a - @racket[define-syntaxes] form is discovered, the right-hand - side is expanded and evaluated (as for a + @item{A @racket[define-syntaxes] form: The right-hand side is + expanded and evaluated (as for a @racket[letrec-syntaxes+values] form), and a transformer - binding is installed for the body sequence before expansion - continues.} + binding is installed for the body sequence before partial + expansion continues with the est of the body.} - @item{A primitive expression form other than @racket[begin]: The - expression is expanded in an expression context, along with all - remaining body forms. If any definitions were found, this - expansion takes place after conversion to a - @racket[letrec-values] or @racket[letrec-syntaxes+values] - form. Otherwise, the expressions are expanded immediately.} + @item{A primitive expression form other than @racket[begin]: Further + expansion of the expression is deferred, and partial expansion + continues with the rest of the body.} @item{A @racket[begin] form: The sub-forms of the @racket[begin] are spliced into the internal-definition sequence, and partial @@ -648,8 +637,15 @@ recursively expands only until the form becomes one of the following: ] -If the last expression form turns out to be a @racket[define-values] -or @racket[define-syntaxes] form, expansion fails with a syntax error. +After all body forms are partially expanded, if no definitions were +encountered, then the expressions are collected into a @racket[begin] +form as he internal-definition context's expansion. Otherwise, at +least one expression must appear after the last definition, and any +@racket[_expr] that appears between definitions is converted to +@racket[(define-values () (begin _expr (values)))]; the definitions +are then converted to bindings in a @racket[letrec-syntaxes+values] +form, and all expressions after the last definition become the body of +the @racket[letrec-syntaxes+values] form. @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @subsection[#:tag "mod-parse"]{Module Phases and Visits} diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index ab79919a0b..b27f6daf03 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -1296,7 +1296,7 @@ expression. Refers to a module-level or local binding, when @racket[id] is not bound as a transformer (see @secref["expansion"]). At run-time, -the reference evaluates to the value in the location associated with +the reference evaluates to the value in the @tech{location} associated with the binding. When the expander encounters an @racket[id] that is not bound by a @@ -1334,7 +1334,7 @@ introduces @racketidfont{#%top} identifiers. (#%variable-reference)]]{ Produces an opaque @deftech{variable reference} value representing the -location of @racket[id], which must be bound as a @tech{top-level +@tech{location} of @racket[id], which must be bound as a @tech{top-level variable} or @tech{module-level variable}. If no @racket[id] is supplied, the resulting value refers to an ``anonymous'' variable defined within the enclosing context (i.e., within the enclosing @@ -1593,7 +1593,7 @@ Like @racket[lambda], but without support for keyword or optional arguments. (let proc-id ([id init-expr] ...) body ...+)]]{ The first form evaluates the @racket[val-expr]s left-to-right, creates -a new location for each @racket[id], and places the values into the +a new @tech{location} for each @racket[id], and places the values into the locations. It then evaluates the @racket[body]s, in which the @racket[id]s are bound. The last @racket[body] expression is in tail position with respect to the @racket[let] form. The @racket[id]s @@ -1622,7 +1622,7 @@ within the @racket[body]s to the procedure itself.} @defform[(let* ([id val-expr] ...) body ...+)]{ Similar to @racket[let], but evaluates the @racket[val-expr]s one by -one, creating a location for each @racket[id] as soon as the value is +one, creating a @tech{location} for each @racket[id] as soon as the value is available. The @racket[id]s are bound in the remaining @racket[val-expr]s as well as the @racket[body]s, and the @racket[id]s need not be distinct; later bindings shadow earlier bindings. @@ -1635,7 +1635,7 @@ distinct; later bindings shadow earlier bindings. @defform[(letrec ([id val-expr] ...) body ...+)]{ -Similar to @racket[let], but the locations for all @racket[id]s are +Similar to @racket[let], but the @tech{locations} for all @racket[id]s are created first and filled with @|undefined-const|, and all @racket[id]s are bound in all @racket[val-expr]s as well as the @racket[body]s. The @racket[id]s must be distinct according to @@ -1654,7 +1654,7 @@ created first and filled with @|undefined-const|, and all @defform[(let-values ([(id ...) val-expr] ...) body ...+)]{ Like @racket[let], except that each @racket[val-expr] must produce as many values as corresponding @racket[id]s, otherwise the -@exnraise[exn:fail:contract]. A separate location is created for each +@exnraise[exn:fail:contract]. A separate @tech{location} is created for each @racket[id], all of which are bound in the @racket[body]s. @mz-examples[ @@ -1664,7 +1664,7 @@ values as corresponding @racket[id]s, otherwise the @defform[(let*-values ([(id ...) val-expr] ...) body ...+)]{ Like @racket[let*], except that each @racket[val-expr] must produce as many -values as corresponding @racket[id]s. A separate location is created +values as corresponding @racket[id]s. A separate @tech{location} is created for each @racket[id], all of which are bound in the later @racket[val-expr]s and in the @racket[body]s. @@ -1676,7 +1676,7 @@ for each @racket[id], all of which are bound in the later @defform[(letrec-values ([(id ...) val-expr] ...) body ...+)]{ Like @racket[letrec], except that each @racket[val-expr] must produce as -many values as corresponding @racket[id]s. A separate location is +many values as corresponding @racket[id]s. A separate @tech{location} is created for each @racket[id], all of which are initialized to @|undefined-const| and bound in all @racket[val-expr]s and in the @racket[body]s. @@ -1738,18 +1738,40 @@ within all @racket[trans-expr]s.} ([(val-id ...) val-expr] ...) body ...+)]{ -Combines @racket[letrec-syntaxes] with @racket[letrec-values]: each -@racket[trans-id] and @racket[val-id] is bound in all -@racket[trans-expr]s and @racket[val-expr]s. +Combines @racket[letrec-syntaxes] with a variant of +@racket[letrec-values]: each @racket[trans-id] and @racket[val-id] is +bound in all @racket[trans-expr]s and @racket[val-expr]s. The @racket[letrec-syntaxes+values] form is the core form for local compile-time bindings, since forms like @racket[letrec-syntax] and -internal @racket[define-syntax] expand to it. In a fully expanded +@tech{internal-definition contexts} expand to it. In a fully expanded expression (see @secref["fully-expanded"]), the @racket[trans-id] -bindings are discarded and the form reduces to @racket[letrec], but +bindings are discarded and the form reduces to a combination of +@racket[letrec-values] or @racket[let-values], but @racket[letrec-syntaxes+values] can appear in the result of @racket[local-expand] with an empty stop list. +For variables bound by @racket[letrec-syntaxes+values], the +@tech{location}-creation rules differ slightly from +@racket[letrec-values]. The @racket[[(val-id ...) val-expr]] binding +clauses are partitioned into minimal sets of clauses that satisfy the +following rule: if a clause has a @racket[val-id] binding that is +referenced (in a full expansion) by the @racket[val-expr] of an +earlier clause, the two clauses and all in between are in the same +set. If a set consists of a single clause whose @racket[val-expr] does +not refer to any of the clause's @racket[val-id]s, then +@tech{locations} for the @racket[val-id]s are created @emph{after} the +@racket[val-expr] is evaluated. Otherwise, @tech{locations} for all +@racket[val-id]s in a set are created just before the first +@racket[val-expr] in the set is evaluated. + +The end result of the @tech{location}-creation rules is that scoping +and evaluation order are the same as for @racket[letrec-values], but +the compiler has more freedom to optimize away @tech{location} +creation. The rules also correspond to a nesting of +@racket[let-values] and @racket[letrec-values], which is how +@racket[letrec-syntaxes+values] for a fully-expanded expression. + See also @racket[local], which supports local bindings with @racket[define], @racket[define-syntax], and more.} @@ -1760,9 +1782,9 @@ See also @racket[local], which supports local bindings with @defform[(local [definition ...] body ...+)]{ -Like @racket[letrec], except that the bindings are expressed in the -same way as in the top-level or in a module body: using -@racket[define], @racket[define-values], @racket[define-syntax], +Like @racket[letrec-syntaxes+values], except that the bindings are +expressed in the same way as in the top-level or in a module body: +using @racket[define], @racket[define-values], @racket[define-syntax], @racket[struct], etc. Definitions are distinguished from non-definitions by partially expanding @racket[definition] forms (see @secref["partial-expansion"]). As in the top-level or in a module @@ -2508,7 +2530,10 @@ provides a hook to control interactive evaluation through Like @racket[(let () defn-or-expr ...)] for an @tech{internal-definition context} sequence, except that an expression -is not allowed to precede a definition. +is not allowed to precede a definition, and all definitions are +treated as referring to all other definitions (i.e., @tech{locations} +for variables are all allocated first, like @racket[letrec] and +unlike @racket[letrec-syntaxes+values]). The @racket[#%stratified-body] form is useful for implementing syntactic forms or languages that supply a more limited kind of diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 19786cf75e..1b5dd1ad17 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1112,6 +1112,41 @@ [y (lambda () (x))]) (list (x) (y) h))))) +(test-comp '(lambda (f a) + (define x (f y)) + (define y (m)) + (define-syntax-rule (m) 10) + (f "hi!\n") + (define z (f (lambda () (+ x y a)))) + (define q (p)) + (define p (q)) + (list x y z)) + '(lambda (f a) + (letrec ([x (f y)] + [y 10]) + (f "hi!\n") + (let ([z (f (lambda () (+ x y a)))]) + (letrec ([q (p)] + [p (q)]) + (list x y z)))))) + +(test-comp '(lambda (f a) + (#%stratified-body + (define x (f y)) + (define y (m)) + (define-syntax-rule (m) 10) + (define z (f (lambda () (+ x y a)))) + (define q (p)) + (define p (q)) + (list x y z))) + '(lambda (f a) + (letrec-values ([(x) (f y)] + [(y) 10] + [(z) (f (lambda () (+ x y a)))] + [(q) (p)] + [(p) (q)]) + (list x y z)))) + (test-comp '(procedure? add1) #t) (test-comp '(procedure? (lambda (x) x)) diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index 70b593f317..5c08a14d6a 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -689,8 +689,9 @@ (test #t has-stx-property? (expand #'(let () (define-struct x (a)) 12)) #f 'define-struct 'origin) ;; Disappearing syntax decls: -(test #t has-stx-property? (expand #'(let () (define-syntax x 1) (define y 12) 10)) 'letrec-values 'x 'disappeared-binding) -(test #t has-stx-property? (expand #'(let () (define-struct s (x)) 10)) 'letrec-values 's 'disappeared-binding) +(test #t has-stx-property? (expand #'(let () (define-syntax x 1) (define y 12) 10)) 'let-values 'x 'disappeared-binding) +(test #t has-stx-property? (expand #'(let () (define-syntax x 1) (define y y) 10)) 'letrec-values 'x 'disappeared-binding) +(test #t has-stx-property? (expand #'(let () (define-struct s (x)) 10)) 'let-values 's 'disappeared-binding) (test #t has-stx-property? (expand #'(let () (define-syntax x 1) 10)) 'let-values 'x 'disappeared-binding) (test #f has-stx-property? (expand #'(fluid-let-syntax ([x 1]) 10)) 'let-values 'x 'disappeared-binding) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 324554767d..67c3c40dda 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -1388,6 +1388,54 @@ (test #t exn? (caar (map try (list pipeline2))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Semantics of internal definitions != R5RS + +(test 0 'racket-int-def (call-with-continuation-prompt + (lambda () + (let ([v 0] + [k #f] + [q void]) + (define f (let/cc _k (set! k _k))) + (define g v) ; fresh location each evaluation + (if f + (begin + (set! q (lambda () g)) + (set! v 1) + (k #f)) + (q)))))) +(test 1 'racket-int-def (call-with-continuation-prompt + (lambda () + (let ([v 0] + [k #f] + [q void]) + (#%stratified-body + (define f (let/cc _k (set! k _k))) + (define g v) ; same location both evaluations + (if f + (begin + (set! q (lambda () g)) + (set! v 1) + (k #f)) + (q))))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; check that the compiler is not too agressive with `letrec' -> `let*' + +(test "#\nready\n" + get-output-string + (let ([p (open-output-string)]) + (parameterize ([current-output-port p]) + (let ([restart void]) + (letrec ([dummy1 (let/cc k (set! restart k))] + [dummy2 (displayln maybe-ready)] + [maybe-ready 'ready]) + (let ([rs restart]) + (set! restart void) + (rs #f))))) + p)) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 23885360dd..6334048ace 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,7 @@ +Version 5.1.2.2 +Changed the location-creation semantics of internal definitions + and `letrec-syntaxes+values' + Version 5.1.2, July 2011 Replaced syntax certificates with syntax taints: Added syntax-tainted?, syntax-arm, syntax-disarm, syntax-rearm, diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index b72124fb4f..d98e20e680 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -1676,6 +1676,365 @@ case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand /* let, let-values, letrec, etc. */ /**********************************************************************/ +static Scheme_Let_Header *make_header(Scheme_Object *first, int num_bindings, int num_clauses, + int flags) +{ + Scheme_Let_Header *head; + + head = MALLOC_ONE_TAGGED(Scheme_Let_Header); + head->iso.so.type = scheme_compiled_let_void_type; + head->body = first; + head->count = num_bindings; + head->num_clauses = num_clauses; + SCHEME_LET_FLAGS(head) = flags; + + return head; +} + +static Scheme_Object *shift_compiled_expression(Scheme_Object *v, int delta, int skip); + +static Scheme_Object *shift_compiled_expression_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *v = (Scheme_Object *)p->ku.k.p1; + + p->ku.k.p1 = NULL; + + return (void *)shift_compiled_expression(v, p->ku.k.i1, p->ku.k.i2); +} + +static Scheme_Object *shift_compiled_expression(Scheme_Object *v, int delta, int skip) +{ + if (!delta || (SCHEME_TYPE(v) > _scheme_compiled_values_types_)) + return v; + + if (delta < 0) scheme_signal_error("internal error: bad shift delta"); + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = (void *)v; + p->ku.k.i1 = delta; + p->ku.k.i2 = skip; + + return scheme_handle_stack_overflow(shift_compiled_expression_k); + } + } +#endif + + /* Perform simple shifts directly. We want to avoid adding + extra `let' ayers if possible, since it might interefere + with optimizations. */ + + switch (SCHEME_TYPE(v)) { + case scheme_compiled_toplevel_type: + case scheme_compiled_quote_syntax_type: + case scheme_varref_form_type: + return v; + case scheme_local_type: + { + int pos = SCHEME_LOCAL_POS(v); + if (pos < skip) + return v; + else + return scheme_make_local(scheme_local_type, pos - delta, 0); + } + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)v; + int i; + + for (i = app->num_args + 1; i--; ) { + v = shift_compiled_expression(app->args[i], delta, skip); + app->args[i] = v; + } + + return (Scheme_Object *)app; + } + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)v; + + v = shift_compiled_expression(app->rator, delta, skip); + app->rator = v; + v = shift_compiled_expression(app->rand, delta, skip); + app->rand = v; + + return (Scheme_Object *)app; + } + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)v; + + v = shift_compiled_expression(app->rator, delta, skip); + app->rator = v; + v = shift_compiled_expression(app->rand1, delta, skip); + app->rand1 = v; + v = shift_compiled_expression(app->rand2, delta, skip); + app->rand2 = v; + + return (Scheme_Object *)app; + } + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)v; + + v = shift_compiled_expression(b->test, delta, skip); + b->test = v; + v = shift_compiled_expression(b->tbranch, delta, skip); + b->tbranch = v; + v = shift_compiled_expression(b->fbranch, delta, skip); + b->fbranch = v; + + return (Scheme_Object *)b; + } + case scheme_with_cont_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)v; + + v = shift_compiled_expression(wcm->key, delta, skip); + wcm->key = v; + v = shift_compiled_expression(wcm->val, delta, skip); + wcm->val = v; + v = shift_compiled_expression(wcm->body, delta, skip); + wcm->body = v; + + return (Scheme_Object *)wcm; + } + case scheme_sequence_type: + case scheme_begin0_sequence_type: + { + Scheme_Sequence *s = (Scheme_Sequence *)v; + int i; + + for (i = s->count; i--; ) { + v = shift_compiled_expression(s->array[i], delta, skip); + s->array[i] = v; + } + + return (Scheme_Object *)s; + } + case scheme_apply_values_type: + { + Scheme_Object *v2; + + v2 = shift_compiled_expression(SCHEME_PTR1_VAL(v), delta, skip); + SCHEME_PTR1_VAL(v) = v2; + v2 = shift_compiled_expression(SCHEME_PTR2_VAL(v), delta, skip); + SCHEME_PTR2_VAL(v) = v2; + + return v; + } + case scheme_set_bang_type: + { + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)v; + + v = shift_compiled_expression(sb->var, delta, skip); + sb->var = v; + v = shift_compiled_expression(sb->val, delta, skip); + sb->val = v; + + return (Scheme_Object *)sb; + } + case scheme_compiled_unclosed_procedure_type: + { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)v; + + v = shift_compiled_expression(data->code, delta, skip + data->num_params); + data->code = v; + + return (Scheme_Object *)data; + } + case scheme_case_lambda_sequence_type: + { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)v; + int i; + + for (i = cl->count; i--; ) { + v = shift_compiled_expression(cl->array[i], delta, skip); + cl->array[i] = v; + } + + return (Scheme_Object *)cl; + } + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *lh = (Scheme_Let_Header *)v; + Scheme_Compiled_Let_Value *clv; + int post_bind = !(SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + int i; + + if (!post_bind) skip += lh->count; + + clv = (Scheme_Compiled_Let_Value *)lh->body; + i = lh->num_clauses; + while (1) { + v = shift_compiled_expression(clv->value, delta, skip); + clv->value = v; + if (--i) + clv = (Scheme_Compiled_Let_Value *)clv->body; + else + break; + } + + if (post_bind) skip += lh->count; + + if (!lh->num_clauses) { + v = shift_compiled_expression(lh->body, delta, skip); + lh->body = v; + } else { + v = shift_compiled_expression(clv->body, delta, skip); + clv->body = v; + } + + return (Scheme_Object *)lh; + } + default: + scheme_signal_error("internal error: compile-time shift failed: %d", SCHEME_TYPE(v)); + return NULL; + } +} + +static Scheme_Object *force_traditional_letrec(Scheme_Object *result, Scheme_Comp_Env *env) +{ + /* Force `letrec'-style binding by adding a forward + reference to the last binding as a first binding: + (letrec-values+syntaxes ([() (if #f (#%app values))] ....) ....). + To avoid affecting performance, this hack is reverted in + the `letrec' compiler and expander. */ + Scheme_Object *sbh, *vbh, *vb, *v, *last_name = NULL, *values, *app; + + sbh = SCHEME_STX_CDR(result); + vbh = SCHEME_STX_CDR(sbh); + vb = SCHEME_STX_CAR(vbh); + + while (!SCHEME_STX_NULLP(vb)) { + v = SCHEME_STX_CAR(vb); + v = SCHEME_STX_CAR(v); + if (!SCHEME_STX_NULLP(v)) { + last_name = SCHEME_STX_CAR(v); + } + vb = SCHEME_STX_CDR(vb); + } + + if (last_name) { + vb = SCHEME_STX_CAR(vbh); + v = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, + scheme_sys_wraps(env), 0, 0); + app = scheme_datum_to_syntax(app_symbol, scheme_false, + scheme_sys_wraps(env), 0, 0); + values = scheme_datum_to_syntax(values_symbol, scheme_false, + scheme_sys_wraps(env), 0, 0); + vb = icons(icons(scheme_null, + icons(icons(v, + icons(scheme_false, + icons(last_name, + icons(icons(app, icons(values, scheme_null)), + scheme_null)))), + scheme_null)), + vb); + vbh = SCHEME_STX_CDR(vbh); + sbh = SCHEME_STX_CAR(sbh); + v = SCHEME_STX_CAR(result); + v = icons(v, icons(sbh, icons(vb, vbh))); + result = scheme_datum_to_syntax(v, result, result, 0, 2); + } + + return result; +} + +static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp_Env *env) +/* See force_traditional_letrec() */ +{ + Scheme_Object *v, *v2, *v3, *id; + + v = SCHEME_STX_CDR(form); + v = SCHEME_STX_CAR(v); + if (SCHEME_STX_NULLP(v)) return form; + + v = SCHEME_STX_CAR(v); + /* is v `[() ...]' ? */ + v2 = SCHEME_STX_CAR(v); + if (!SCHEME_STX_NULLP(v2)) return form; + + v2 = SCHEME_STX_CDR(v); + v2 = SCHEME_STX_CAR(v2); + + /* is v2 `(if #f ... (values))' ? */ + if (!SCHEME_STX_PAIRP(v2)) return form; + v = SCHEME_STX_CDR(v2); + if (!SCHEME_STX_PAIRP(v)) return form; + v = SCHEME_STX_CAR(v); + v = SCHEME_STX_VAL(v); + + if (!SCHEME_FALSEP(v)) { + /* try '#f: */ + if (!SCHEME_PAIRP(v)) return form; + v3 = SCHEME_CDR(v); + if (!SCHEME_STX_PAIRP(v3)) return form; + v3 = SCHEME_STX_CAR(v3); + v3 = SCHEME_STX_VAL(v3); + if (!SCHEME_FALSEP(v3)) return form; + + v3 = SCHEME_CDR(v); + v3 = SCHEME_STX_CDR(v3); + if (!SCHEME_STX_NULLP(v3)) return form; + } + + /* found #f; look for `if' and `(#%app values)': */ + v = SCHEME_STX_CAR(v2); + if (!SCHEME_STX_SYMBOLP(v)) return form; + + id = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, + scheme_sys_wraps(env), 0, 0); + if (!scheme_stx_module_eq(v, id, env->genv->phase)) return form; + + /* found `if'; look for `(#%app values)' */ + v = SCHEME_STX_CDR(v2); + v = SCHEME_STX_CDR(v); + if (!SCHEME_STX_PAIRP(v)) return form; + v = SCHEME_STX_CDR(v); + if (!SCHEME_STX_PAIRP(v)) return form; + v2 = SCHEME_STX_CDR(v); + if (!SCHEME_STX_NULLP(v2)) return form; + + v = SCHEME_STX_CAR(v); + if (!SCHEME_STX_PAIRP(v)) return form; + v2 = SCHEME_STX_CAR(v); + if (!SCHEME_STX_SYMBOLP(v2)) return form; + id = scheme_datum_to_syntax(app_symbol, scheme_false, + scheme_sys_wraps(env), 0, 0); + if (!scheme_stx_module_eq(v2, id, env->genv->phase)) return form; + + v = SCHEME_STX_CDR(v); + if (!SCHEME_STX_PAIRP(v)) return form; + v2 = SCHEME_STX_CDR(v); + if (!SCHEME_STX_NULLP(v2)) return form; + + v = SCHEME_STX_CAR(v); + if (!SCHEME_STX_SYMBOLP(v)) return form; + id = scheme_datum_to_syntax(values_symbol, scheme_false, + scheme_sys_wraps(env), 0, 0); + if (!scheme_stx_module_eq(v, id, env->genv->phase)) return form; + + /* pattern matched; drop the first clause */ + v = SCHEME_STX_CDR(form); + v2 = SCHEME_STX_CAR(v); + v2 = SCHEME_STX_CDR(v2); + + v = SCHEME_STX_CDR(v); + v = scheme_datum_to_syntax(v, scheme_false, scheme_false, 0, 0); + v2 = icons(v2, v); + + v = SCHEME_STX_CAR(form); + v2 = icons(v, v2); + + return scheme_datum_to_syntax(v2, form, form, 0, 2); +} + static Scheme_Object * gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, @@ -1691,9 +2050,18 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, int rec_env_already = rec[drec].env_already; int rev_bind_order = recursive; int post_bind = !recursive && !star; - + Scheme_Let_Header *head; + form = scheme_stx_taint_disarm(form, NULL); + if (rec_env_already == 2) { + l = detect_traditional_letrec(form, origenv); + if (!SAME_OBJ(l, form)) { + rec_env_already = 1; + form = l; + } + } + i = scheme_stx_proper_list_length(form); if (i < 3) scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL)); @@ -1896,7 +2264,15 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } } + head = make_header(first, num_bindings, num_clauses, + ((recursive ? SCHEME_LET_RECURSIVE : 0) + | (star ? SCHEME_LET_STAR : 0))); + if (recursive) { + Scheme_Let_Header *current_head = head; + int prev_might_invoke = 0; + int group_clauses = 0, group_count = 0; + lv = (Scheme_Compiled_Let_Value *)first; for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { Scheme_Object *ce, *rhs; @@ -1906,14 +2282,55 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, lv->value = ce; /* Record the fact that this binding doesn't use any or later - bindings in the same set. The `let' optimizer and resolver + bindings in the same set. In internal-definition mode, break bindings into smaller sets based on this - information. */ - if (!scheme_env_check_reset_any_use(env) - && !scheme_might_invoke_call_cc(ce)) - SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; - if (!scheme_env_min_use_below(env, lv->position)) - SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; + information; otherwise, the `let' optimizer and resolver + may do so, but we have to be more conservative as reflected + by scheme_might_invoke_call_cc(). */ + if ((rec_env_already == 2) /* int def: semantics is `let' */ + || (!prev_might_invoke + && !scheme_might_invoke_call_cc(ce))) { + if (!scheme_env_check_reset_any_use(env)) + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; + if ((rec_env_already == 2) + && !group_clauses + && !scheme_env_min_use_below(env, lv->position + lv->count)) { + /* A clause that should be in its own `let' */ + Scheme_Let_Header *next_head; + next_head = make_header(lv->body, + current_head->count - lv->count, + current_head->num_clauses - 1, + SCHEME_LET_RECURSIVE); + current_head->num_clauses = 1; + current_head->count = lv->count; + current_head->body = (Scheme_Object *)next_head; + SCHEME_LET_FLAGS(current_head) -= SCHEME_LET_RECURSIVE; + current_head = next_head; + } else if (!scheme_env_min_use_below(env, lv->position)) { + /* End a recursive `letrec' group */ + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; + + if (rec_env_already == 2) { + Scheme_Let_Header *next_head; + group_clauses++; + group_count += lv->count; + next_head = make_header(lv->body, + current_head->count - group_count, + current_head->num_clauses - group_clauses, + SCHEME_LET_RECURSIVE); + current_head->num_clauses = group_clauses; + current_head->count = group_count; + current_head->body = (Scheme_Object *)next_head; + current_head = next_head; + } + group_clauses = 0; + group_count = 0; + } else { + group_clauses++; + group_count += lv->count; + } + } else + prev_might_invoke = 1; } } @@ -1933,23 +2350,43 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, lv->flags = flags; } - { - Scheme_Let_Header *head; - - head = MALLOC_ONE_TAGGED(Scheme_Let_Header); - head->iso.so.type = scheme_compiled_let_void_type; - head->body = first; - head->count = num_bindings; - head->num_clauses = num_clauses; - SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0) - | (star ? SCHEME_LET_STAR : 0)); + if (rec_env_already == 2) { + /* `head' is a chain of group headers; splice them into the lv + chain, and adjust coordinates in each lv->value due to + grouping */ + Scheme_Let_Header *current_head = head, *next_head = (Scheme_Let_Header *)head->body; + Scheme_Object *rhs, *next = NULL; + int num_group_clauses = 0; - first = (Scheme_Object *)head; + head->body = first; + lv = (Scheme_Compiled_Let_Value *)first; + for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)next) { + rhs = shift_compiled_expression(lv->value, + ((SCHEME_LET_FLAGS(current_head) & SCHEME_LET_RECURSIVE) + ? num_bindings - current_head->count + : num_bindings), + 0); + lv->value = rhs; + lv->position -= (num_bindings - current_head->count); + next = lv->body; + + num_group_clauses++; + if (current_head->num_clauses == num_group_clauses) { + num_bindings -= current_head->count; + current_head = next_head; + next_head = (Scheme_Let_Header *)current_head->body; + if ((i + 1) < num_clauses) { + current_head->body = lv->body; + lv->body = (Scheme_Object *)current_head; + } + num_group_clauses = 0; + } + } } - + scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); - return first; + return (Scheme_Object *)head; } static Scheme_Object * @@ -1957,14 +2394,25 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ const char *formname, int letrec, int multi, int letstar, Scheme_Comp_Env *env_already) { - Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname, *form; + Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname, *form, *pre_set; Scheme_Comp_Env *use_env, *env; Scheme_Expand_Info erec1; DupCheckRecord r; - int rec_env_already = erec[drec].env_already; + int rec_env_already = erec[drec].env_already, forward_ref_boundary; + /* If env_already == 2, then it's not a true `letrec': + it's from `letrec-values+syntax' and should be + expanded into `let' plus `letrec'. */ form = scheme_stx_taint_disarm(orig_form, NULL); + if (rec_env_already == 2) { + v = detect_traditional_letrec(form, origenv); + if (!SAME_OBJ(v, form)) { + rec_env_already = 1; + form = v; + } + } + vars = SCHEME_STX_CDR(form); if (!SCHEME_STX_PAIRP(vars)) @@ -2091,6 +2539,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ first = last = NULL; vs = vars; + forward_ref_boundary = 0; while (SCHEME_STX_PAIRP(vars)) { Scheme_Object *rhs; @@ -2100,6 +2549,9 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ name = SCHEME_STX_CAR(v); name = scheme_add_env_renames(name, env, origenv); + if (rec_env_already == 2) + forward_ref_boundary += scheme_stx_proper_list_length(name); + rhs = SCHEME_STX_CDR(v); rhs = SCHEME_STX_CAR(rhs); rhs = scheme_add_env_renames(rhs, use_env, origenv); @@ -2127,6 +2579,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ /* Pass 2: Expand */ first = last = NULL; + pre_set = scheme_null; while (SCHEME_STX_PAIRP(vars)) { Scheme_Object *rhs, *rhs_name; @@ -2137,7 +2590,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ name = SCHEME_STX_CAR(v); rhs = SCHEME_STX_CDR(v); rhs = SCHEME_STX_CAR(rhs); - + if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { rhs_name = SCHEME_STX_CAR(name); } else { @@ -2158,6 +2611,26 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ last = v; + if (rec_env_already == 2) { + /* Expansion for internal definitions: break into `let' and + `letrec' groups based on references among definitions: */ + int cnt; + cnt = scheme_stx_proper_list_length(name); + if (SCHEME_NULLP(SCHEME_CDR(first)) + && !scheme_env_min_use_below(use_env, forward_ref_boundary)) { + /* no self or forward references */ + first = scheme_datum_to_syntax(first, vs, vs, 0, 1); + pre_set = cons(cons(let_values_symbol, first), pre_set); + first = NULL; + } else if (!scheme_env_min_use_below(use_env, forward_ref_boundary - cnt)) { + /* no (further) forward references */ + first = scheme_datum_to_syntax(first, vs, vs, 0, 1); + pre_set = cons(cons(letrec_values_symbol, first), pre_set); + first = NULL; + } + forward_ref_boundary -= cnt; + } + vars = SCHEME_STX_CDR(vars); } @@ -2166,19 +2639,36 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ if (!SCHEME_STX_NULLP(vars)) scheme_wrong_syntax(NULL, vars, form, NULL); - if (!first) - first = scheme_null; + if (SCHEME_NULLP(pre_set) || first) { + if (!first) + first = scheme_null; + + first = scheme_datum_to_syntax(first, vs, vs, 0, 1); + } - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); scheme_init_expand_recs(erec, drec, &erec1, 1); erec1.value_name = erec[drec].value_name; body = expand_block(body, env, &erec1, 0); - v = SCHEME_STX_CAR(form); - v = cons(v, cons(first, body)); - v = scheme_datum_to_syntax(v, orig_form, orig_form, 0, 2); + if (SCHEME_PAIRP(pre_set)) { + if (first) + pre_set = cons(cons(letrec_values_symbol, first), pre_set); + + while (!SCHEME_NULLP(pre_set)) { + v = scheme_datum_to_syntax(SCHEME_CAR(SCHEME_CAR(pre_set)), orig_form, scheme_sys_wraps(origenv), 0, 0); + body = cons(v, cons(SCHEME_CDR(SCHEME_CAR(pre_set)), body)); + body = scheme_datum_to_syntax(body, orig_form, orig_form, 0, 2); + body = cons(body, scheme_null); + pre_set = SCHEME_CDR(pre_set); + } + + return SCHEME_CAR(body); + } else { + v = SCHEME_STX_CAR(form); + v = cons(v, cons(first, body)); + v = scheme_datum_to_syntax(v, orig_form, orig_form, 0, 2); + } return v; } @@ -3321,14 +3811,27 @@ do_letrec_syntaxes(const char *where, v = cons(letrec_values_symbol, cons(var_bindings, body)); v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); + if (!env_already) { /* i.e., not internal defn */ + /* We want non-`letrec' semantics for value bindings (i.e., sort + out the bindings into `letrec' and `let'): */ + rec[drec].env_already = 2; + } + if (rec[drec].comp) { v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); } else { + int restore = ((depth >= 0) || (depth == -2)); + + if (restore && (rec[drec].env_already == 2)) { + /* don't sort out after all, because we're keeping `letrec-values+syntaxes' */ + rec[drec].env_already = 1; + } + SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer); v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env); - if ((depth >= 0) || (depth == -2)) { - /* Pull back out the pieces we want: */ + if (restore) { + /* Add back out the pieces we want: */ Scheme_Object *formname; formname = SCHEME_STX_CAR(forms); v = scheme_stx_taint_disarm(v, NULL); @@ -5157,9 +5660,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, scheme_null); } - if (stx_start) { + if (stx_start || (mixed && !rec[drec].comp && (rec[drec].depth != -1))) { result = scheme_make_pair(letrec_syntaxes_symbol, - scheme_make_pair(stx_start, + scheme_make_pair((stx_start ? stx_start : scheme_null), scheme_make_pair(start, result))); } else { result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); @@ -5191,22 +5694,25 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!more) { /* We've converted to a letrec or letrec-values+syntaxes */ scheme_stx_seal_rib(rib); - rec[drec].env_already = 1; + rec[drec].env_already = (mixed ? 2 : 1); if (rec[drec].comp) { result = scheme_compile_expr(result, env, rec, drec); return scheme_make_pair(result, scheme_null); } else { - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) { - result = scheme_make_pair(result, scheme_null); - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); - return scheme_expand_list(result, env, rec, drec); - } else { - result = scheme_make_pair(result, scheme_null); - return scheme_datum_to_syntax(result, forms, forms, 0, 0); + if (!mixed && ((rec[drec].depth == -2) || (rec[drec].depth > 0))) { + if (SAME_OBJ(letrec_syntaxes_symbol, SCHEME_STX_VAL(SCHEME_CAR(SCHEME_STX_VAL(result))))) + result = force_traditional_letrec(result, env); } + if (rec[drec].depth > 0) + --rec[drec].depth; + if (rec[drec].depth) { + SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, + scheme_make_pair(result, scheme_null)); + result = scheme_expand_expr(result, env, rec, drec); + } + result = scheme_make_pair(result, scheme_null); + return scheme_datum_to_syntax(result, forms, forms, 0, 0); } } }