From 9b0224708249c61a0569e79f0c1e5b4363b656b1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 9 Jan 2014 16:34:22 +0900
Subject: [PATCH] initial explicit renaming macro prototype

---
 include/picrin/macro.h |  1 +
 src/macro.c            | 75 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 76 insertions(+)

diff --git a/include/picrin/macro.h b/include/picrin/macro.h
index 0a01e00d..f7f9c36f 100644
--- a/include/picrin/macro.h
+++ b/include/picrin/macro.h
@@ -45,6 +45,7 @@ struct pic_sc {
 
 #define pic_senv(v) ((struct pic_senv *)pic_ptr(v))
 #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
+#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
 
 struct pic_senv *pic_null_syntactic_env(pic_state *pic);
 struct pic_senv *pic_minimal_syntactic_env(pic_state *pic);
diff --git a/src/macro.c b/src/macro.c
index 0cd38949..88bb005e 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -659,6 +659,80 @@ pic_macro_identifier_eq_p(pic_state *pic)
   return pic_bool_value(pic_eq_p(x, y));
 }
 
+static pic_value
+er_macro_rename(pic_state *pic)
+{
+  pic_sym sym;
+  struct pic_senv *mac_env;
+
+  pic_get_args(pic, "m", &sym);
+
+  mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
+
+  return macroexpand(pic, pic_symbol_value(sym), mac_env);
+}
+
+static pic_value
+er_macro_compare(pic_state *pic)
+{
+  pic_sym x, y;
+  struct pic_senv *use_env;
+  pic_value a, b;
+
+  pic_get_args(pic, "mm", &x, &y);
+
+  use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
+
+  a = macroexpand(pic, pic_symbol_value(x), use_env);
+  b = macroexpand(pic, pic_symbol_value(y), use_env);
+
+  return pic_bool_value(pic_eq_p(a, b));
+}
+
+static pic_value
+er_macro_call(pic_state *pic)
+{
+  pic_value expr, use_env, mac_env;
+  struct pic_proc *rename, *compare, *cb;
+
+  pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
+
+  if (! pic_senv_p(use_env)) {
+    pic_error(pic, "unexpected type of argument 1");
+  }
+  if (! pic_senv_p(mac_env)) {
+    pic_error(pic, "unexpected type of argument 3");
+  }
+
+  rename = pic_proc_new(pic, er_macro_rename);
+  pic_proc_cv_reserve(pic, rename, 2);
+  pic_proc_cv_set(pic, rename, 0, use_env);
+  pic_proc_cv_set(pic, rename, 1, mac_env);
+
+  compare = pic_proc_new(pic, er_macro_compare);
+  pic_proc_cv_reserve(pic, compare, 2);
+  pic_proc_cv_set(pic, compare, 0, use_env);
+  pic_proc_cv_set(pic, compare, 1, mac_env);
+
+  cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
+
+  return pic_apply_argv(pic, cb, 3, expr, pic_obj_value(rename), pic_obj_value(compare));
+}
+
+static pic_value
+pic_macro_er_macro_transformer(pic_state *pic)
+{
+  struct pic_proc *cb, *proc;
+
+  pic_get_args(pic, "l", &cb);
+
+  proc = pic_proc_new(pic, er_macro_call);
+  pic_proc_cv_reserve(pic, proc, 1);
+  pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
+
+  return pic_obj_value(proc);
+}
+
 void
 pic_init_macro(pic_state *pic)
 {
@@ -667,6 +741,7 @@ pic_init_macro(pic_state *pic)
     pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
+    pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
   }
   ENDLIBRARY(pic);
 }