fix certification problems in internal-defn 'begin' and with the 'call-with-values'->'let-values' transformation
svn: r9292
This commit is contained in:
Matthew Flatt
parent
c811740d48
commit
a33562b9dc
|
|
@ -4,8 +4,6 @@
|
|||
(for-syntax scheme/base syntax/kerncase)
|
||||
(only-in mzscheme transcript-on transcript-off))
|
||||
|
||||
(provide (rename-out [r5rs:body #%r5rs:body])) ; Temporary hack!
|
||||
|
||||
(provide (for-syntax syntax-rules ...)
|
||||
(rename-out
|
||||
[mcons cons]
|
||||
|
|
@ -244,45 +242,49 @@
|
|||
(syntax-case stx (r5rs:lambda)
|
||||
((r5rs:letrec ((var1 rhs) ...) body ...)
|
||||
(andmap immediate-value? (syntax->list #'(rhs ...)))
|
||||
#'(letrec ((var1 rhs) ...) (r5rs:body body ...)))
|
||||
(syntax/loc stx (letrec ((var1 rhs) ...) (r5rs:body body ...))))
|
||||
((r5rs:letrec ((var1 init1) ...) body ...)
|
||||
#'(r5rs:letrec "generate_temp_names"
|
||||
(syntax/loc stx
|
||||
(r5rs:letrec "generate_temp_names"
|
||||
(var1 ...)
|
||||
()
|
||||
((var1 init1) ...)
|
||||
body ...))
|
||||
body ...)))
|
||||
((r5rs:letrec "generate_temp_names"
|
||||
()
|
||||
(temp1 ...)
|
||||
((var1 init1) ...)
|
||||
body ...)
|
||||
#'(let ((var1 undefined) ...)
|
||||
(syntax/loc stx
|
||||
(let ((var1 undefined) ...)
|
||||
(let ((temp1 init1) ...)
|
||||
(set! var1 temp1)
|
||||
...
|
||||
(let ()
|
||||
(r5rs:body
|
||||
body ...)))))
|
||||
body ...))))))
|
||||
((r5rs:letrec "generate_temp_names"
|
||||
(x y ...)
|
||||
(temp ...)
|
||||
((var1 init1) ...)
|
||||
body ...)
|
||||
#'(r5rs:letrec "generate_temp_names"
|
||||
(syntax/loc stx
|
||||
(r5rs:letrec "generate_temp_names"
|
||||
(y ...)
|
||||
(newtemp temp ...)
|
||||
((var1 init1) ...)
|
||||
body ...))))
|
||||
body ...)))))
|
||||
|
||||
(define-syntax (r5rs:lambda stx)
|
||||
;; Convert rest-arg list to mlist, and use r5rs:body:
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) . body)
|
||||
#'(#%plain-lambda (id ...) (r5rs:body . body))]
|
||||
(syntax/loc stx (#%plain-lambda (id ...) (r5rs:body . body)))]
|
||||
[(_ (id ... . rest) . body)
|
||||
#'(#%plain-lambda (id ... . rest)
|
||||
(syntax/loc stx
|
||||
(#%plain-lambda (id ... . rest)
|
||||
(let ([rest (list->mlist rest)])
|
||||
(r5rs:body . body)))]))
|
||||
(r5rs:body . body))))]))
|
||||
|
||||
(define-syntax (r5rs:define stx)
|
||||
;; Use r5rs:lambda
|
||||
|
|
|
|||
|
|
@ -5500,6 +5500,29 @@ static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env)
|
|||
return cnt;
|
||||
}
|
||||
|
||||
static Scheme_Object *cert_ids(Scheme_Object *orig_ids, Scheme_Object *orig)
|
||||
{
|
||||
Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL;
|
||||
|
||||
while (!SCHEME_STX_NULLP(ids)) {
|
||||
|
||||
id = SCHEME_STX_CAR(ids);
|
||||
id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1);
|
||||
|
||||
pr = scheme_make_pair(id, scheme_null);
|
||||
|
||||
if (last)
|
||||
SCHEME_CDR(last) = pr;
|
||||
else
|
||||
first = pr;
|
||||
last = pr;
|
||||
|
||||
ids = SCHEME_STX_CDR(ids);
|
||||
}
|
||||
|
||||
return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
|
||||
Scheme_Compile_Expand_Info *rec, int drec)
|
||||
|
|
@ -5579,6 +5602,9 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
/* If we don't check here, the error is in terms of `let': */
|
||||
scheme_dup_symbol_check(&r, NULL, n, "argument", name);
|
||||
|
||||
/* Propagate certifications to bound id: */
|
||||
n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1);
|
||||
|
||||
v = SCHEME_STX_CAR(rest);
|
||||
v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
|
||||
if (last)
|
||||
|
|
@ -5591,16 +5617,19 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
rest = SCHEME_STX_CDR(rest);
|
||||
}
|
||||
|
||||
body = scheme_datum_to_syntax(icons(begin_symbol, body), form,
|
||||
scheme_sys_wraps(env),
|
||||
0, 2);
|
||||
/* Copy certifications from lambda to `body'. */
|
||||
body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
|
||||
|
||||
body = scheme_datum_to_syntax(cons(let_values_symbol,
|
||||
cons(bindings,
|
||||
body)),
|
||||
cons(body, scheme_null))),
|
||||
form,
|
||||
scheme_sys_wraps(env),
|
||||
0, 2);
|
||||
|
||||
/* Copy certifications from lambda to `body'. */
|
||||
body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
|
||||
|
||||
return scheme_compile_expand_expr(body, env, rec, drec, 0);
|
||||
} else {
|
||||
#if 0
|
||||
|
|
@ -5642,18 +5671,27 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
if (SAME_OBJ(gval, scheme_lambda_syntax)
|
||||
&& SCHEME_STX_PAIRP(second)
|
||||
&& (arg_count(second, env) >= 0)) {
|
||||
Scheme_Object *lhs;
|
||||
Scheme_Object *lhs, *orig_post_first, *orig_post_second;
|
||||
orig_post_first = first;
|
||||
orig_post_second = second;
|
||||
second = SCHEME_STX_CDR(second);
|
||||
lhs = SCHEME_STX_CAR(second);
|
||||
second = SCHEME_STX_CDR(second);
|
||||
first = SCHEME_STX_CDR(first);
|
||||
first = SCHEME_STX_CDR(first);
|
||||
first = icons(begin_symbol, first);
|
||||
first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1);
|
||||
second = icons(begin_symbol, second);
|
||||
second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1);
|
||||
/* Copy certifications from lambda to body: */
|
||||
lhs = cert_ids(lhs, orig_post_second);
|
||||
first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1);
|
||||
second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1);
|
||||
/* Convert to let-values: */
|
||||
name = icons(let_values_symbol,
|
||||
icons(icons(icons(lhs, icons(icons(begin_symbol, first),
|
||||
scheme_null)),
|
||||
icons(icons(icons(lhs, icons(first, scheme_null)),
|
||||
scheme_null),
|
||||
second));
|
||||
icons(second, scheme_null)));
|
||||
form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2);
|
||||
return scheme_compile_expand_expr(form, env, rec, drec, 0);
|
||||
}
|
||||
|
|
@ -6264,8 +6302,8 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
stx_start = scheme_null; */
|
||||
if (stx_start) {
|
||||
result = scheme_make_pair(letrec_syntaxes_symbol,
|
||||
scheme_make_pair(stx_start,
|
||||
scheme_make_pair(start, result)));
|
||||
scheme_make_pair(stx_start,
|
||||
scheme_make_pair(start, result)));
|
||||
} else {
|
||||
result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result));
|
||||
}
|
||||
|
|
@ -6442,6 +6480,7 @@ scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto)
|
|||
for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) {
|
||||
a = SCHEME_CAR(ll);
|
||||
a = scheme_stx_track(a, expr, name);
|
||||
a = scheme_stx_cert(a, NULL, NULL, expr, NULL, 1);
|
||||
SCHEME_CAR(ll) = a;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -4428,6 +4428,8 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
|
|||
Scheme_Comp_Env *env,
|
||||
Scheme_Compile_Info *rec, int drec)
|
||||
{
|
||||
try_again:
|
||||
|
||||
if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
|
||||
/* If it's a begin, we have to check some more... */
|
||||
Scheme_Object *first, *val;
|
||||
|
|
@ -4437,11 +4439,12 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
|
|||
|
||||
if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) {
|
||||
/* Flatten begin: */
|
||||
Scheme_Object *rest;
|
||||
rest = SCHEME_STX_CDR(first);
|
||||
if (scheme_stx_proper_list_length(rest) > 0) {
|
||||
first = scheme_datum_to_syntax(rest, first, first, 0, 2);
|
||||
return scheme_compile_sequence(first, env, rec, drec);
|
||||
if (scheme_stx_proper_list_length(first) > 0) {
|
||||
Scheme_Object *rest;
|
||||
rest = scheme_flatten_begin(first, scheme_null);
|
||||
first = scheme_datum_to_syntax(rest, first, first, 0, 2);
|
||||
forms = first;
|
||||
goto try_again;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user