asmr-lisp.y

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

extern int yylex(void);
int yyerror(const char *s) { printf("%s\n", s); return 0; }

int node[4096]; int nnum = 1;
int car[2048], cdr[2048]; int cnum = 1;
char symbol[2048][32]; int snum = 1;

int cons(int a, int d) {
  car[cnum] = a; cdr[cnum] = d;
  node[nnum] = cnum; cnum++; nnum++;
  return nnum - 1;
}
int head(int s) { return car[node[s]]; }
int tail(int s) { return cdr[node[s]]; }
int lref(int s, int num) {
  return num == 0 ? head(s) : lref(tail(s), num - 1);
}

int setsym(char *str) {
  strcpy(symbol[snum], str); node[nnum] = -snum;
  snum++; nnum++; return nnum - 1;
}
const char *getsym(int s) { return symbol[-node[s]]; }

#define N 0
#define T 1
#define F 0
int pairp(int s) { return node[s] > 0 ? T : F; }
int nullp(int s) { return s == N ? T : F; }
int eqsymp(int x, const char *y) { return !strcmp(getsym(x), y); }
int intp(int s) {
  const char *str = getsym(s); int i;
  for (i = 0; i < strlen(str); i++)
    if (!isdigit(str[i]) && str[i] != '-') break;
  return i == strlen(str) ? T : F;
}

void sw(int s) {
  if (pairp(s)) {
    printf("("); sw(head(s));
    if (pairp(tail(s)))
      for (int n = tail(s); !nullp(n); n = tail(n)) {
        printf(" "); sw(head(n));
      }
    else if (tail(s) != N) { printf(" . "); sw(tail(s)); }
    printf(")");
  } else printf("%s", getsym(s));
}

int ap(int x, int y) {
  if (nullp(x)) return y; else cons(head(x), ap(tail(x), y));
}

int pm(int k, int v) {
  if (nullp(k) || nullp(v)) return N;
  else cons(head(k), cons(head(v), pm(tail(k), tail(v))));
}

int pq(int k, int pl) {
  if (nullp(pl)) return F;
  else if (eqsymp(k, getsym(head(pl)))) return lref(pl, 1);
  else return pq(k, tail(tail(pl)));
}

int sq(int s, int e) {
  if (eqsymp(s, "+") || eqsymp(s, "-") || eqsymp(s, "eq?") ||
      eqsymp(s, "cons") || eqsymp(s, "car") || eqsymp(s, "cdr"))
    return s;
  else return pq(s, e);
}

enum OP { ADD, SUB };
int op(enum OP f, int a) {
  int a1 = atoi(getsym(head(a))), a2 = atoi(getsym(head(tail(a)))), r;
  switch (f) {
    case ADD: r = a1 + a2; break;
    case SUB: r = a1 - a2; break;
  }
  char str[32]; sprintf(str, "%d", r); return setsym(str);
}
int ay(int f, int a) {
  if      (eqsymp(f, "+")) return op(ADD, a);
  else if (eqsymp(f, "-")) return op(SUB, a);
  else if (eqsymp(f, "cons")) return cons(lref(a, 0), lref(a, 1));
  else if (eqsymp(f, "car")) return head(lref(a, 0));
  else if (eqsymp(f, "cdr")) return tail(lref(a, 0));
  else if (eqsymp(f, "eq?")) {
    int a1 = lref(a, 0), a2 = lref(a, 1);
    if (nullp(a1) && nullp(a2)) return T;
    else if (nullp(a1) || nullp(a2)) return F;
    else return eqsymp(a1, getsym(a2));
  }
}

int ev(int s, int e);
int ea(int a, int e) {
  return nullp(a) ? N : cons(ev(head(a), e), ea(tail(a), e));
}

int ev(int s, int e) {
  if (pairp(s)) {
    int h = head(s);
    if (!pairp(h) && (eqsymp(h, "quote"))) return head(tail(s));
    else if (!pairp(h) && (eqsymp(h, "if")))
      return ev(lref(s, 1), e) ? ev(lref(s, 2), e) : ev(lref(s, 3), e);
    else if (!pairp(h) && (eqsymp(h, "lambda"))) return ap(s, cons(e, N));
    else {
      int f = ev(h, e), a = ea(tail(s), e);
      if (!pairp(f)) return ay(f, a);
      else return ev(lref(f, 2), ap(pm(lref(f, 1), a), lref(f, 3)));
    }
  } else return intp(s) ? s : sq(s, e);
}

%}

%defines
%union { char *symbol; int node; }
%token EMPTY DOT
%token <symbol> SYMBOL
%type <node> s list

%%

in	: s		{ sw(ev(nnum - 1, N)); printf("\n"); return 0; }
	;

s	: EMPTY		{ $$ = N; }
        | SYMBOL	{ $$ = setsym($1); }
	| '(' list ')'	{ $$ = $2; }
	;

list	: s		{ $$ = cons($1, N); }
	| s list	{ $$ = cons($1, $2); }
	| s DOT s	{ $$ = cons($1, $3); }
	;

%%

#include "lex.yy.c"
int main(void) { yyparse(); return 0; }