hygiene fix for nested macros, still need to clean this up

eval.c

@@ -13,6 +13,9 @@ static sexp the_interaction_env_symbol;
 static sexp the_err_handler_symbol, the_compile_error_symbol;
 static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
 
+#define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE)
+#define sexp_debug(ctx, msg, obj) (sexp_write_string(msg, sexp_current_error_port(ctx)), sexp_write(obj, sexp_current_error_port(ctx)), sexp_write_char('\n', sexp_current_error_port(ctx)))
+
 #if USE_DEBUG
 #include "debug.c"
 #else
@@ -67,7 +70,7 @@ static void env_define(sexp ctx, sexp e, sexp key, sexp value) {
   sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e));
   sexp_gc_var(ctx, tmp, s_tmp);
   sexp_gc_preserve(ctx, tmp, s_tmp);
-  if (cell != SEXP_FALSE)
+  if (sexp_truep(cell))
     sexp_cdr(cell) = value;
   else {
     tmp = sexp_cons(ctx, key, value);
@@ -92,6 +95,20 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
   return e;
 }
 
+static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) {
+  sexp_gc_var(ctx, res, s_res);
+  sexp_gc_preserve(ctx, res, s_res);
+  res = env2;
+  if (env1 && sexp_envp(env1)) {
+    res = sexp_alloc_type(ctx, env, SEXP_ENV);
+    sexp_env_parent(res) = sexp_chain_env(ctx, sexp_env_parent(env1), env2);
+    sexp_env_bindings(res) = sexp_env_bindings(env1);
+    sexp_env_lambda(res) = sexp_env_lambda(env1);
+  }
+  sexp_gc_release(ctx, res, s_res);
+  return res;
+}
+
 static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
   sexp_gc_var(ctx, res, s_res);
   sexp_gc_preserve(ctx, res, s_res);
@@ -403,7 +420,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x) {
   cell = env_cell(env, x);
   if (! cell) {
     if (sexp_synclop(x)) {
-      if (sexp_memq(ctx, x, sexp_context_fv(ctx)) != SEXP_FALSE)
+      if (sexp_truep(sexp_memq(ctx, x, sexp_context_fv(ctx))))
         env = sexp_synclo_env(x);
       x = sexp_synclo_expr(x);
     }
@@ -464,7 +481,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
   for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
     if (! sexp_idp(sexp_car(ls)))
       sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
-    else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
+    else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls))))
       sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
   /* build lambda and analyze body */
   res = sexp_make_lambda(ctx, sexp_cadr(x));
@@ -583,13 +600,14 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
       res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls));
     } else {
       proc = sexp_eval(eval_ctx, sexp_cadar(ls));
-      if (sexp_exceptionp(proc)) {
-        res = proc;
-        break;
-      } else if (sexp_procedurep(proc)) {
-        mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx));
+      if (sexp_procedurep(proc)) {
+        mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx));
         tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
         sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
+      } else {
+        res = (sexp_exceptionp(proc) ? proc
+               : sexp_compile_error(eval_ctx, "non-procedure macro:", proc));
+        break;
       }
     }
   }
@@ -619,8 +637,10 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) {
     res = sexp_compile_error(ctx, "bad let-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_parent(env) = sexp_env_parent(sexp_context_env(ctx)); */
+/*     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);
@@ -657,7 +677,7 @@ static sexp analyze (sexp ctx, sexp object) {
   x = object;
  loop:
   if (sexp_pairp(x)) {
-    if (sexp_listp(ctx, x) == SEXP_FALSE) {
+    if (sexp_not(sexp_listp(ctx, x))) {
       res = sexp_compile_error(ctx, "dotted list in source", x);
     } else if (sexp_idp(sexp_car(x))) {
       cell = env_cell(sexp_context_env(ctx), sexp_car(x));
@@ -693,15 +713,18 @@ static sexp analyze (sexp ctx, sexp object) {
             res = sexp_compile_error(ctx, "unknown core form", op); break;
           }
         } else if (sexp_macrop(op)) {
-          /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */
           tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
           tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
           tmp = sexp_cons(ctx, x, tmp);
-          x = sexp_apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)),
-                         sexp_macro_proc(op),
-                         tmp);
-          /* if (in_repl_p) sexp_debug("     => ", x, ctx); */
-          goto loop;
+          x = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+          sexp_context_env(x) = sexp_macro_env(op);
+          x = sexp_apply(x, sexp_macro_proc(op), tmp);
+          /* goto loop; */
+          /* XXXX need to handle free vars, simplify */
+          tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+          sexp_context_env(tmp)
+            = sexp_chain_env(ctx, sexp_macro_env(op), sexp_context_env(tmp));
+          res = analyze(tmp, x);
         } else if (sexp_opcodep(op)) {
           res = sexp_length(ctx, sexp_cdr(x));
           if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) {

include/chibi/sexp.h

@@ -269,6 +269,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 /***************************** predicates *****************************/
 
 #define sexp_truep(x)    ((x) != SEXP_FALSE)
+#define sexp_not(x)      ((x) == SEXP_FALSE)
 
 #define sexp_nullp(x)    ((x) == SEXP_NULL)
 #define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)

sexp.c

@@ -416,7 +416,7 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) {
     return sexp_type_exception(ctx, "not a string", str);
   if (! sexp_integerp(start))
     return sexp_type_exception(ctx, "not a number", start);
-  if (end == SEXP_FALSE)
+  if (sexp_not(end))
     end = sexp_make_integer(sexp_string_length(str));
   if (! sexp_integerp(end))
     return sexp_type_exception(ctx, "not a number", end);
@@ -723,14 +723,36 @@ void sexp_write (sexp obj, sexp out) {
     case SEXP_BYTECODE:
       sexp_write_string("#<bytecode>", out); break;
     case SEXP_ENV:
-      sexp_printf(out, "#<env %p>", obj); break;
+      sexp_printf(out, "#<env %p (%p)", obj, sexp_env_parent(obj));
+      x = sexp_env_bindings(obj);
+      if (sexp_unbox_integer(sexp_length(NULL, x)) > 5) {
+        sexp_write_char(' ', out);
+        sexp_write(sexp_caar(x), out);
+        sexp_write_string(": ", out);
+        if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x)))
+          sexp_printf(out, "%p", sexp_cdar(x));
+        else
+          sexp_write(sexp_cdar(x), out);
+        sexp_write_string(" ...", out);
+      } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) {
+        sexp_write_char(' ', out);
+        sexp_write(sexp_caar(x), out);
+        sexp_write_string(": ", out);
+        if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x)))
+          sexp_printf(out, "%p", sexp_cdar(x));
+        else
+          sexp_write(sexp_cdar(x), out);
+      }
+      sexp_write_char('>', out);
+      break;
     case SEXP_EXCEPTION:
       sexp_write_string("#<exception>", out); break;
     case SEXP_MACRO:
       sexp_write_string("#<macro>", out); break;
 #if USE_DEBUG
     case SEXP_LAMBDA:
-      sexp_write_string("#<lambda ", out);
+      /* sexp_write_string("#<lambda ", out); */
+      sexp_printf(out, "#<lambda %p ", obj);
       sexp_write(sexp_lambda_params(obj), out);
       sexp_write_char(' ', out);
       sexp_write(sexp_lambda_body(obj), out);
@@ -1140,7 +1162,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
     case '(':
       sexp_push_char(c1, in);
       res = sexp_read(ctx, in);
-      if (sexp_listp(ctx, res) == SEXP_FALSE) {
+      if (sexp_not(sexp_listp(ctx, res))) {
         if (! sexp_exceptionp(res)) {
           res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
                                 SEXP_NULL,

tests/basic/test09-hygiene.res

@@ -3,3 +3,5 @@
 3
 4
 5
+6
+outer

tests/basic/test09-hygiene.scm

@@ -23,3 +23,40 @@
                           (cons (rename 'myor) (cddr expr)))))))))
    (let ((tmp 5)) (myor #f tmp))))
 (newline)
+
+(define-syntax myor
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr))
+         #f
+         (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+               (list (rename 'if) (rename 'tmp)
+                     (rename 'tmp)
+                     (cons (rename 'myor) (cddr expr))))))))
+
+(write (let ((tmp 6)) (myor #f tmp)))
+(newline)
+
+;; (let ((x 'outer))
+;;   (let-syntax ((with-x
+;;                 (syntax-rules ()
+;;                   ((_ y expr)
+;;                    (let-syntax ((y (syntax-rules () ((_) x))))
+;;                      expr)))))
+;;     (let ((x 'inner))
+;;       (write (with-x z (z)))
+;;       (newline)))) 
+
+(let ((x 'outer))
+  (let-syntax ((with-x
+                (er-macro-transformer
+                 (lambda (form rename compare)
+                   `(let-syntax ((,(cadr form)
+                                  (er-macro-transformer
+                                   (lambda (form rename2 compare)
+                                     (rename2 'x)))))
+                      ,(caddr form))))))
+    (let ((x 'inner))
+      (write (with-x z (z)))
+      (newline)))) 
+