C でマクロ展開系を実装してみる

というわけで，マクロを実装しよう．インタプリタは他の人が書いてくれるだろうし，L は C よりも低レベルな言語だから，トランスレートは楽勝だ．

とりあえず，構文木を作って，マクロが出てきたら展開できる限り展開するだけ．マクロが呼び出されていたら，マクロの構文木の仮引数を全て実引数に置換して，の場に再帰的に展開する (マクロの再帰的定義は許してない．条件付き展開はサポートしてないので，無限に展開され続ける)．

lexical scope の言語だから，リード時に全ての変数や関数の束縛関係が決まる．なので全てグローバルに一意なIDにリネーミング (α変換) する．これで，C とかに変換するとき，全ての定義を無条件にトップレベルに持ってきても大丈夫になる (ただし，古典的なマクロなので，展開時の変数名の衝突には気を付けないといけない)

入力例 (test.l)

; sample L program
(macro (clear X)
       (begin
         (def (loop)
            (if (nzero? X) (begin (sub1 X) (loop))))
         (loop)))

(macro (<-- Y X)
       (begin
         (def Z)
         (def (g)
           (if (nzero? Z)
               (begin (add1 X) (sub1 Z) (g))))
         (def (f)
           (if (nzero? X)
               (begin (add1 Y) (add1 Z) (sub1 X) (f))
               (g)))
         (clear Y)
         (f)))
  
(begin (def A)
       (def B)
       (def C)
       (def (f) (begin (def Z) (sub1 Z) (f)))
       (if (nzero? A) (sub1 B))
       (f)
       (<-- A B)
       (if (nzero? A) (sub1 A) (add1 B))
       (begin (def A)
              (def A2)
              (begin  (def B1)
                      (def B2)
                      (add1 B1)
                      (sub1 B2))
              (sub1 A)
              (add1 C))
       (add1 A))

実行例．たぶん ANSI 準拠の C コンパイラなら何でもコンパイルできるはず (Debian と MinGW の gcc で確認)．

$ gcc -Wall -ansi -pedantic-errors l.c
$ ./a.exe test.l 
(macro (m0 V0)
       (begin 
              (def (f0)
                   (if (nzero? V0)
                       (begin 
                              (sub1 V0)
                              (f0))))
              (f0)))
(macro (m1 V1 V2)
       (begin 
              (def V3)
              (def (f1)
                   (if (nzero? V3)
                       (begin 
                              (add1 V2)
                              (sub1 V3)
                              (f1))))
              (def (f2)
                   (if (nzero? V2)
                       (begin 
                              (add1 V1)
                              (add1 V3)
                              (sub1 V2)
                              (f2))
                       (f1)))
              ; macro (m0 V1) expanded
              (begin 
                     (def (f0)
                          (if (nzero? V1)
                              (begin 
                                     (sub1 V1)
                                     (f0))))
                     (f0))
              (f2)))
(begin 
       (def V4)
       (def V5)
       (def V6)
       (def (f3)
            (begin 
                   (def V7)
                   (sub1 V7)
                   (f3)))
       (if (nzero? V4)
           (sub1 V5))
       (f3)
       ; macro (m1 V4 V5) expanded
       (begin 
              (def V3)
              (def (f1)
                   (if (nzero? V3)
                       (begin 
                              (add1 V5)
                              (sub1 V3)
                              (f1))))
              (def (f2)
                   (if (nzero? V5)
                       (begin 
                              (add1 V4)
                              (add1 V3)
                              (sub1 V5)
                              (f2))
                       (f1)))
              ; macro (m0 V1) expanded
              (begin 
                     (def (f0)
                          (if (nzero? V1)
                              (begin 
                                     (sub1 V1)
                                     (f0))))
                     (f0))
              (f2))
       (if (nzero? V4)
           (sub1 V4)
           (add1 V5))
       (begin 
              (def V8)
              (def V9)
              (begin 
                     (def V10)
                     (def V11)
                     (add1 V10)
                     (sub1 V11))
              (sub1 V8)
              (add1 V6))
       (add1 V4))

C で 600 行ちょいで書けた．真面目に条件分岐で展開を制御したりしようとすると，対象言語の L よりも高度なインタプリタが必要になる．そもそも，L がいらなくなる．条件分岐が入ったマクロだけで，計算可能な関数が全て計算できるようになる．反復と停止は再帰的にマクロを定義すれば実現できる．

---

#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include <string.h>

/*
 * Programming Language L Specification
 *
 * M ::= (macro (m X1 ... Xn) P)
 *
 * P ::= C | (begin D1 ... Dm P1 ... Pn)
 * D ::= (def X)  | (def (f) P)
 * C ::= (add1 X) | (sub1 X) | (if (nzero? X) P1 P2) | (if (nzero? X) P) | (f)
 *
 * data type ::= Natural Number
 *
 */

enum Tag {
  Tag_Var,
  Tag_Nut,
  Tag_Begin,
  Tag_VarDef,
  Tag_FunDef,
  Tag_FunCall,
  Tag_MacroDef,
  Tag_MacroCall,
  Tag_Add1,
  Tag_Sub1,
  Tag_If
};

enum Tok {
  Tok_NULL,  /* 0 */
  Tok_LB,    /* ( */
  Tok_RB,    /* ) */
  Tok_Macro,
  Tok_Num,
  Tok_Name,
  Tok_Begin,
  Tok_Def,
  Tok_Add1,
  Tok_Sub1,
  Tok_If,
  Tok_NZero
};

typedef struct tree {
  enum Tag    tag;
  struct tree *next;
} tree;

typedef struct Var {
  enum Tag tag;
  tree     *next;
  char     *name;
  unsigned id;
} Var;

typedef struct Nut {
  enum Tag tag;
  tree     *next;
  unsigned nut;
} Nut;

typedef struct Begin {
  enum Tag     tag;
  tree         *next;
  struct Begin *chain;
  tree         *defs;
  tree         *progs;
} Begin;

typedef struct VarDef {
  enum Tag tag;
  tree     *next;
  Var      *var;
} VarDef;

typedef struct FunDef {
  enum Tag tag;
  tree     *next;
  char     *name;
  unsigned id;
  tree     *body;
} FunDef;

typedef struct Arith {
  enum Tag tag;
  tree     *next;
  VarDef   *vardef;
} Arith;

typedef struct If {
  enum Tag tag;
  tree     *next;
  VarDef   *cond;
  tree     *seq;
  tree     *alt;
} If;

typedef struct FunCall {
  enum Tag tag;
  tree     *next;
  char     *name;
  FunDef   *func;
} FunCall;

typedef struct MacroDef {
  enum Tag tag;
  tree     *next;
  char     *name;
  unsigned id;
  tree     *args;
  tree     *body;
} MacroDef;

typedef struct MacroCall {
  enum Tag tag;
  tree     *next;
  char     *name;
  tree     *args;
  MacroDef *macro;
} MacroCall;

static void expect(enum Tok t);
static void *xmalloc(size_t size);
static void unget_tok(enum Tok t);
static enum Tok get_tok();
static const char* tok_to_str(enum Tok t);
static tree *read();
static tree *read_prog();
static tree *read_var();
static tree *read_arith(enum Tok t);
static tree *new_var();
static int  isNut();
static tree *read_nut();
static tree *read_begin();
static tree *read_vardef();
static tree *read_fundef();
static tree *read_if();
static tree *read_call();
static tree *read_macrodef();
static tree *append(tree *l, tree *e);
static void pprint(tree *p);
static void pprint_indent(unsigned n);
static void pprint_prog(tree *p, unsigned indent);
static void load(const char* filename);

#define MAX_BUF_LEN 1024
static char      global_variable_buffer[MAX_BUF_LEN];
static unsigned  global_variable_variable_id;
static unsigned  global_variable_function_id;
static unsigned  global_variable_macro_id;
static MacroDef *global_variable_macro_definitions;
static Begin    *global_variable_current_binding;

static void expect(enum Tok t) {
  enum Tok t1 = get_tok();
  if(t != t1) {
    fprintf(stderr, "Parse Error : expect %s But %s !\n", tok_to_str(t)
                                                        , tok_to_str(t1));
    exit(EXIT_FAILURE);
  }
}

static void *xmalloc(size_t size) {
  void *mem = malloc(size);
  if(!mem) {
    fprintf(stderr, "melloc failure ...\n");
    exit(EXIT_FAILURE);
  }
  memset(mem, 0x00, size);
  return mem;
}

static tree *append(tree *l, tree *e) {
  tree *t = l;
  if(!l) return e;
  while(l->next) l = l->next;
  l->next = e;
  return t;
}

static tree *read_macrodef() {
  enum Tok t = get_tok();
  MacroDef *m = xmalloc(sizeof(MacroDef));
  unsigned len;
  /* (macro (name X1, ..., Xn) P)
                || def
     (macro name (begin (def X1) ... (def Xn) P)) */
  Begin *b = xmalloc(sizeof(Begin));
  m->tag = Tag_MacroDef;
  m->id = global_variable_macro_id++;
  b->tag = Tag_Begin;
  b->chain = global_variable_current_binding;
  global_variable_current_binding = b;
  if(Tok_LB != t)
    goto parse_error;
  expect(Tok_Name);
  len = strlen(global_variable_buffer);
  m->name = xmalloc(len + 1);
  strcpy(m->name, global_variable_buffer);
  t = get_tok();
  while(Tok_RB != t) {
    m->args = append(m->args, read_vardef());
    t = get_tok();
  }
  b->defs = m->args;
  expect(Tok_LB);
  m->body = read_prog();
  global_variable_current_binding = b->chain;
  free(b);
  expect(Tok_RB);
  return (tree *)m;
parse_error :
  fprintf(stderr, "token %s : Parse Error in read_macrodef()\n", tok_to_str(t));
  exit(EXIT_FAILURE);
}

static tree *read_nut() {
  unsigned v = atoi(global_variable_buffer);
  Nut *n = xmalloc(sizeof(Nut));
  n->tag = Tag_Nut;
  n->nut = v;
  return (tree *)n;
}

static tree *read_begin() {
  enum Tok t = get_tok();
  Begin *b = xmalloc(sizeof(Begin));
  b->tag = Tag_Begin;
  /* Begin Node chains (binding levels)
     (new variable definition only occurs in Begin Node) */
  b->chain = global_variable_current_binding;
  global_variable_current_binding = b;
  if(Tok_LB != t)
    goto parse_error;
  t = get_tok();
  while(Tok_Def == t) {
    t = get_tok();
    if(Tok_LB == t) {
      tree *fd;
      expect(Tok_Name);
      fd = read_fundef();
      b->defs = append(b->defs, fd);
      /* for recursive definition (in self function body) */
      expect(Tok_LB);
      ((FunDef *)fd)->body = read_prog();
    } else if(Tok_Name == t)
      b->defs = append(b->defs, read_vardef());
    else
      goto parse_error;
    /* (def X) | (def (f) P) */
    expect(Tok_RB);
    expect(Tok_LB);
    t = get_tok(); /* def */
  }
  unget_tok(t);
  while(Tok_RB != t) {
    b->progs = append(b->progs, read_prog());
    t = get_tok();
  }
  global_variable_current_binding = b->chain;
  return (tree *)b;
parse_error :
  fprintf(stderr, "token %s : Parse Error in read_begin()\n", tok_to_str(t));
  exit(EXIT_FAILURE);
}

tree *read_vardef() {
  VarDef *vd = xmalloc(sizeof(VarDef));
  vd->tag = Tag_VarDef;
  vd->var = (Var *)new_var();
  return (tree *)vd;
}

static tree *read_fundef() {
  unsigned len = strlen(global_variable_buffer);
  FunDef *fd = xmalloc(sizeof(FunDef));
  fd->tag = Tag_FunDef;
  fd->name = xmalloc(len + 1);
  strcpy(fd->name, global_variable_buffer);
  expect(Tok_RB); /* only : (def (fun) */
  fd->id = global_variable_function_id++;
  return (tree *)fd;
}

/* lookup variable (must be declared before) */
static tree *read_var() {
  Begin *current_binding = global_variable_current_binding;
  tree *def;
  do {
    for(def = current_binding->defs; def; def = def->next) {
      if(Tag_VarDef == def->tag
          && strcmp(global_variable_buffer, ((VarDef *)def)->var->name) == 0)
        return def;
    }
  } while((current_binding = current_binding->chain));
  fprintf(stderr, "Parse Error : variable %s can't find in this scope.\n",
      global_variable_buffer);
  exit(EXIT_FAILURE);
}

static tree *new_var() {
  unsigned len = strlen(global_variable_buffer);
  Var *v = xmalloc(sizeof(Var));
  v->tag = Tag_Var;
  v->name = xmalloc(len + 1);
  strcpy(v->name, global_variable_buffer);
  v->id = global_variable_variable_id++;
  return (tree *)v;
}

static tree *read_if() {
  enum Tok t;
  /* (if (nzero? X) P) | (if (nzero? X) P1 P2) */
  If *i = xmalloc(sizeof(If));
  i->tag = Tag_If;
  expect(Tok_LB);
  expect(Tok_NZero);
  expect(Tok_Name);
  i->cond = (VarDef *)read_var();
  expect(Tok_RB);
  expect(Tok_LB);
  i->seq = read_prog();
  t = get_tok();
  if(Tok_LB == t) {
    i->alt = read_prog();
    t = get_tok();
  }
  if(Tok_RB != t) {
    fprintf(stderr, "token %s : Parse Error in read_if()\n", tok_to_str(t));
    exit(EXIT_FAILURE);
  }
  return (tree *)i;
}

static int isNut() {
  unsigned i;
  for(i = 0; '\0' != global_variable_buffer[i]; i++) {
    if(!isdigit(global_variable_buffer[i]))
      return 0;
  }
  return 1;
}

static tree *read_call() {
  Begin *current_binding = global_variable_current_binding;
  tree *def;
  unsigned len = strlen(global_variable_buffer);
  /* lookup macro first */
  for(def = (tree *)global_variable_macro_definitions; def; def = def->next) {
    if(strcmp(global_variable_buffer, ((MacroDef *)def)->name) == 0) {
      enum Tok t;
      MacroCall *mc = xmalloc(sizeof(MacroCall));
      mc->tag = Tag_MacroCall;
      mc->name = xmalloc(len + 1);
      strcpy(mc->name, global_variable_buffer);
      mc->macro = (MacroDef *)def;
      t = get_tok();
      while(Tok_RB != t) {
        if(isNut())
          mc->args = append(mc->args, read_nut());
        else
          mc->args = append(mc->args, (tree *)(((VarDef *)read_var())->var));
        t = get_tok();
      }
      return (tree *)mc;
    }
  }
  /* lookup function */
  do {
    for(def = current_binding->defs; def; def = def->next) {
      if(Tag_FunDef == def->tag
          && strcmp(global_variable_buffer, ((FunDef *)def)->name) == 0) {
        FunCall *fc = xmalloc(sizeof(FunCall));
        fc->tag = Tag_FunCall;
        fc->name = xmalloc(len + 1);
        strcpy(fc->name, global_variable_buffer);
        fc->func = (FunDef *)def;
        expect(Tok_RB);  /*puts(tok_to_str(t = get_tok()));*/
        return (tree *)fc;
      }
    }
  } while((current_binding = current_binding->chain));
  fprintf(stderr, "Parse Error : function %s can't find in this scope.\n",
      global_variable_buffer);
  exit(EXIT_FAILURE);
}

static tree *read_arith(enum Tok t) {
  Arith *a = xmalloc(sizeof(Arith));
  if(Tok_Add1 == t)
    a->tag = Tag_Add1;
  else
    a->tag = Tag_Sub1;
  expect(Tok_Name);
  a->vardef = (VarDef *)read_var();
  expect(Tok_RB);
  return (tree *)a;
}

static tree *read_prog() {
  enum Tok t = get_tok();
  if(EOF == t)
    return NULL;
  else if(Tok_Macro == t)
    return read_macrodef();
  else if(Tok_Begin == t)
    return read_begin();
  else if(Tok_Add1 == t || Tok_Sub1 == t)
    return read_arith(t);
  else if(Tok_If == t)
    return read_if();
  else if(Tok_Name == t)
    /* macro OR function call */
    return read_call();
  fprintf(stderr, "token %s : Parse Error in read_prog()\n", tok_to_str(t));
  exit(EXIT_FAILURE);
}

static const char* tok_to_str(enum Tok t) {
  switch(t) {
    case Tok_LB    : return "(";
    case Tok_RB    : return ")";
    case Tok_Macro : return "macro";
    case Tok_Begin : return "begin";
    case Tok_Def   : return "def";
    case Tok_Add1  : return "add1";
    case Tok_Sub1  : return "sub1";
    case Tok_If    : return "if";
    case Tok_NZero : return "nzero?";
    case Tok_Name  : return global_variable_buffer;
    default : fprintf(stderr, "Error in tok_to_str() : invalid token!\n");
              exit(EXIT_FAILURE);
  }
}

static void pprint(tree *p) {
  pprint_prog(p, 0);
}

static void pprint_indent(unsigned n) {
  for(; n; n--)
    putchar(' ');
}

static void pprint_prog(tree *p, unsigned indent) {
  pprint_indent(indent);
  if(Tag_Add1 == p->tag) {
    printf("(add1 V%d)", ((Arith *)p)->vardef->var->id);
  } else if(Tag_Sub1 == p->tag) {
    printf("(sub1 V%d)", ((Arith *)p)->vardef->var->id);
  } else if(Tag_MacroDef == p->tag) {
    tree *tmp;
    printf("(macro (m%d", ((MacroDef *)p)->id);
    for(tmp = ((MacroDef *)p)->args; tmp ; tmp = tmp->next) {
      putchar(' ');
      printf("V%d", ((VarDef *)tmp)->var->id);
    }
    puts(")");
    pprint_prog(((MacroDef *)p)->body, indent + 7);
    putchar(')');
  } else if(Tag_Begin == p->tag) {
    tree *tmp;
    printf("(begin ");
    for(tmp = ((Begin *)p)->defs; tmp ; tmp = tmp->next) {
      putchar('\n');
      pprint_indent(indent + 7);
      if(Tag_VarDef == tmp->tag)
        printf("(def V%d)", ((VarDef *)tmp)->var->id);
      else if(Tag_FunDef == tmp->tag) {
        printf("(def (f%d)\n", ((FunDef *)tmp)->id);
        pprint_prog(((FunDef *)tmp)->body, indent + 12);
        putchar(')');
      }
    }
    for(tmp = ((Begin *)p)->progs; tmp ; tmp = tmp->next) {
      putchar('\n');
      pprint_prog(tmp, indent + 7);
    }
    putchar(')');
  } else if(Tag_If == p->tag) {
    printf("(if (nzero? V%d)\n", ((If *)p)->cond->var->id);
    pprint_prog(((If *)p)->seq, indent + 4);
    if(((If *)p)->alt) {
      putchar('\n');
      pprint_prog(((If *)p)->alt, indent + 4);
    }
    putchar(')');
  } else if(Tag_MacroCall == p->tag) {
    tree *tmp, *param;
    MacroDef *m = ((MacroCall *)p)->macro;
    printf("; macro (m%d", m->id);
    for(tmp = ((MacroCall *)p)->args; tmp ; tmp = tmp->next) {
      putchar(' ');
      if(Tag_Nut == tmp->tag)
        printf("%d", ((Nut *)tmp)->nut);
      else if(Tag_Var == tmp->tag)
        printf("V%d", ((Var *)tmp)->id);
      else
        goto error;
    }
    puts(") expanded");
    param = m->args;
    for(tmp = ((MacroCall *)p)->args; tmp ; tmp = tmp->next) {
      ((VarDef *)param)->var = (Var *)tmp;
      param = param->next;
    }
    pprint_prog(m->body, indent);
  } else if(Tag_FunCall == p->tag) {
    printf("(f%d)", ((FunCall *)p)->func->id);
  }
  return;
error :
  fprintf(stderr, "Error in pprint_prog() : Invalid tree!\n");
  exit(EXIT_FAILURE);
}

static FILE *global_variable_input_file_pointer;
static enum Tok global_variable_prev_tok = Tok_NULL;

static void unget_tok(enum Tok t) {
  global_variable_prev_tok = t;
}

static enum Tok get_tok() {
  int c;
  int i = 0;

  if(Tok_NULL != global_variable_prev_tok) {
    enum Tok tmp = global_variable_prev_tok;
    global_variable_prev_tok = Tok_NULL;
    return tmp;
  }

  c = getc(global_variable_input_file_pointer);

  while(isspace(c))
    c = getc(global_variable_input_file_pointer);
  if(c == ';')
    while('\n' != (c = getc(global_variable_input_file_pointer)));
  while(isspace(c))
    c = getc(global_variable_input_file_pointer);
  if(c == EOF)
    return EOF;
  if(c == '(')
    return Tok_LB;
  else if(c == ')')
    return Tok_RB;
  while(c != '(' && c != ')' && isgraph(c)) {
    if(i < MAX_BUF_LEN)
      global_variable_buffer[i++] = c;
    else {
      fprintf(stderr, "Tokenize Error : Too Long Name!\n");
      exit(EXIT_FAILURE);
    }
    c = getc(global_variable_input_file_pointer);
  }
  global_variable_buffer[i] = '\0';
  ungetc(c, global_variable_input_file_pointer);
  if(strcmp(global_variable_buffer, "macro") == 0)
    return Tok_Macro;
  else if(strcmp(global_variable_buffer, "begin") == 0)
    return Tok_Begin;
  else if(strcmp(global_variable_buffer, "def") == 0)
    return Tok_Def;
  else if(strcmp(global_variable_buffer, "add1") == 0)
    return Tok_Add1;
  else if(strcmp(global_variable_buffer, "sub1") == 0)
    return Tok_Sub1;
  else if(strcmp(global_variable_buffer, "if") == 0)
    return Tok_If;
  else if(strcmp(global_variable_buffer, "nzero?") == 0)
    return Tok_NZero;
  else
    return Tok_Name;
}

tree *read() {
  enum Tok t = get_tok();
  if(Tok_LB == t)
    return read_prog();
  else
    return NULL;
}

void load(const char* filename) {
  tree *p;
  if(NULL == (global_variable_input_file_pointer = fopen(filename, "r")))
    exit(EXIT_FAILURE);
  while((p = read())) {
    if(Tag_MacroDef == p->tag)
      global_variable_macro_definitions
        = (MacroDef *)append((tree *)global_variable_macro_definitions, p);
    pprint(p);
    putchar('\n');
  }
  fclose(global_variable_input_file_pointer);
}

int main(int argc, char* argv[]) {
  if(argc == 1) return EXIT_FAILURE ;
#ifdef DEBUG_TOKENIZER
{
  enum Tok t;
  if(NULL == (global_variable_input_file_pointer = fopen(argv[1], "r")))
    exit(EXIT_FAILURE);
  while(EOF != (t = get_tok()))
    puts(tok_to_str(t));
}
#else
  load(argv[1]);
#endif
  return EXIT_SUCCESS;
}