Merge branch 'define-is-a-macro'

piclib/CMakeLists.txt

@@ -1,4 +1,5 @@
 list(APPEND PICLIB_SCHEME_LIBS
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
 

piclib/picrin/base.scm

@@ -0,0 +1,22 @@
+(define-library (picrin base)
+  (import (rename (picrin base core) (define define*))
+          (scheme base)
+          (picrin macro))
+
+  (define-syntax define
+    (lambda (form use-env mac-env)
+      (if (symbol? (cadr form))
+          (cons (make-identifier 'define* mac-env) (cdr form))
+          (list (make-identifier 'define mac-env)
+                (car (cadr form))
+                (cons (make-identifier 'lambda mac-env)
+                      (cons (cdr (cadr form))
+                            (cddr form)))))))
+
+  (export define
+          set!
+          quote
+          lambda
+          if
+          begin
+          define-syntax))

piclib/picrin/macro.scm

@@ -1,7 +1,8 @@
 ;;; Hygienic Macros
 
 (define-library (picrin macro)
-  (import (scheme base)
+  (import (picrin base)
+          (scheme base)
           (picrin dictionary))
 
   ;; assumes no derived expressions are provided yet

piclib/scheme/base.scm

@@ -1,5 +1,9 @@
 (define-library (scheme base)
-  (import (picrin macro))
+  (import (picrin base)
+          (picrin macro))
+
+  (export define set! lambda quote
+          if begin define-syntax)
 
   ;; core syntax
 

src/init.c

@@ -62,10 +62,7 @@ pic_init_core(pic_state *pic)
 {
   size_t ai = pic_gc_arena_preserve(pic);
 
-  pic_deflibrary (pic, "(scheme base)") {
-
-    /* load core syntaces */
-    pic->lib->env = pic_null_syntactic_environment(pic);
+  pic_deflibrary (pic, "(picrin base core)") {
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
@@ -73,7 +70,9 @@ pic_init_core(pic_state *pic)
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
     pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+  }
 
+  pic_deflibrary (pic, "(scheme base)") {
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
     pic_init_port(pic); DONE;

src/macro.c

@@ -160,36 +160,24 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
 static pic_value
 macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
 {
-  pic_sym sym;
-  pic_value formal, body, var, val;
+  pic_sym sym, rename;
+  pic_value var, val;
 
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  formal = pic_cadr(pic, expr);
-  if (pic_pair_p(formal)) {
-    var = pic_car(pic, formal);
-  } else {
   if (pic_length(pic, expr) != 3) {
     pic_error(pic, "syntax error");
   }
-    var = formal;
-  }
+
+  var = pic_cadr(pic, expr);
   if (! pic_sym_p(var)) {
     pic_error(pic, "binding to non-symbol object");
   }
   sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, NULL)) {
-    pic_add_rename(pic, senv, sym);
+  if (! pic_find_rename(pic, senv, sym, &rename)) {
+    rename = pic_add_rename(pic, senv, sym);
   }
-  body = pic_cddr(pic, expr);
-  if (pic_pair_p(formal)) {
-    val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv);
-  } else {
-    val = macroexpand(pic, pic_car(pic, body), senv);
-  }
-  return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv), val);
+  val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv);
+
+  return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val);
 }
 
 static pic_value