From e5da561a5d46e51a4e47702456456d183e83c285 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Tue, 4 Feb 2014 20:48:46 +0900
Subject: [PATCH] Fixing non-strict matching of identifiers to treat
let(rec)-syntax as non-top-level.
---
eval.c | 48 ++++++++++++++++++++++------------------
include/chibi/eval.h | 3 +++
include/chibi/features.h | 4 ++++
include/chibi/sexp.h | 2 ++
main.c | 7 ++++--
5 files changed, 40 insertions(+), 24 deletions(-)
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;