diff --git a/eval.c b/eval.c index caf129f9..c638b10e 100644 --- a/eval.c +++ b/eval.c @@ -533,6 +533,8 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_gc_var4(ref, value, tmp, env); sexp_gc_preserve4(ctx, ref, value, tmp, env); env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { res = sexp_compile_error(ctx, "bad define syntax", x); } else { @@ -606,37 +608,32 @@ static sexp analyze_define_syntax (sexp ctx, sexp x) { return res; } -static sexp analyze_let_syntax (sexp ctx, sexp x) { +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp) { sexp res; sexp_gc_var3(env, ctx2, tmp); sexp_gc_preserve3(ctx, env, ctx2, tmp); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { - res = sexp_compile_error(ctx, "bad let-syntax", x); + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); } else { env = sexp_alloc_type(ctx, env, SEXP_ENV); - sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); - sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); + sexp_env_syntactic_p(env) = 1; + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_bindings(env) = SEXP_NULL; ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); sexp_context_env(ctx2) = env; - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2); res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); } sexp_gc_release3(ctx); return res; } +static sexp analyze_let_syntax (sexp ctx, sexp x) { + return analyze_let_syntax_aux(ctx, x, 0); +} + static sexp analyze_letrec_syntax (sexp ctx, sexp x) { - sexp res; - sexp_gc_var1(tmp); - sexp_gc_preserve1(ctx, tmp); - if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { - res = sexp_compile_error(ctx, "bad letrec-syntax", x); - } else { - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); - res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); - } - sexp_gc_release1(ctx); - return res; + return analyze_let_syntax_aux(ctx, x, 1); } static sexp analyze (sexp ctx, sexp object) { @@ -736,13 +733,14 @@ static sexp analyze (sexp ctx, sexp object) { } else { res = x; } + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); sexp_gc_release4(ctx); return res; } -sexp sexp_analyze (sexp ctx, sexp x) { - return analyze(ctx, x); -} +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} static sexp_sint_t sexp_context_make_label (sexp ctx) { sexp_sint_t label = sexp_context_pos(ctx); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index b4527037..ab1e2d07 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -203,7 +203,7 @@ struct sexp_struct { } cpointer; /* runtime types */ struct { - char flags; + unsigned int syntacticp:1; sexp parent, lambda, bindings; } env; struct { @@ -544,7 +544,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) #define sexp_bytecode_data(x) ((x)->value.bytecode.data) -#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_syntactic_p(x) ((x)->value.env.syntacticp) #define sexp_env_parent(x) ((x)->value.env.parent) #define sexp_env_bindings(x) ((x)->value.env.bindings) #define sexp_env_local_p(x) (sexp_env_parent(x)) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 9c379eb2..5ad8b5b7 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -404,11 +404,21 @@ (test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) (test 'ok - (let ((... 2)) - (let-syntax ((s (syntax-rules () - ((_ x ...) 'bad) - ((_ . r) 'ok)))) - (s a b c)))) + (let ((... 2)) + (let-syntax ((s (syntax-rules () + ((_ x ...) 'bad) + ((_ . r) 'ok)))) + (s a b c)))) + +(test 'ok (let () + (let-syntax () + (define internal-def 'ok)) + internal-def)) + +(test 'ok (let () + (letrec-syntax () + (define internal-def 'ok)) + internal-def)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;