lisp.c

#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;
}

test.lisp

(define zero (lambda (f) (lambda (x) x)))
(define one (lambda (f) (lambda (x) (f x))))
(define plus (lambda (m n) (lambda (f) (lambda (x) ((n f) ((m f) x))))))
(define mult (lambda (m n) (lambda (f) (lambda (x) ((n (m f)) x)))))
(define xp (lambda (m n) (lambda (f) (lambda (x) (((n m) f) x)))))
(define inc (lambda (x) (+ x 1)))
(define num (lambda (n) ((n inc) 0)))
(define two (plus one one))
(define three (plus two one))
(define six (mult two three))
(define sixty-four (xp two six))
(num sixty-four)