Lispインタプリタその１（勉強会用）

lispinterp1.c

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

#if !defined(UNUSED)
# if defined(__GNUC__)
#  define UNUSED __attribute__((__unused__))
# else
#  define UNUSED
# endif
#endif

#define ERROR(...) do{puts(""); fprintf(stderr, __VA_ARGS__); puts(""); longjmp(torepl, -1);}while(0)
#define FATAL(...) do{puts(""); fprintf(stderr, __VA_ARGS__); puts(""); exit(-1);}while(0)

#define CHANKSIZE 256
#define SYMTABLESIZE 256

typedef enum {
  TYPE_NIL, TYPE_T, TYPE_SYMBOL, TYPE_PAIR, TYPE_INTEGER,
  TYPE_SUBR,  TYPE_FSUBR, TYPE_EXPR, TYPE_FEXPR
} datatype;

#define DOLIST(i, p ,lst) for((p)=(lst); (p).type!=TYPE_NIL && ((i)=(p).paircar, 1); (p)=(p).paircdr)

struct _pair_t;
struct _data_t;
struct _symbol_t;

struct _data_t {
  datatype type;
  union {
    int integer;
    struct _pair_t *pair;
    struct _symbol_t *symbol;
    struct _data_t (*subr)(struct _data_t, struct _data_t);
#define intval value.integer
#define pairptr value.pair
#define symptr value.symbol
#define paircar value.pair->car
#define paircdr value.pair->cdr
#define subrptr value.subr
  } value;
};

struct _symbol_t {
  char *name;
};

struct _pair_t {
  unsigned int gc:1;
  unsigned int inuse:1;
  struct _data_t car;
  struct _data_t cdr;
#define freesize car.value.integer
#define freenext cdr.value.pair
};

struct _chank_t {
  struct _pair_t chank[CHANKSIZE];
  struct _chank_t *next;
};

typedef struct _pair_t pair_t;
typedef struct _data_t data_t;
typedef struct _symbol_t symbol_t;
typedef struct _data_t (*subr_t)(struct _data_t, struct _data_t);
typedef struct _chank_t chank_t;

data_t NIL = {.type=TYPE_NIL};
data_t T = {.type=TYPE_T};

data_t get_symbol(const char *str);
data_t get_pair(void);
data_t make_intval(int v);
int issymbolchar(int c);
void read_spaces(FILE *fp);
data_t read_list(FILE *fp);
data_t read_integer(FILE *fp);
data_t read_symbol(FILE *fp);
int read(FILE *fp, data_t *res);
data_t print(data_t d);
void print_list(data_t d);
data_t cons(data_t car, data_t cdr);
data_t env_search(data_t symbol, data_t env);
data_t env_bind(data_t params, data_t args, data_t env);
data_t apply(data_t func, data_t args, data_t env);
data_t eval(data_t exp, data_t env);
data_t evlis(data_t exp, data_t env);
int eq(data_t a, data_t b);
data_t progn(data_t list, data_t env);

symbol_t symtable[SYMTABLESIZE];
int symtable_used = 0;

chank_t *chanklist = NULL;
void *chank_startaddr = (void*)(~0);
void *chank_endaddr = 0;
pair_t *freelist = NULL;
void **stack_bottom;

jmp_buf torepl;

data_t get_symbol(const char *str) {
  data_t d; d.type = TYPE_SYMBOL;
  int i;
  for(i=0; i<symtable_used; i++)
    if(strcmp(symtable[i].name, str) == 0){
      d.symptr = &symtable[i];
      return d;
    }
  if(symtable_used < SYMTABLESIZE){
    symtable[symtable_used].name = strdup(str);
    d.symptr = &symtable[symtable_used++];
    return d;
  }
  FATAL("symbol table is full.");
}

void gc_mark1(pair_t *p) {
  if(p->inuse==1 && p->gc==0){
    p->gc=1;
    if(p->car.type==TYPE_PAIR  || p->car.type==TYPE_EXPR || p->car.type==TYPE_FEXPR)
      gc_mark1(p->car.pairptr);
    if(p->cdr.type==TYPE_PAIR || p->cdr.type==TYPE_EXPR || p->cdr.type==TYPE_FEXPR)
      gc_mark1(p->cdr.pairptr);
  }
}

int is_in_chank(void *ptr) {
  chank_t *c;
  if(chank_startaddr <= ptr && ptr < chank_endaddr)
    for(c=chanklist; c!=NULL; c=c->next)
      if((void*)(c->chank) <= ptr && ptr < (void*)(c->chank+CHANKSIZE) && (ptr-(void*)c->chank)%sizeof(pair_t)==0)
        return 1;
  return 0;
}

void gc_check_stack(void **stack_top) {
  void **stack_start, **stack_end, **ptr;
  if(stack_top<stack_bottom){
    stack_start = stack_top; stack_end = stack_bottom;
  }else{
    stack_start = stack_bottom; stack_end = stack_top;
  }
  for(ptr=stack_start; ptr<=stack_end; ptr++)
    if(is_in_chank(*ptr))
      gc_mark1((pair_t*)(*ptr));
}

void gc_check_registers() {
  jmp_buf regs;
  void **ptr;
  setjmp(regs);
  for(ptr=(void**)(regs); ptr<(void**)(regs+1); ptr++)
    if(is_in_chank(*ptr))
      gc_mark1((pair_t*)(*ptr));
}

void gc_mark() {
  void *var;
  gc_check_stack(&var); 
  gc_check_registers(); 
}

int gc_sweep() {
  chank_t *c;
  int i, count = 0;
  freelist = NULL;
  for(c=chanklist; c!=NULL; c=c->next)
    for(i=0; i<CHANKSIZE; i++)
      if(c->chank[i].gc==0){
        c->chank[i].inuse=0;
        c->chank[i].freesize=1;
        c->chank[i].freenext = freelist;
        freelist = &(c->chank[i]);
        count++;
      }else{
        c->chank[i].gc=0;
      }
  return count;
}

void alloc_chank() {
  chank_t *c = malloc(sizeof(chank_t));
  if(c==NULL) FATAL("out of memory,");
  c->next = chanklist;
  chanklist = c;
  c->chank[0].freesize = CHANKSIZE;
  c->chank[CHANKSIZE-1].freenext = freelist;
  freelist = c->chank;
  if(chank_startaddr > (void*)c->chank)
    chank_startaddr = c->chank;
  if(chank_endaddr < (void*)(c->chank+CHANKSIZE))
    chank_endaddr = c->chank+CHANKSIZE;
}

int gc_run() {
  int count;
  gc_mark();
  if((count=gc_sweep())==0)
    alloc_chank();
  return count;
}

data_t get_pair() {
  data_t d; d.type = TYPE_PAIR;
  if(freelist == NULL)
    gc_run();
  d.pairptr = freelist;
  d.pairptr->inuse=1;
  if(freelist->freesize-1 == 0){
    freelist = freelist->freenext;
  }else{
    (freelist+1)->freesize = freelist->freesize-1;
    freelist = freelist + 1;
  }
  return d;
}

data_t make_intval(int v) {
  data_t d; d.type = TYPE_INTEGER;
  d.intval = v;
  return d;
}

int issymbolchar(int c) {
  if(isalnum(c)) return 1;
  switch(c){
    case '!': case '$': case '%': case '&':
    case '*': case '+': case '-': case '/':
    case '<': case '=': case '>': case '?':
      return 1;
  }
  return 0;
}

void read_spaces(FILE *fp) {
  int c;
  while(isspace(c=getc(fp)));
  ungetc(c, fp);
}

data_t read_list(FILE *fp) {
  data_t list_head = NIL, *list_tail = &list_head, item;
  while(read(fp, &item) == 0){
    *list_tail = cons(item, NIL);
    list_tail = &(list_tail->paircdr);
  }
  return list_head;
}

data_t read_integer(FILE *fp) {
  int num = 0, c;
  while(isdigit(c=getc(fp)))
    num = num*10 + (c-'0');
  ungetc(c, fp);
  return make_intval(num);
}

data_t read_symbol(FILE *fp) {
  int c, i;
  static char buf[128];
  for(i=0; i<127; i++)
    if(issymbolchar(c=getc(fp)))
      buf[i] = c;
    else
      break;
  buf[i] = '\0';
  ungetc(c, fp);
  if(strcmp("t", buf) == 0)
    return T;
  else if(strcmp("nil", buf) == 0)
    return NIL;
  else
    return get_symbol(buf);
}

int read(FILE *fp, data_t *res) {
  int c;
  read_spaces(fp);
  c = getc(fp);
  if(c == '('){
    *res = read_list(fp);
    read_spaces(fp);
    if((c=getc(fp)) !=')')
      ERROR("rparen expected.");
    return 0;
  }else if(c == '\''){
    *res = cons(get_symbol("quote"), cons(NIL, NIL));
    return read(fp, &(res->paircdr.paircar));
  }else if(isdigit(c)){
    ungetc(c, fp);
    *res = read_integer(fp);
    return 0;
  }else if(issymbolchar(c)){
    ungetc(c, fp);
    *res = read_symbol(fp);
    return 0;
  }
  ungetc(c, fp);
  return -1;
}

data_t print(data_t d) {
  switch(d.type) {
    case TYPE_NIL:
      printf("nil"); break;
    case TYPE_INTEGER:
      printf("%d", d.value.integer); break;
    case TYPE_PAIR:
      printf("("); print_list(d); printf(")");  break;
    case TYPE_SYMBOL:
      printf("%s", d.symptr->name);  break;
    case TYPE_SUBR:
      printf("#<subr>"); break;
    case TYPE_FSUBR:
      printf("#<fsubr>"); break;
    case TYPE_T:
      printf("t"); break;
    case TYPE_EXPR:
      printf("#<expr>"); break;
    case TYPE_FEXPR:
      printf("#<fexpr>"); break;
  }
  return d;
}

void print_list(data_t d) {
  if(d.type == TYPE_PAIR){
    print(d.paircar);
    if(d.paircdr.type == TYPE_PAIR){
      printf(" "); print_list(d.value.pair->cdr);
    }else if(d.paircdr.type != TYPE_NIL){
      printf(" . "); print(d.paircdr);
    }
  }else{
    print(d);
  }
}

data_t cons(data_t car, data_t cdr) {
  data_t c = get_pair();
  c.paircar = car; c.paircdr = cdr;
  return c;
}

data_t env_search(data_t symbol, data_t env) {
  data_t f, b, p, p2;
  DOLIST(f, p, env)
    DOLIST(b, p2, f)
      if(eq(b.paircar, symbol))
        return b.paircdr;
  ERROR("unbound variable: %s", symbol.symptr->name);
}

data_t env_bind(data_t params, data_t args, data_t env) {
  data_t list_head = NIL, *list_tail = &list_head, param, p;
  DOLIST(param, p, params){
    *list_tail = cons(cons(param, args.paircar), NIL);
    list_tail = &(list_tail->paircdr);
    args = args.paircdr;
  }
  return cons(list_head, env);
}

data_t apply(data_t callee, data_t args, data_t env) {
  switch(callee.type){
    case TYPE_SUBR: 
      return (callee.subrptr)(evlis(args, env), env);
    case TYPE_FSUBR:
      return (callee.subrptr)(args, env);
    case TYPE_EXPR:
      return progn(callee.paircdr, env_bind(callee.paircar, evlis(args, env), env));
    case TYPE_FEXPR:
      return progn(callee.paircdr, env_bind(callee.paircar, cons(args, NIL), env));
    default:
      ERROR("bad callee.");
  }
}

data_t eval(data_t exp, data_t env) {
  switch(exp.type){
    case TYPE_NIL:
    case TYPE_T:
    case TYPE_INTEGER:
      return exp;
    case TYPE_PAIR:
      return apply(eval(exp.paircar, env), exp.paircdr, env);
    case TYPE_SYMBOL:
      return env_search(exp, env);
    default:
      ERROR("eval error.");
  }
}

data_t evlis(data_t exp, data_t env) {
  data_t list_head = NIL, *list_tail = &list_head;
  while(exp.type != TYPE_NIL){
    *list_tail = cons(eval(exp.paircar, env), NIL);
    list_tail = &(list_tail->paircdr);
    exp = exp.paircdr;
  }
  return list_head;
}

data_t subr_cons(data_t args, data_t env UNUSED) {
  return cons(args.paircar, args.paircdr.paircar);
}

data_t subr_car(data_t args, data_t env UNUSED) {
  return args.paircar.paircar;
}

data_t subr_cdr(data_t args, data_t env UNUSED) {
  return args.paircar.paircdr;
}

data_t subr_add(data_t args, data_t env UNUSED) {
  int sum = 0;
  data_t i, p;
  DOLIST(i, p, args)
    sum += i.intval;
  return make_intval(sum);
}

data_t subr_lt(data_t args, data_t env UNUSED) {
  data_t i, p;
  int prev = args.paircar.intval;
  DOLIST(i, p, args.paircdr)
    if(!(prev < i.intval))
      return NIL;
  return T;
}

int eq(data_t a, data_t b) {
  if(a.type != b.type) return 0;
  switch(a.type){
    case TYPE_NIL:
    case TYPE_T:
      return 1;
    case TYPE_INTEGER:
      return a.intval==b.intval;
    case TYPE_PAIR:
    case TYPE_EXPR:
    case TYPE_FEXPR:
      return a.pairptr==b.pairptr;
    case TYPE_SYMBOL:
      return a.symptr==b.symptr;
    case TYPE_SUBR:
    case TYPE_FSUBR:
      return a.subrptr==b.subrptr;
  }
  return 0;
}

data_t subr_eq(data_t args, data_t env UNUSED) {
  if(eq(args.paircar, args.paircdr.paircar))
    return T;
  else
    return NIL;
}

data_t subr_atom(data_t args, data_t env UNUSED) {
  if(args.paircar.type != TYPE_PAIR)
    return T;
  else
    return NIL;
}

data_t subr_gc(data_t args UNUSED, data_t env UNUSED) {
  return make_intval(gc_run());
}

data_t subr_free(data_t args UNUSED, data_t env UNUSED) {
  int count = 0;
  pair_t *ptr;
  for(ptr=freelist; ptr!=NULL; ptr=ptr->freenext)
    count+=ptr->freesize;
  return make_intval(count);
}

data_t subr_read(data_t args UNUSED, data_t env UNUSED) {
  data_t d;
  if(read(stdin, &d) == 0)
    return d;
  else
    return NIL;
}

data_t subr_eval(data_t args, data_t env) {
  return eval(args.paircar, env);
}

data_t subr_print(data_t args, data_t env UNUSED) {
  return print(args.paircar);
}

data_t fsubr_quote(data_t args, data_t env UNUSED) {
  return args.paircar;
}

data_t fsubr_define(data_t args, data_t env) {
  env.paircar = cons(cons(args.paircar, eval(args.paircdr.paircar, env)), env.paircar);
  return args.paircar;
}

data_t fsubr_defun(data_t args, data_t env) {
  data_t f = args.paircdr; f.type = TYPE_EXPR;
  env.paircar = cons(cons(args.paircar, f), env.paircar);
  return args.paircar;
}

data_t progn(data_t list, data_t env) {
  data_t e, v, p;
  DOLIST(e, p, list)
    v = eval(e, env);
  return v;
}

data_t fsubr_cond(data_t args, data_t env) {
  data_t c, p;
  DOLIST(c, p, args)
    if(eval(c.paircar, env).type != TYPE_NIL)
      return progn(c.paircdr, env);
  return NIL;
}

data_t fsubr_lambda(data_t args, data_t env UNUSED) {
  data_t f = args; f.type = TYPE_EXPR;
  return f;
}

data_t fsubr_nlambda(data_t args, data_t env UNUSED) {
  data_t f = args; f.type = TYPE_FEXPR;
  return f;
}

void register_subr(datatype t, const char *name, subr_t subr, data_t env) {
  data_t d; d.type = t;
  d.subrptr = subr;
  env.paircar = cons(cons(get_symbol(name), d) ,env.paircar);
}

data_t env_init_toplevel() {
  data_t tenv = cons(NIL, NIL);
  register_subr(TYPE_SUBR, "cons", subr_cons, tenv);
  register_subr(TYPE_SUBR, "car", subr_car, tenv);
  register_subr(TYPE_SUBR, "cdr", subr_cdr, tenv);
  register_subr(TYPE_SUBR, "atom", subr_atom, tenv);
  register_subr(TYPE_FSUBR, "quote", fsubr_quote, tenv);
  register_subr(TYPE_FSUBR, "define", fsubr_define, tenv);
  register_subr(TYPE_FSUBR, "defun", fsubr_defun, tenv);
  register_subr(TYPE_FSUBR, "cond", fsubr_cond, tenv);
  register_subr(TYPE_FSUBR, "lambda", fsubr_lambda, tenv);
  register_subr(TYPE_FSUBR, "nlambda", fsubr_nlambda, tenv);
  register_subr(TYPE_SUBR, "+", subr_add, tenv);
  register_subr(TYPE_SUBR, "<", subr_lt, tenv);
  register_subr(TYPE_SUBR, "eq", subr_eq, tenv);
  register_subr(TYPE_SUBR, "read", subr_read, tenv);
  register_subr(TYPE_SUBR, "eval", subr_eval, tenv);
  register_subr(TYPE_SUBR, "print", subr_print, tenv);
  register_subr(TYPE_SUBR, "gc", subr_gc, tenv);
  register_subr(TYPE_SUBR, "free", subr_free, tenv);
  return tenv;
}

void repl() {
  data_t d, toplevel_env = env_init_toplevel();
  setjmp(torepl);
  while(1){
    printf("lisp> ");
    if(read(stdin, &d)==0)
      print(eval(d, toplevel_env));
    else
      break;
    printf("\n");
  }
}

int main() {
  void *var;
  stack_bottom = &var;
  alloc_chank();
  repl();
}