From 7a2f8abd9c227a3d3233d1e12a7594f0a30ff90a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 20 Jul 2014 14:55:17 +0900
Subject: [PATCH] rewrite let-syntax in scheme

---
 include/picrin.h   |  4 ++--
 piclib/prelude.scm |  9 +++++++--
 src/init.c         |  1 -
 src/macro.c        | 38 --------------------------------------
 src/state.c        |  2 --
 5 files changed, 9 insertions(+), 45 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index ff0b1a78..fd3b4ca2 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -80,14 +80,14 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
-  pic_sym sDEFINE_SYNTAX, sLET_SYNTAX;
+  pic_sym sDEFINE_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
 
   pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
-  pic_sym rDEFINE_SYNTAX, rLET_SYNTAX;
+  pic_sym rDEFINE_SYNTAX;
   pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
 
   xhash syms;                   /* name to symbol */
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index e9c756b2..7049c2f0 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -271,12 +271,17 @@
                    formal)
             ,@body)))))
 
+  (define-syntax let-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       `(,(r 'letrec-syntax) ,@(cdr form)))))
+
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
           cond case else =>
           do when unless
-          letrec-syntax
+          let-syntax letrec-syntax
           _ ... syntax-error))
 
 (import (picrin core-syntax))
@@ -286,7 +291,7 @@
         and or
         cond case else =>
         do when unless
-        letrec-syntax
+        let-syntax letrec-syntax
         _ ... syntax-error)
 
 ;;; multiple value
diff --git a/src/init.c b/src/init.c
index b59e0600..56264da7 100644
--- a/src/init.c
+++ b/src/init.c
@@ -70,7 +70,6 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
diff --git a/src/macro.c b/src/macro.c
index 1d338cad..d0372540 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -305,41 +305,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return pic_none_value();
 }
 
-static pic_value
-macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  struct pic_senv *in;
-  pic_value formal, v, var, val;
-  pic_sym sym, rename;
-
-  in = pic_senv_new(pic, senv);
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  formal = pic_cadr(pic, expr);
-  if (! pic_list_p(formal)) {
-    pic_error(pic, "syntax error");
-  }
-  pic_for_each (v, formal) {
-    var = pic_car(pic, v);
-    if (! pic_sym_p(var)) {
-      pic_error(pic, "binding to non-symbol object");
-    }
-    sym = pic_sym(var);
-    if (! pic_find_rename(pic, in, sym, &rename)) {
-      rename = pic_add_rename(pic, in, sym);
-    }
-    val = pic_eval(pic, pic_cadr(pic, v));
-    if (! pic_proc_p(val)) {
-      pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var);
-    }
-    define_macro(pic, rename, pic_proc_ptr(val), senv);
-  }
-  return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in));
-}
-
 static pic_value
 macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
 {
@@ -410,9 +375,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
       else if (tag == pic->rDEFINE_SYNTAX) {
         return macroexpand_defsyntax(pic, expr, senv);
       }
-      else if (tag == pic->rLET_SYNTAX) {
-        return macroexpand_let_syntax(pic, expr, senv);
-      }
       else if (tag == pic->rLAMBDA) {
         return macroexpand_lambda(pic, expr, senv);
       }
diff --git a/src/state.c b/src/state.c
index b910baed..758bae9c 100644
--- a/src/state.c
+++ b/src/state.c
@@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE, "unquote");
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
-  register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");
@@ -128,7 +127,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rSETBANG, "set!");
   register_renamed_symbol(pic, rQUOTE, "quote");
   register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
-  register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIMPORT, "import");
   register_renamed_symbol(pic, rEXPORT, "export");