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;