diff --git a/eval.c b/eval.c index d0d1c351..1c1109f1 100644 --- a/eval.c +++ b/eval.c @@ -598,7 +598,8 @@ sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) { #if SEXP_USE_STRICT_TOPLEVEL_BINDINGS #define sexp_non_local_cell_p(cell) (!cell) #else -#define sexp_non_local_cell_p(cell) (!cell || !sexp_lambdap(sexp_cdr(cell))) +#define sexp_non_local_cell_p(cell) \ + (!cell || (!sexp_lambdap(sexp_cdr(cell)) && !sexp_env_cell_syntactic_p(cell))) #endif sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) { @@ -866,7 +867,7 @@ static sexp analyze_define (sexp ctx, sexp x, int depth) { return res; } -static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx, int localp) { sexp res = SEXP_VOID, name; sexp_gc_var1(mac); sexp_gc_preserve1(eval_ctx, mac); @@ -875,25 +876,28 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { && sexp_idp(sexp_caar(ls)) && sexp_nullp(sexp_cddar(ls)))) { res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_pairp(ls) ? sexp_car(ls) : ls); break; - } else { - if (sexp_idp(sexp_cadar(ls))) - mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE); - else - mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); - if (sexp_procedurep(mac)) - mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx)); - if (!(sexp_macrop(mac)||sexp_corep(mac))) { - res = (sexp_exceptionp(mac) ? mac - : sexp_compile_error(eval_ctx, "non-procedure macro", mac)); - break; - } - name = sexp_caar(ls); - if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) - name = sexp_synclo_expr(name); - if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls))) - sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls)); - sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); } + if (sexp_idp(sexp_cadar(ls))) + mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE); + else + mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(mac)) + mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx)); + if (!(sexp_macrop(mac)||sexp_corep(mac))) { + res = (sexp_exceptionp(mac) ? mac + : sexp_compile_error(eval_ctx, "non-procedure macro", mac)); + break; + } + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls))) + sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); +#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS + if (localp) + sexp_env_cell_syntactic_p(sexp_env_cell(eval_ctx, sexp_context_env(bind_ctx), name, 0)) = 1; +#endif } sexp_gc_release1(eval_ctx); return res; @@ -904,7 +908,7 @@ static sexp analyze_define_syntax (sexp ctx, sexp x) { sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); tmp = sexp_list1(ctx, sexp_cdr(x)); - res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx); + res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx, 0); sexp_gc_release1(ctx); return res; } @@ -925,7 +929,7 @@ static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) { #endif ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); sexp_context_env(ctx2) = env; - tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2); + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2, 1); res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x), depth, 1)); } sexp_gc_release3(ctx); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 28c37af3..70e0e0f6 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -121,6 +121,9 @@ SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp); SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param); +#if SEXP_USE_RENAME_BINDINGS +SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value); +#endif SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res); SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); diff --git a/include/chibi/features.h b/include/chibi/features.h index 8f798f47..968111b2 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -428,6 +428,10 @@ #endif #endif +#ifndef SEXP_USE_SPLICING_LET_SYNTAX +#define SEXP_USE_SPLICING_LET_SYNTAX 0 +#endif + #ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES #define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6a9d91dc..ac5a5548 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -946,6 +946,8 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_bytecode_source(x) (sexp_field(x, bytecode, SEXP_BYTECODE, source)) #define sexp_bytecode_data(x) (sexp_field(x, bytecode, SEXP_BYTECODE, data)) +#define sexp_env_cell_syntactic_p(x) ((x)->syntacticp) + #define sexp_env_syntactic_p(x) ((x)->syntacticp) #define sexp_env_parent(x) (sexp_field(x, env, SEXP_ENV, parent)) #define sexp_env_bindings(x) (sexp_field(x, env, SEXP_ENV, bindings)) diff --git a/main.c b/main.c index 50e12aac..8e3bea2f 100644 --- a/main.c +++ b/main.c @@ -570,8 +570,11 @@ void run_main (int argc, char **argv) { sym = sexp_intern(ctx, "import", -1); sexp_env_define(ctx, env, sym, tmp); sym = sexp_intern(ctx, "cond-expand", -1); - tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID); - sexp_env_define(ctx, env, sym, tmp); + tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0); +#if SEXP_USE_RENAME_BINDINGS + sexp_env_rename(ctx, env, sym, tmp); +#endif + sexp_env_define(ctx, env, sym, sexp_cdr(tmp)); } #endif sexp_context_tracep(ctx) = 1;