Merge branch 'master' into refactor-contrib

docs/libs.rst

@@ -50,6 +50,7 @@ Utility functions and syntaces for macro definition.
 - define-macro
 - gensym
 - macroexpand
+- macroexpand-1
 
 Old-fashioned macro.
 

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 */

include/picrin/lib.h

@@ -12,7 +12,7 @@ extern "C" {
 struct pic_lib {
   PIC_OBJECT_HEADER
   pic_value name;
-  struct pic_senv *senv;
+  struct pic_senv *env;
   xhash exports;
 };
 

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

src/codegen.c

@@ -51,7 +51,7 @@ static void pop_scope(analyze_state *);
 #define register_renamed_symbol(pic, state, slot, lib, id) do {         \
     pic_sym sym, gsym;                                                  \
     sym = pic_intern_cstr(pic, id);                                     \
-    if (! pic_find_rename(pic, lib->senv, sym, &gsym)) {                \
+    if (! pic_find_rename(pic, lib->env, sym, &gsym)) {                \
       pic_error(pic, "internal error! native VM procedure not found");  \
     }                                                                   \
     state->slot = gsym;                                                 \

src/gc.c

@@ -463,7 +463,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_LIB: {
     struct pic_lib *lib = (struct pic_lib *)obj;
     gc_mark(pic, lib->name);
-    gc_mark_object(pic, (struct pic_object *)lib->senv);
+    gc_mark_object(pic, (struct pic_object *)lib->env);
     break;
   }
   case PIC_TT_VAR: {

src/init.c

@@ -62,15 +62,14 @@ pic_init_core(pic_state *pic)
   pic_deflibrary ("(scheme base)") {
 
     /* load core syntaces */
-    pic->lib->senv = pic_null_syntactic_environment(pic);
+    pic->lib->env = pic_null_syntactic_environment(pic);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->env, 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->env, 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;

src/lib.c

@@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name)
   senv = pic_null_syntactic_environment(pic);
 
   lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
-  lib->senv = senv;
+  lib->env = senv;
   lib->name = name;
   xh_init_int(&lib->exports, sizeof(pic_sym));
 
@@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec)
     printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym)));
 #endif
 
-    pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
+    pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
   }
 }
 
@@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 
@@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 

src/macro.c

@@ -10,6 +10,7 @@
 #include "picrin/lib.h"
 #include "picrin/error.h"
 #include "picrin/dict.h"
+#include "picrin/cont.h"
 
 pic_sym
 pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
@@ -215,17 +216,11 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
   for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
     pic_value v = pic_car(pic, a);
 
-    if (! pic_sym_p(v)) {
-      v = macroexpand(pic, v, senv);
-    }
     if (! pic_sym_p(v)) {
       pic_error(pic, "syntax error");
     }
     pic_add_rename(pic, in, pic_sym(v));
   }
-  if (! pic_sym_p(a)) {
-    a = macroexpand(pic, a, senv);
-  }
   if (pic_sym_p(a)) {
     pic_add_rename(pic, in, pic_sym(a));
   }
@@ -258,9 +253,6 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
     }
     var = formal;
   }
-  if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
   }
@@ -288,9 +280,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   }
 
   var = pic_cadr(pic, expr);
-  if (! pic_sym_p(var)) {
-    var = macroexpand(pic, var, senv);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
   }
@@ -316,44 +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)) {
-      var = macroexpand(pic, var, senv);
-    }
-    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)
 {
@@ -424,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);
       }
@@ -497,7 +445,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  v = macroexpand(pic, expr, pic->lib->senv);
+  v = macroexpand(pic, expr, pic->lib->env);
 
 #if DEBUG
   puts("after expand:");
@@ -508,6 +456,47 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   return v;
 }
 
+static pic_value
+macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv)
+{
+  struct pic_macro *mac;
+  pic_value v, args;
+
+  if (pic_sym_p(expr)) {
+    pic_sym sym;
+
+    sym = pic_sym(expr);
+
+    if (pic_interned_p(pic, sym)) {
+      return pic_sym_value(make_identifier(pic, pic_sym(expr), senv));
+    }
+  }
+  if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
+    pic_sym sym;
+
+    sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
+
+    if ((mac = find_macro(pic, sym)) != NULL) {
+      if (mac->senv == NULL) { /* legacy macro */
+        args = pic_cdr(pic, expr);
+      }
+      else {
+        args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
+      }
+
+      pic_try {
+        v = pic_apply(pic, mac->proc, args);
+      } pic_catch {
+        pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
+      }
+
+      return v;
+    }
+  }
+
+  return pic_undef_value();     /* no expansion occurred */
+}
+
 struct pic_senv *
 pic_senv_new(pic_state *pic, struct pic_senv *up)
 {
@@ -539,7 +528,7 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym,
 {
   pic_put_rename(pic, senv, sym, rsym);
 
-  if (pic->lib && pic->lib->senv == senv) {
+  if (pic->lib && pic->lib->env == senv) {
     pic_export(pic, sym);
   }
 }
@@ -551,7 +540,7 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
 
   /* symbol registration */
   sym = pic_intern_cstr(pic, name);
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  rename = pic_add_rename(pic, pic->lib->env, sym);
   define_macro(pic, rename, macro, NULL);
 
   /* auto export! */
@@ -595,6 +584,22 @@ pic_macro_macroexpand(pic_state *pic)
   return pic_macroexpand(pic, expr);
 }
 
+static pic_value
+pic_macro_macroexpand_1(pic_state *pic)
+{
+  pic_value expr, val;
+
+  pic_get_args(pic, "o", &expr);
+
+  val = macroexpand_one(pic, expr, pic->lib->env);
+  if (pic_undef_p(val)) {
+    return pic_values2(pic, expr, pic_false_value());
+  }
+  else {
+    return pic_values2(pic, val, pic_true_value());
+  }
+}
+
 static pic_value
 pic_macro_identifier_p(pic_state *pic)
 {
@@ -645,6 +650,7 @@ pic_init_macro(pic_state *pic)
   pic_deflibrary ("(picrin macro)") {
     pic_defun(pic, "gensym", pic_macro_gensym);
     pic_defun(pic, "macroexpand", pic_macro_macroexpand);
+    pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
     pic_defun(pic, "identifier?", pic_macro_identifier_p);
     pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
     pic_defun(pic, "make-identifier", pic_macro_make_identifier);

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");

src/vm.c

@@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name)
   pic_sym sym, rename;
 
   sym = pic_intern_cstr(pic, name);
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     return SIZE_MAX;
   }
   if (! (e = xh_get_int(&pic->global_tbl, rename))) {
@@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name)
   }
 
   /* register to the senv */
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  rename = pic_add_rename(pic, pic->lib->env, sym);
 
   /* register to the global table */
   gidx = pic->glen++;