diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index 84e86bb70a..bf10766763 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -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 diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1b41e75161..8c19f1e6a0 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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) @@ -5542,7 +5565,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, origname = name; name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL); - + /* look for ((lambda (x) ...) ...); */ if (SAME_OBJ(gval, scheme_lambda_syntax)) { Scheme_Object *argsnbody; @@ -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; } diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 0a60d7588f..e70688230e 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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; } }