#include <assert.h>
#include <stdarg.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
enum type {
NIL,
BOOLEAN,
INTEGER,
RATIONAL,
STRING,
SYMBOL,
PRIMITIVE,
FUNCTION,
PAIR
};
struct value;
typedef struct value *V;
struct hash;
typedef struct hash *H;
struct rational {
int numerator;
int denominator;
};
typedef V (*P)(V);
struct function {
V args;
V body;
H env;
};
struct pair {
V car;
V cdr;
};
struct value {
enum type t;
union {
bool b;
int i;
struct rational r;
char *s;
P pr;
struct function f;
struct pair p;
};
};
struct value Qnil, Qtrue, Qfalse;
V Vnil, Vtrue, Vfalse;
void init_const() {
Vnil = &Qnil;
Vtrue = &Qtrue;
Vfalse = &Qfalse;
Vnil->t = NIL;
Vtrue->t = BOOLEAN;
Vtrue->b = true;
Vfalse->t = BOOLEAN;
Vfalse->b = false;
}
V make_integer(int i) {
V a = (V)malloc(sizeof(struct value));
a->t = INTEGER;
a->i = i;
return a;
}
int gcd(int a, int b) {
while (b) {
int t = a % b;
a = b;
b = t;
}
return a;
}
V divide(V a, V b) {
assert(a->t == INTEGER);
assert(b->t == INTEGER);
int g = gcd(a->i, b->i);
V c = (V)malloc(sizeof(struct value));
c->t = RATIONAL;
c->r.numerator = a->i / g;
c->r.denominator = b->i / g;
return c;
}
V make_string(char *s) {
V a = (V)malloc(sizeof(struct value));
a->t = STRING;
a->s = s;
return a;
}
V make_symbol(char *s) {
V a = (V)malloc(sizeof(struct value));
a->t = SYMBOL;
a->s = s;
return a;
}
V make_primitive(P pr) {
V a = (V)malloc(sizeof(struct value));
a->t = PRIMITIVE;
a->pr = pr;
return a;
}
V make_function(V args, V body, H env) {
V a = (V)malloc(sizeof(struct value));
a->t = FUNCTION;
a->f.args = args;
a->f.body = body;
a->f.env = env;
return a;
}
V make_pair(V a, V b) {
V c = (V)malloc(sizeof(struct value));
c->t = PAIR;
c->p.car = a;
c->p.cdr = b;
return c;
}
V listv(int n, V *a) {
int i;
V b = Vnil;
for (i = n-1; i >= 0; i--)
b = make_pair(a[i], b);
return b;
}
V list(int n, ...) {
int i;
va_list va;
V *a = (V *)malloc(n*sizeof(V));
va_start(va, n);
for (i = 0; i < n; i++)
a[i] = va_arg(va, V);
va_end(va);
V b = listv(n, a);
free(a);
return b;
}
struct entry {
char *key;
V value;
};
struct hash {
int size;
int capacity;
struct entry *items;
struct hash *parent;
};
int hash(char *s) {
int h = 0;
int c;
while (c = *s++)
h = h * 33 + c;
return h;
}
H make_hash(H parent) {
int i;
int n = 8;
H h = (H)malloc(sizeof(struct hash));
h->size = 0;
h->capacity = n;
h->items = (struct entry *)malloc(n*sizeof(struct entry));
for (i = 0; i < n; i++)
h->items[i].key = NULL;
h->parent = parent;
return h;
}
struct entry *get_entry(H h, char *key) {
int i;
char *s;
int n = h->capacity;
i = hash(key) % n;
while (s = h->items[i].key) {
if (!strcmp(s, key))
break;
i++;
if (i == n)
i = 0;
}
return &h->items[i];
}
V get_hash(H h, char *key) {
while (h) {
struct entry *e = get_entry(h, key);
if (e->key)
return e->value;
h = h->parent;
}
return NULL;
}
void grow_hash(H h);
void put_hash(H h, char *key, V value) {
struct entry *e = get_entry(h, key);
e->value = value;
if (!e->key) {
e->key = key;
h->size++;
grow_hash(h);
}
}
void replace_hash(H h, char *key, V value) {
while (h) {
struct entry *e = get_entry(h, key);
if (e->key)
e->value = value;
h = h->parent;
}
}
void grow_hash(H h) {
int i;
if (h->size < h->capacity / 2)
return;
int old_capacity = h->capacity;
struct entry *old_items = h->items;
h->capacity = old_capacity * 2;
h->items = (struct entry *)malloc(h->capacity*sizeof(struct entry));
for (i = 0; i < h->capacity; i++)
h->items[i].key = NULL;
for (i = 0; i < old_capacity; i++) {
struct entry e = old_items[i];
if (e.key)
put_hash(h, e.key, e.value);
}
free(old_items);
}
V cons(V args) {
V a = args->p.car;
V b = args->p.cdr->p.car;
return make_pair(a, b);
}
V car(V args) {
V a = args->p.car;
return a->p.car;
}
V cdr(V args) {
V a = args->p.car;
return a->p.cdr;
}
V add(V args) {
int a = args->p.car->i;
int b = args->p.cdr->p.car->i;
return make_integer(a + b);
}
#define PRIM1(name) put_hash(h, #name, make_primitive(name))
#define PRIM2(name, cname) put_hash(h, name, make_primitive(cname))
H init_env() {
H h = make_hash(NULL);
PRIM1(cons);
PRIM1(car);
PRIM1(cdr);
PRIM2("+", add);
return h;
}
char ch;
void skip_spaces(FILE *f) {
do ch = fgetc(f);
while (ch == ' ');
}
bool is_integer(char c) {
return '0' <= c && c <= '9';
}
bool is_symbol(char c) {
if ('a' <= c && c <= 'z') return true;
if (strchr("+-*/", c)) return true;
return false;
}
V read_integer(FILE *f) {
int i = 0;
while (is_integer(ch)) {
i = i * 10 + ch - '0';
ch = fgetc(f);
}
return make_integer(i);
}
V read_symbol(FILE *f) {
int n = 1;
int i = 0;
char *s = (char *)malloc(n);
while (is_symbol(ch)) {
s[i++] = ch;
if (i == n) {
n *= 2;
s = realloc(s, n);
}
ch = fgetc(f);
}
s[i] = '\0';
return make_symbol(s);
}
V read_value(FILE *f);
V read_list(FILE *f) {
int n = 1;
int i = 0;
V *a = (V *)malloc(n*sizeof(V));
skip_spaces(f);
while (true) {
if (ch == ')')
break;
a[i++] = read_value(f);
if (i == n) {
n *= 2;
a = realloc(a, n*sizeof(V));
}
if (ch == ' ')
skip_spaces(f);
}
V b = listv(i, a);
free(a);
skip_spaces(f);
return b;
}
V read_value(FILE *f) {
if (is_integer(ch))
return read_integer(f);
if (is_symbol(ch))
return read_symbol(f);
if (ch == '(')
return read_list(f);
return NULL;
}
V lisp_read(FILE *f) {
skip_spaces(f);
return read_value(f);
}
V eval_seq(V a, H e);
V eval_map(V a, H e);
V apply(V a, V b);
V eval(V a, H e) {
switch (a->t) {
case NIL:
case BOOLEAN:
case INTEGER:
case RATIONAL:
case STRING:
return a;
case SYMBOL:
return get_hash(e, a->s);
}
assert(a->t == PAIR);
V h = a->p.car;
V t = a->p.cdr;
if (h->t == SYMBOL) {
if (!strcmp(h->s, "define"))
return (put_hash(e, t->p.car->s, eval(t->p.cdr->p.car, e)), Vnil);
else if (!strcmp(h->s, "lambda"))
return make_function(t->p.car, t->p.cdr, e);
else if (!strcmp(h->s, "begin"))
return eval_seq(t, e);
}
h = eval(h, e);
t = eval_map(t, e);
return apply(h, t);
}
V eval_seq(V a, H e) {
V b = Vnil;
while (a->t != NIL) {
b = eval(a->p.car, e);
a = a->p.cdr;
}
return b;
}
V eval_map(V a, H e) {
int n = 1;
int i = 0;
V *b = (V *)malloc(n*sizeof(V));
while (a->t != NIL) {
b[i++] = eval(a->p.car, e);
if (i == n) {
n *= 2;
a = realloc(a, n*sizeof(V));
}
a = a->p.cdr;
}
V c = listv(i, b);
free(b);
return c;
}
V apply(V a, V b) {
if (a->t == PRIMITIVE)
return (*a->pr)(b);
H e = make_hash(a->f.env);
V k, v;
for (k = a->f.args, v = b; k->t != NIL; k = k->p.cdr, v = v->p.cdr)
put_hash(e, k->p.car->s, v->p.car);
return eval_seq(a->f.body, e);
}
void lisp_write(V a, FILE *f) {
switch (a->t) {
case NIL:
fputs("()", f);
break;
case BOOLEAN:
if (a->b) fputs("#t", f);
else fputs("#f", f);
break;
case INTEGER:
fprintf(f, "%d", a->i);
break;
case RATIONAL:
fprintf(f, "%d", a->r.numerator);
fputc('/', f);
fprintf(f, "%d", a->r.denominator);
break;
case STRING:
fputc('"', f);
fputs(a->s, f);
fputc('"', f);
break;
case SYMBOL:
fputs(a->s, f);
break;
case FUNCTION:
fputs("(lambda ", f);
lisp_write(a->f.args, f);
fputc(' ', f);
lisp_write(a->f.body, f);
fputc(')', f);
break;
case PAIR:
fputc('(', f);
V b = a;
while (true) {
lisp_write(b->p.car, f);
b = b->p.cdr;
if (b->t == NIL)
break;
if (b->t != PAIR) {
fputs(" . ", f);
lisp_write(b, f);
break;
}
fputc(' ', f);
}
fputc(')', f);
break;
}
}
void newline(FILE *f) {
fputc('\n', f);
}
int main() {
init_const();
H e = init_env();
bool tty = isatty(0);
while (true) {
if (tty)
fputs("> ", stdout);
V a = lisp_read(stdin);
if (!a)
break;
V b = eval(a, e);
if (b == Vnil)
continue;
lisp_write(b, stdout);
newline(stdout);
}
return 0;
}