Merge branch 'rewrite-defmacro'

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, sDEFINE_MACRO, sLET_SYNTAX;
+  pic_sym sDEFINE_SYNTAX, sLET_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, rDEFINE_MACRO, rLET_SYNTAX;
+  pic_sym rDEFINE_SYNTAX, rLET_SYNTAX;
   pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
 
   xhash syms;                   /* name to symbol */

piclib/picrin/macro.scm

@@ -124,10 +124,25 @@
                   (rename sym)))
             (f (walk inject expr) inject compare))))
 
+  (define-syntax define-macro
+    (er-macro-transformer
+     (lambda (expr r c)
+       (define formal (car (cdr expr)))
+       (define body   (cdr (cdr expr)))
+       (if (symbol? formal)
+           (list (r 'define-syntax) formal
+                 (list (r 'lambda) (list (r 'form) '_ '_)
+                       (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))
+           (list (r 'define-macro) (car formal)
+                 (cons (r 'lambda)
+                       (cons (cdr formal)
+                             body)))))))
+
   (export make-syntactic-closure
           close-syntax
           capture-syntactic-environment
           sc-macro-transformer
           rsc-macro-transformer
           er-macro-transformer
-          ir-macro-transformer))
+          ir-macro-transformer
+          define-macro))

src/macro.c

@@ -316,53 +316,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   return pic_none_value();
 }
 
-static pic_value
-macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_value var, val;
-  pic_sym sym, rename;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_car(pic, pic_cdr(pic, expr));
-  if (pic_pair_p(var)) {
-    /* FIXME: unhygienic */
-    val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
-                   pic_cons(pic, pic_cdr(pic, var),
-                            pic_cdr(pic, pic_cdr(pic, expr))));
-    var = pic_car(pic, var);
-  }
-  else {
-    if (pic_length(pic, expr) != 3) {
-      pic_error(pic, "syntax_error");
-    }
-    val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
-  }
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "syntax error");
-  }
-  sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, &rename)) {
-    rename = pic_add_rename(pic, senv, sym);
-  }
-
-  pic_try {
-    val = pic_eval(pic, val);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, rename, pic_proc_ptr(val), NULL);
-
-  return pic_none_value();
-}
-
 static pic_value
 macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
@@ -471,9 +424,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->rDEFINE_MACRO) {
-        return macroexpand_defmacro(pic, expr, senv);
-      }
       else if (tag == pic->rLET_SYNTAX) {
         return macroexpand_let_syntax(pic, expr, senv);
       }
@@ -693,10 +643,6 @@ void
 pic_init_macro(pic_state *pic)
 {
   pic_deflibrary ("(picrin macro)") {
-
-    /* export define-macro syntax */
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO);
-
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);

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, sDEFINE_MACRO, "define-macro");
   register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
@@ -129,7 +128,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, rDEFINE_MACRO, "define-macro");
   register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIMPORT, "import");