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

change semantic of internal definitions

Browse Source 
and `letrec-syntaxes+values' --- allowing `let' in place
 of `letrec', which in turn lets the compiler optimize
 away location allocation
This commit is contained in:
Matthew Flatt 2011-07-08 14:00:41 -06:00
parent fb5c62d9d7
commit b98e1b189a
7 changed files with 717 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -586,8 +586,8 @@ binding} at @tech{phase level} 0).
@subsection[#:tag "partial-expansion"]{Partial Expansion} @subsection[#:tag "partial-expansion"]{Partial Expansion}
In certain contexts, such as an @tech{internal-definition context} or In certain contexts, such as an @tech{internal-definition context} or
@tech{module context}, forms are partially expanded to determine @tech{module context}, @deftech{partial expansion} is used to determine
whether they represent definitions, expressions, or other declaration whether forms represent definitions, expressions, or other declaration
forms. Partial expansion works by cutting off the normal recursion forms. Partial expansion works by cutting off the normal recursion
expansion when the relevant binding is for a primitive syntactic form. 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} @subsection[#:tag "intdef-body"]{Internal Definitions}
An @tech{internal-definition context} corresponds to a partial expansion step An @tech{internal-definition context} supports local definitions mixed
(see @secref["partial-expansion"]). Forms that allow internal definitions document with expressions. Forms that allow internal definitions document such
such positions using the @racket[_body] meta-variable. A form that supports internal positions using the @racket[_body] meta-variable. Definitions in an
definitions starts by expanding its first form in an internal-definition context are equivalent to local binding via
internal-definition context, but only partially. That is, it @racket[letrec-syntaxes+values]; macro expansion converts internal
recursively expands only until the form becomes one of the following: 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[ @itemize[
@item{A @racket[define-values] or @racket[define-syntaxes] form, for @item{A @racket[define-values] form: The lexical context of all
any form other than the last one: The definition form is not syntax objects for the body sequence is immediately enriched
expanded further. Instead, the next form is expanded partially, with bindings for the @racket[define-values] form. Further
and so on. The content of a @racket[begin] form is spliced into expansion of the definition is deferred, and partial expansion
the body-form sequence. After all forms are partially expanded, continues with the rest of the body.}
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.
When a @racket[define-values] form is discovered, the lexical @item{A @racket[define-syntaxes] form: The right-hand side is
context of all syntax objects for the body sequence is expanded and evaluated (as for a
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
@racket[letrec-syntaxes+values] form), and a transformer @racket[letrec-syntaxes+values] form), and a transformer
binding is installed for the body sequence before expansion binding is installed for the body sequence before partial
continues.} expansion continues with the est of the body.}
@item{A primitive expression form other than @racket[begin]: The @item{A primitive expression form other than @racket[begin]: Further
expression is expanded in an expression context, along with all expansion of the expression is deferred, and partial expansion
remaining body forms. If any definitions were found, this continues with the rest of the body.}
expansion takes place after conversion to a
@racket[letrec-values] or @racket[letrec-syntaxes+values]
form. Otherwise, the expressions are expanded immediately.}
@item{A @racket[begin] form: The sub-forms of the @racket[begin] are @item{A @racket[begin] form: The sub-forms of the @racket[begin] are
spliced into the internal-definition sequence, and partial 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] After all body forms are partially expanded, if no definitions were
or @racket[define-syntaxes] form, expansion fails with a syntax error. 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} @subsection[#:tag "mod-parse"]{Module Phases and Visits}

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

@ -1296,7 +1296,7 @@ expression.
Refers to a module-level or local binding, when @racket[id] is Refers to a module-level or local binding, when @racket[id] is
not bound as a transformer (see @secref["expansion"]). At run-time, 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. the binding.
When the expander encounters an @racket[id] that is not bound by a When the expander encounters an @racket[id] that is not bound by a
@ -1334,7 +1334,7 @@ introduces @racketidfont{#%top} identifiers.
(#%variable-reference)]]{ (#%variable-reference)]]{
Produces an opaque @deftech{variable reference} value representing the 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 variable} or @tech{module-level variable}. If no @racket[id] is
supplied, the resulting value refers to an ``anonymous'' variable supplied, the resulting value refers to an ``anonymous'' variable
defined within the enclosing context (i.e., within the enclosing 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 ...+)]]{ (let proc-id ([id init-expr] ...) body ...+)]]{
The first form evaluates the @racket[val-expr]s left-to-right, creates 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 locations. It then evaluates the @racket[body]s, in which the
@racket[id]s are bound. The last @racket[body] expression is in @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 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 ...+)]{ @defform[(let* ([id val-expr] ...) body ...+)]{
Similar to @racket[let], but evaluates the @racket[val-expr]s one by 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 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 as well as the @racket[body]s, and the @racket[id]s need not be
distinct; later bindings shadow earlier bindings. distinct; later bindings shadow earlier bindings.
@ -1635,7 +1635,7 @@ distinct; later bindings shadow earlier bindings.
@defform[(letrec ([id val-expr] ...) body ...+)]{ @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 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[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 @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 @defform[(let-values ([(id ...) val-expr] ...) body ...+)]{ Like
@racket[let], except that each @racket[val-expr] must produce as many @racket[let], except that each @racket[val-expr] must produce as many
values as corresponding @racket[id]s, otherwise the 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. @racket[id], all of which are bound in the @racket[body]s.
@mz-examples[ @mz-examples[
@ -1664,7 +1664,7 @@ values as corresponding @racket[id]s, otherwise the
@defform[(let*-values ([(id ...) val-expr] ...) body ...+)]{ Like @defform[(let*-values ([(id ...) val-expr] ...) body ...+)]{ Like
@racket[let*], except that each @racket[val-expr] must produce as many @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 for each @racket[id], all of which are bound in the later
@racket[val-expr]s and in the @racket[body]s. @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 @defform[(letrec-values ([(id ...) val-expr] ...) body ...+)]{ Like
@racket[letrec], except that each @racket[val-expr] must produce as @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 created for each @racket[id], all of which are initialized to
@|undefined-const| and bound in all @racket[val-expr]s @|undefined-const| and bound in all @racket[val-expr]s
and in the @racket[body]s. and in the @racket[body]s.
@ -1738,18 +1738,40 @@ within all @racket[trans-expr]s.}
([(val-id ...) val-expr] ...) ([(val-id ...) val-expr] ...)
body ...+)]{ body ...+)]{
Combines @racket[letrec-syntaxes] with @racket[letrec-values]: each Combines @racket[letrec-syntaxes] with a variant of
@racket[trans-id] and @racket[val-id] is bound in all @racket[letrec-values]: each @racket[trans-id] and @racket[val-id] is
@racket[trans-expr]s and @racket[val-expr]s. bound in all @racket[trans-expr]s and @racket[val-expr]s.
The @racket[letrec-syntaxes+values] form is the core form for local The @racket[letrec-syntaxes+values] form is the core form for local
compile-time bindings, since forms like @racket[letrec-syntax] and 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] 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[letrec-syntaxes+values] can appear in the result of
@racket[local-expand] with an empty stop list. @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 See also @racket[local], which supports local bindings with
@racket[define], @racket[define-syntax], and more.} @racket[define], @racket[define-syntax], and more.}
@ -1760,9 +1782,9 @@ See also @racket[local], which supports local bindings with
@defform[(local [definition ...] body ...+)]{ @defform[(local [definition ...] body ...+)]{
Like @racket[letrec], except that the bindings are expressed in the Like @racket[letrec-syntaxes+values], except that the bindings are
same way as in the top-level or in a module body: using expressed in the same way as in the top-level or in a module body:
@racket[define], @racket[define-values], @racket[define-syntax], using @racket[define], @racket[define-values], @racket[define-syntax],
@racket[struct], etc. Definitions are distinguished from @racket[struct], etc. Definitions are distinguished from
non-definitions by partially expanding @racket[definition] forms (see non-definitions by partially expanding @racket[definition] forms (see
@secref["partial-expansion"]). As in the top-level or in a module @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 Like @racket[(let () defn-or-expr ...)] for an
@tech{internal-definition context} sequence, except that an expression @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 The @racket[#%stratified-body] form is useful for implementing
syntactic forms or languages that supply a more limited kind of syntactic forms or languages that supply a more limited kind of

35
collects/tests/racket/optimize.rktl
View File

@ -1112,6 +1112,41 @@
[y (lambda () (x))]) [y (lambda () (x))])
(list (x) (y) h))))) (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) (test-comp '(procedure? add1)
#t) #t)
(test-comp '(procedure? (lambda (x) x)) (test-comp '(procedure? (lambda (x) x))

5
collects/tests/racket/stx.rktl
View File

@ -689,8 +689,9 @@
(test #t has-stx-property? (expand #'(let () (define-struct x (a)) 12)) #f 'define-struct 'origin) (test #t has-stx-property? (expand #'(let () (define-struct x (a)) 12)) #f 'define-struct 'origin)
;; Disappearing syntax decls: ;; 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-syntax x 1) (define y 12) 10)) 'let-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 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 #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) (test #f has-stx-property? (expand #'(fluid-let-syntax ([x 1]) 10)) 'let-values 'x 'disappeared-binding)

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

@ -1388,6 +1388,54 @@
(test #t exn? (caar (map try (list pipeline2))))) (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 "#<undefined>\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) (report-errs)

4
doc/release-notes/racket/HISTORY.txt
View File

@ -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 Version 5.1.2, July 2011
Replaced syntax certificates with syntax taints: Replaced syntax certificates with syntax taints:
Added syntax-tainted?, syntax-arm, syntax-disarm, syntax-rearm, Added syntax-tainted?, syntax-arm, syntax-disarm, syntax-rearm,

596
src/racket/src/compile.c
View File

@ -1676,6 +1676,365 @@ case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand
/* let, let-values, letrec, etc. */ /* 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 <last-id> (#%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 * static Scheme_Object *
gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, 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 rec_env_already = rec[drec].env_already;
int rev_bind_order = recursive; int rev_bind_order = recursive;
int post_bind = !recursive && !star; int post_bind = !recursive && !star;
Scheme_Let_Header *head;
form = scheme_stx_taint_disarm(form, NULL); 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); i = scheme_stx_proper_list_length(form);
if (i < 3) if (i < 3)
scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL)); 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) { 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; lv = (Scheme_Compiled_Let_Value *)first;
for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
Scheme_Object *ce, *rhs; Scheme_Object *ce, *rhs;
@ -1906,14 +2282,55 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
lv->value = ce; lv->value = ce;
/* Record the fact that this binding doesn't use any or later /* 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 break bindings into smaller sets based on this
information. */ information; otherwise, the `let' optimizer and resolver
if (!scheme_env_check_reset_any_use(env) may do so, but we have to be more conservative as reflected
&& !scheme_might_invoke_call_cc(ce)) by scheme_might_invoke_call_cc(). */
SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; if ((rec_env_already == 2) /* int def: semantics is `let' */
if (!scheme_env_min_use_below(env, lv->position)) || (!prev_might_invoke
SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; && !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; lv->flags = flags;
} }
{ if (rec_env_already == 2) {
Scheme_Let_Header *head; /* `head' is a chain of group headers; splice them into the lv
chain, and adjust coordinates in each lv->value due to
head = MALLOC_ONE_TAGGED(Scheme_Let_Header); grouping */
head->iso.so.type = scheme_compiled_let_void_type; Scheme_Let_Header *current_head = head, *next_head = (Scheme_Let_Header *)head->body;
head->body = first; Scheme_Object *rhs, *next = NULL;
head->count = num_bindings; int num_group_clauses = 0;
head->num_clauses = num_clauses;
SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0)
| (star ? SCHEME_LET_STAR : 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); scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1);
return first; return (Scheme_Object *)head;
} }
static Scheme_Object * 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, const char *formname, int letrec, int multi, int letstar,
Scheme_Comp_Env *env_already) 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_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1; Scheme_Expand_Info erec1;
DupCheckRecord r; 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); 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); vars = SCHEME_STX_CDR(form);
if (!SCHEME_STX_PAIRP(vars)) 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; first = last = NULL;
vs = vars; vs = vars;
forward_ref_boundary = 0;
while (SCHEME_STX_PAIRP(vars)) { while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs; 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_STX_CAR(v);
name = scheme_add_env_renames(name, env, origenv); 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_CDR(v);
rhs = SCHEME_STX_CAR(rhs); rhs = SCHEME_STX_CAR(rhs);
rhs = scheme_add_env_renames(rhs, use_env, origenv); 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 */ /* Pass 2: Expand */
first = last = NULL; first = last = NULL;
pre_set = scheme_null;
while (SCHEME_STX_PAIRP(vars)) { while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs, *rhs_name; 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); name = SCHEME_STX_CAR(v);
rhs = SCHEME_STX_CDR(v); rhs = SCHEME_STX_CDR(v);
rhs = SCHEME_STX_CAR(rhs); rhs = SCHEME_STX_CAR(rhs);
if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) {
rhs_name = SCHEME_STX_CAR(name); rhs_name = SCHEME_STX_CAR(name);
} else { } else {
@ -2158,6 +2611,26 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
last = v; 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); 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)) if (!SCHEME_STX_NULLP(vars))
scheme_wrong_syntax(NULL, vars, form, NULL); scheme_wrong_syntax(NULL, vars, form, NULL);
if (!first) if (SCHEME_NULLP(pre_set) || first) {
first = scheme_null; 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_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
scheme_init_expand_recs(erec, drec, &erec1, 1); scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = erec[drec].value_name; erec1.value_name = erec[drec].value_name;
body = expand_block(body, env, &erec1, 0); body = expand_block(body, env, &erec1, 0);
v = SCHEME_STX_CAR(form); if (SCHEME_PAIRP(pre_set)) {
v = cons(v, cons(first, body)); if (first)
v = scheme_datum_to_syntax(v, orig_form, orig_form, 0, 2); 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; return v;
} }
@ -3321,14 +3811,27 @@ do_letrec_syntaxes(const char *where,
v = cons(letrec_values_symbol, cons(var_bindings, body)); v = cons(letrec_values_symbol, cons(var_bindings, body));
v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); 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) { if (rec[drec].comp) {
v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env);
} else { } 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); 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); v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env);
if ((depth >= 0) || (depth == -2)) { if (restore) {
/* Pull back out the pieces we want: */ /* Add back out the pieces we want: */
Scheme_Object *formname; Scheme_Object *formname;
formname = SCHEME_STX_CAR(forms); formname = SCHEME_STX_CAR(forms);
v = scheme_stx_taint_disarm(v, NULL); v = scheme_stx_taint_disarm(v, NULL);
@ -5157,9 +5660,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
scheme_null); scheme_null);
} }
if (stx_start) { if (stx_start || (mixed && !rec[drec].comp && (rec[drec].depth != -1))) {
result = scheme_make_pair(letrec_syntaxes_symbol, 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))); scheme_make_pair(start, result)));
} else { } else {
result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); 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) { if (!more) {
/* We've converted to a letrec or letrec-values+syntaxes */ /* We've converted to a letrec or letrec-values+syntaxes */
scheme_stx_seal_rib(rib); scheme_stx_seal_rib(rib);
rec[drec].env_already = 1; rec[drec].env_already = (mixed ? 2 : 1);
if (rec[drec].comp) { if (rec[drec].comp) {
result = scheme_compile_expr(result, env, rec, drec); result = scheme_compile_expr(result, env, rec, drec);
return scheme_make_pair(result, scheme_null); return scheme_make_pair(result, scheme_null);
} else { } else {
if (rec[drec].depth > 0) if (!mixed && ((rec[drec].depth == -2) || (rec[drec].depth > 0))) {
--rec[drec].depth; if (SAME_OBJ(letrec_syntaxes_symbol, SCHEME_STX_VAL(SCHEME_CAR(SCHEME_STX_VAL(result)))))
if (rec[drec].depth) { result = force_traditional_letrec(result, env);
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 (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);
} }
} }
} }