fixing define splicing for let-syntax (issue #13)

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_syntactic_p(env) = 1;
-    sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx));
+    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;
+  return analyze_let_syntax_aux(ctx, x, 1);
-  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;
 }
 
 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) {
+sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);}
-  return analyze(ctx, x);
-}
 
 static sexp_sint_t sexp_context_make_label (sexp ctx) {
   sexp_sint_t label = sexp_context_pos(ctx);

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))

tests/r5rs-tests.scm

@@ -404,11 +404,21 @@
 (test '(,@foo) (let ((unquote-splicing 1)) `(,@foo)))
 
 (test 'ok
-      (let ((... 2))
+    (let ((... 2))
-        (let-syntax ((s (syntax-rules ()
+      (let-syntax ((s (syntax-rules ()
-                          ((_ x ...) 'bad)
+                        ((_ x ...) 'bad)
-                          ((_ . r) 'ok))))
+                        ((_ . r) 'ok))))
-          (s a b c))))
+        (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))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;