introduce legacy macros

include/picconf.h

@@ -13,6 +13,7 @@
 #define PIC_STACK_SIZE 1024
 #define PIC_IREP_SIZE 256
 #define PIC_GLOBALS_SIZE 1024
+#define PIC_MACROS_SIZE 1024
 #define PIC_SYM_POOL_SIZE 128
 #define PIC_POOL_SIZE 1024
 

include/picrin.h

@@ -30,6 +30,7 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
+  pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV;
   pic_sym sEQ, sLT, sLE, sGT, sGE;
@@ -38,9 +39,12 @@ typedef struct {
   const char **sym_pool;
   size_t slen, scapa;
 
+  /* positive for variables, negative for macros (bitnot) */
   struct xhash *global_tbl;
   pic_value *globals;
   size_t glen, gcapa;
+  struct pic_proc **macros;
+  size_t mlen, mcapa;
 
   struct pic_irep **irep;
   size_t ilen, icapa;
@@ -92,6 +96,7 @@ bool pic_parse_cstr(pic_state *, const char *, pic_value *);
 pic_value pic_apply(pic_state *pic, struct pic_proc *, pic_value);
 pic_value pic_apply_argv(pic_state *pic, struct pic_proc *, size_t, ...);
 struct pic_proc *pic_codegen(pic_state *, pic_value);
+pic_value pic_expand(pic_state *, pic_value);
 
 void pic_abort(pic_state *, const char *);
 void pic_raise(pic_state *, pic_value);

src/codegen.c

@@ -131,7 +131,7 @@ scope_lookup(codegen_state *state, const char *key, int *depth, int *idx)
  enter:
 
   e = xh_get(scope->local_tbl, key);
-  if (e) {
+  if (e && e->val >= 0) {
     if (scope->up == NULL) {	/* global */
       *depth = -1;
     }

src/expand.c

@@ -0,0 +1,127 @@
+#include <stdio.h>
+#include <assert.h>
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "xhash/xhash.h"
+
+#define FALLTHROUGH ((void)0)
+
+struct syntactic_env {
+  struct syntactic_env *up;
+
+  struct xhash *tbl;
+};
+
+static void
+define_macro(pic_state *pic, const char *name, struct pic_proc *macro)
+{
+  int idx;
+
+  idx = pic->mlen++;
+  pic->macros[idx] = macro;
+  xh_put(pic->global_tbl, name, ~idx);
+}
+
+static struct pic_proc *
+lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name)
+{
+  struct xh_entry *e;
+
+  e = xh_get(env->tbl, name);
+  if (! e)
+    return NULL;
+
+  if (e->val >= 0)
+    return NULL;
+
+  return pic->macros[~e->val];
+}
+
+pic_value
+expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
+{
+  int ai = pic_gc_arena_preserve(pic);
+
+  switch (pic_type(obj)) {
+  case PIC_TT_SYMBOL: {
+    return obj;
+  }
+  case PIC_TT_PAIR: {
+    pic_value v;
+
+    if (! pic_list_p(pic, obj))
+      return obj;
+
+    if (pic_symbol_p(pic_car(pic, obj))) {
+      struct pic_proc *macro;
+      pic_sym sym;
+
+      sym = pic_sym(pic_car(pic, obj));
+      if (sym == pic->sDEFINE_MACRO) {
+	v = pic_apply(pic, pic_codegen(pic, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)))), pic_nil_value());
+	assert(pic_proc_p(v));
+	define_macro(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cdr(pic, obj)))), pic_proc_ptr(v));
+	return pic_false_value();
+      }
+      macro = lookup_macro(pic, env, pic_symbol_name(pic, sym));
+      if (macro) {
+	v = pic_apply(pic, macro, pic_cdr(pic, obj));
+	if (pic->errmsg) {
+	  printf("macroexpand error: %s\n", pic->errmsg);
+	  abort();
+	}
+	return v;
+      }
+    }
+
+    v = pic_cons(pic, pic_car(pic, obj), pic_nil_value());
+    for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) {
+      v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), v);
+    }
+    v = pic_reverse(pic, v);
+
+    pic_gc_arena_restore(pic, ai);
+    pic_gc_protect(pic, v);
+    return v;
+  }
+  case PIC_TT_NIL:
+  case PIC_TT_BOOL:
+  case PIC_TT_FLOAT:
+  case PIC_TT_INT:
+  case PIC_TT_EOF:
+  case PIC_TT_STRING:
+  case PIC_TT_VECTOR: {
+    return obj;
+  }
+  case PIC_TT_PROC:
+  case PIC_TT_PORT:
+  case PIC_TT_ENV:
+  case PIC_TT_UNDEF:
+    pic_error(pic, "logic flaw");
+    abort();			/* unreachable */
+  }
+}
+
+pic_value
+pic_expand(pic_state *pic, pic_value obj)
+{
+  struct syntactic_env env;
+  pic_value v;
+  int ai = pic_gc_arena_preserve(pic);
+
+  env.tbl = pic->global_tbl;
+
+  v = expand(pic, obj, &env);
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, v);
+
+#if DEBUG
+  puts("expanded:");
+  pic_debug(pic, v);
+#endif
+
+  return v;
+}

src/state.c

@@ -48,6 +48,9 @@ pic_open(int argc, char *argv[], char **envp)
   pic->globals = (pic_value *)malloc(sizeof(pic_value) * PIC_GLOBALS_SIZE);
   pic->glen = 0;
   pic->gcapa = PIC_GLOBALS_SIZE;
+  pic->macros = (struct pic_proc **)malloc(sizeof(struct pic_proc *) * PIC_MACROS_SIZE);
+  pic->mlen = 0;
+  pic->mcapa = PIC_MACROS_SIZE;
 
   /* pool */
   pic->pool = (pic_value *)malloc(sizeof(pic_value) * PIC_POOL_SIZE);
@@ -71,6 +74,8 @@ pic_open(int argc, char *argv[], char **envp)
   pic->sQUASIQUOTE = pic_intern_cstr(pic, "quasiquote");
   pic->sUNQUOTE = pic_intern_cstr(pic, "unquote");
   pic->sUNQUOTE_SPLICING = pic_intern_cstr(pic, "unquote-splicing");
+  pic->sDEFINE_SYNTAX = pic_intern_cstr(pic, "define-syntax");
+  pic->sDEFINE_MACRO = pic_intern_cstr(pic, "define-macro");
   pic->sCONS = pic_intern_cstr(pic, "cons");
   pic->sCAR = pic_intern_cstr(pic, "car");
   pic->sCDR = pic_intern_cstr(pic, "cdr");