From 8a5cfbddc0315e4b55086f3a349c397ca7743c55 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 8 Apr 2009 23:07:19 +0900
Subject: [PATCH] allowing unhygienic insertion

---
 eval.c                           | 15 +++++++++------
 sexp.h                           |  3 ++-
 tests/basic/test10-unhygiene.res |  2 ++
 tests/basic/test10-unhygiene.scm | 22 ++++++++++++++++++++++
 4 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/eval.c b/eval.c
index 3f359cab..8d3faadb 100644
--- a/eval.c
+++ b/eval.c
@@ -242,6 +242,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) {
   sexp_context_lambda(res) = SEXP_FALSE;
   sexp_context_stack(res) = stack;
   sexp_context_env(res) = env;
+  sexp_context_fv(res) = SEXP_NULL;
   sexp_context_depth(res) = 0;
   sexp_context_pos(res) = 0;
   sexp_context_top(res) = 0;
@@ -256,6 +257,7 @@ static sexp sexp_child_context(sexp context, sexp lambda) {
   sexp_context_lambda(ctx) = lambda;
   sexp_context_env(ctx) = sexp_context_env(context);
   sexp_context_top(ctx) = sexp_context_top(context);
+  sexp_context_fv(ctx) = sexp_context_fv(context);
   sexp_context_tracep(ctx) = sexp_context_tracep(context);
   return ctx;
 }
@@ -326,16 +328,15 @@ static sexp analyze_seq (sexp ls, sexp context) {
 }
 
 static sexp analyze_var_ref (sexp x, sexp context) {
-  sexp cell = env_cell(sexp_context_env(context), x);
+  sexp env = sexp_context_env(context), cell;
+  cell = env_cell(env, x);
   if (! cell) {
     if (sexp_synclop(x)) {
-      cell = env_cell_create(sexp_synclo_env(x),
-                             sexp_synclo_expr(x),
-                             SEXP_UNDEF);
+      if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE)
+        env = sexp_synclo_env(x);
       x = sexp_synclo_expr(x);
-    } else {
-      cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF);
     }
+    cell = env_cell_create(env, x, SEXP_UNDEF);
   }
   if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell)))
     return sexp_compile_error("invalid use of syntax as value", sexp_list1(x));
@@ -543,6 +544,8 @@ static sexp analyze (sexp x, sexp context) {
   } else if (sexp_synclop(x)) {
     context = sexp_child_context(context, sexp_context_lambda(context));
     sexp_context_env(context) = sexp_synclo_env(x);
+    sexp_context_fv(context) = sexp_append(sexp_synclo_free_vars(x),
+                                           sexp_context_fv(context));
     x = sexp_synclo_expr(x);
     goto loop;
   } else {
diff --git a/sexp.h b/sexp.h
index a17c5433..9f8d4fe4 100644
--- a/sexp.h
+++ b/sexp.h
@@ -159,7 +159,7 @@ struct sexp_struct {
     } lit;
     /* compiler state */
     struct {
-      sexp bc, lambda, *stack, env;
+      sexp bc, lambda, *stack, env, fv;
       sexp_uint_t pos, top, depth, tailp, tracep;
     } context;
   } value;
@@ -338,6 +338,7 @@ struct sexp_struct {
 #define sexp_context_stack(x)   ((x)->value.context.stack)
 #define sexp_context_depth(x)   ((x)->value.context.depth)
 #define sexp_context_bc(x)      ((x)->value.context.bc)
+#define sexp_context_fv(x)      ((x)->value.context.fv)
 #define sexp_context_pos(x)     ((x)->value.context.pos)
 #define sexp_context_top(x)     ((x)->value.context.top)
 #define sexp_context_lambda(x)  ((x)->value.context.lambda)
diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res
index 69584714..0d174dc4 100644
--- a/tests/basic/test10-unhygiene.res
+++ b/tests/basic/test10-unhygiene.res
@@ -2,3 +2,5 @@
 1
 1
 6
+7
+8
diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm
index 90bc5ef6..c60a6bca 100644
--- a/tests/basic/test10-unhygiene.scm
+++ b/tests/basic/test10-unhygiene.scm
@@ -25,3 +25,25 @@
 (write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3)))
 (newline)
 
+(write
+ (letrec-syntax
+     ((myor
+       (er-macro-transformer
+        (lambda (expr rename compare)
+          (if (null? (cdr expr))
+              #f
+              (list (rename 'let) (list (list (rename 'it) (cadr expr)))
+                    (list (rename 'if) (rename 'it)
+                          (rename 'it)
+                          (cons (rename 'myor) (cddr expr)))))))))
+   (let ((it 7)) (myor #f it))))
+(newline)
+
+(define-syntax define-foo
+  (sc-macro-transformer
+   (lambda (form environment)
+     (make-syntactic-closure environment '(foo) `(define foo 8)))))
+
+(define-foo)
+(write foo)
+(newline)