Commits

catseye  committed 5705314

Add partial implementation of Pixley in C (with resumable parser!)

  • Participants
  • Parent commits 841694c

Comments (0)

Files changed (10)

File impl/mignon/Makefile

+# GNU Makefile for mignon.
+# $Id: Makefile 658 2010-07-21 17:33:26Z cpressey $
+
+PROG=mignon
+CC?=gcc
+STRIP?=strip
+O?=.o
+EXE?=
+
+WARNS=	-Werror -W -Wall -Wstrict-prototypes -Wmissing-prototypes \
+	-Wpointer-arith	-Wno-uninitialized -Wreturn-type -Wcast-qual \
+	-Wwrite-strings -Wswitch -Wshadow -Wcast-align -Wchar-subscripts \
+	-Winline -Wnested-externs -Wredundant-decls
+
+ifdef ANSI
+  CFLAGS+= -ansi -pedantic
+else
+  CFLAGS+= -std=c99 -D_POSIX_C_SOURCE=200112L
+endif
+
+CFLAGS+= ${WARNS} ${EXTRA_CFLAGS}
+
+ifdef DEBUG
+  CFLAGS+= -g
+endif
+
+OBJS=	sexp${O} parse${O} eval${O} main${O}
+
+all: ${PROG}${EXE}
+
+${PROG}${EXE}: $(OBJS)
+	$(CC) $(OBJS) -o ${PROG} $(LIBS)
+
+parse${O}: parse.c parse.h sexp.h
+	$(CC) $(CFLAGS) -c parse.c -o parse${O}
+
+sexp${O}: sexp.c sexp.h
+	$(CC) $(CFLAGS) -c sexp.c -o sexp${O}
+
+eval${O}: eval.c eval.h
+	$(CC) $(CFLAGS) -c eval.c -o eval${O}
+
+main${O}: main.c parse.h sexp.h eval.h
+	$(CC) $(CFLAGS) -c main.c -o main${O}
+
+clean:
+	rm -f *.o *.core *.exe ${PROG}${EXE}

File impl/mignon/amalgamate.sh

+#!/bin/sh
+
+cat sexp.h eval.h parse.h sexp.c eval.c parse.c main.c | grep -v '^\#include "' > mignon.c

File impl/mignon/eval.c

+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+
+#include "sexp.h"
+#include "eval.h"
+
+struct value *lookup(struct env *env, struct atom *name)
+{
+    for (; env != NULL; env = env->next) {
+        if (env->name == name) {
+            return env->value;
+        }
+    }
+    return NULL;
+}
+
+struct env *bind(struct env *env, struct atom *name, struct value *value)
+{
+    struct env *e = malloc(sizeof *e);
+    e->name = name;
+    e->value = value;
+    e->next = env;
+    return e;
+}
+
+static void dump_env(struct env *env)
+{
+    printf("env: {\n");
+    while (env != NULL) {
+        printf("  %s = ", env->name->string);
+        dump(env->value);
+        printf(";\n");
+        env = env->next;
+    }
+    printf("}\n");
+}
+
+struct value *eval(struct value *sexp, struct env *env)
+{
+    struct value *cadr = atom("cadr");
+    struct value *car = atom("car");
+    struct value *cdr = atom("cdr");
+    struct value *cond = atom("cond");
+    struct value *cons_ = atom("cons");
+    struct value *else_ = atom("else");
+    struct value *equalp = atom("equal?");
+    struct value *lambda_ = atom("lambda");
+    struct value *let = atom("let*");
+    struct value *listp = atom("list?");
+    struct value *nullp = atom("null?");
+    struct value *quote = atom("quote");
+    struct value *truth = atom("#t");
+    struct value *falsehood = atom("#f");
+
+    int done = 0;
+    while (!done) {
+        done = 1;
+        switch (sexp->type) {
+            case V_ATOM:
+            {
+                struct atom *name = (struct atom *)sexp;
+                struct value *value = lookup(env, name);
+                if (value == NULL) {
+                    printf("Atom ");
+                    dump(sexp);
+                    printf(" has no meaning\n");
+                    exit(1);
+                }
+                return value;
+            }
+            case V_CONS:
+            {
+                struct value *h = head(sexp);
+                struct value *t = tail(sexp);
+                struct value *bound = lookup(env, (struct atom *)h);
+                if (bound != NULL) {
+                    sexp = cons(bound, t);
+                    done = 0; /* "tail call" */
+                } else if (h == cadr) {
+                    struct value *k = eval(head(t), env);
+                    return head(tail(k));
+                } else if (h == car) {
+                    struct value *k = eval(head(t), env);
+                    return head(k);
+                } else if (h == cdr) {
+                    struct value *k = eval(head(t), env);
+                    return tail(k);
+                } else if (h == cond) {
+                    struct value *branch = head(t);
+                    /* this will error out with car(nil) if no 'else' in cond */
+                    while (1) {
+                        struct value *test = head(branch);
+                        struct value *expr = head(tail(branch));
+                        if (test == else_) {
+                            sexp = expr;
+                            done = 0; /* "tail call" */
+                        } else {
+                            test = eval(test, env);
+                            if (test != falsehood) {
+                                sexp = expr;
+                                done = 0; /* "tail call" */
+                            } else {
+                                t = tail(t);
+                                branch = head(t);
+                            }
+                        }
+                    }
+                    return nil;
+                } else if (h == cons_) {
+                    struct value *j = eval(head(t), env);
+                    struct value *k = eval(head(tail(t)), env);
+                    return cons(j, k);
+                } else if (h == equalp) {
+                    struct value *j = eval(head(t), env);
+                    struct value *k = eval(head(tail(t)), env);
+                    if (equal(j, k)) {
+                        return truth;
+                    } else {
+                        return falsehood;
+                    }
+                } else if (h == lambda_) {
+                    return lambda(env, head(t), head(tail(t)));
+                } else if (h == let) {
+                    struct value *pairs = head(t);
+                    struct value *body = head(tail(t));
+
+                    while (pairs != nil) {
+                        struct value *pair = head(pairs);
+                        struct value *name = head(pair);
+                        struct value *value = eval(head(tail(pair)), env);
+                        /* TODO: check that head(pair) is an atom! */
+                        env = bind(env, (struct atom *)name, value);
+                        pairs = tail(pairs);
+                    }
+                    /* TODO: garbage collection plz */
+                    /* return eval(body, env); */
+                    /* XXX do we have to save env?? */
+                    sexp = body;
+                    done = 0; /* "tail call" */
+                } else if (h == listp) {
+                    struct value *k = eval(head(t), env);
+                    if (k == nil || k->type == V_CONS) {
+                        return truth;
+                    } else {
+                        return falsehood;
+                    }
+                } else if (h == nullp) {
+                    struct value *k = eval(head(t), env);
+                    if (k == nil) {
+                        return truth;
+                    } else {
+                        return falsehood;
+                    }
+                } else if (h == quote) {
+                    return head(t);
+                } else if (h->type == V_LAMBDA) {
+                    struct lambda *l = (struct lambda *)h;
+                    struct value *formals = l->formals;
+                    env = l->env;
+                    while (t->type == V_CONS) {
+                        struct value *formal = head(formals);
+                        struct value *value = eval(head(t), env);
+                        env = bind(env, (struct atom *)formal, value);
+                        formals = tail(formals);
+                        t = tail(t);
+                    }
+                    /* XXX do we have to save env?? */
+                    /* return eval(l->body, env); */
+                    sexp = l->body;
+                    done = 0; /* "tail call" */                    
+                } else {
+                    printf("Cannot evaluate ");
+                    dump(h);
+                    printf("\n");
+                    exit(1);
+                }
+                break;
+            }
+            case V_LAMBDA:
+            {
+                return sexp;
+            }
+        }
+    }
+    return sexp;
+}
+
+struct estate *push_estate(struct estate *parent, struct env *env, struct value *sexp)
+{
+    struct estate *estate = malloc(sizeof *estate);
+    estate->status = E_START;
+    estate->env = env;
+    estate->sexp = sexp;
+    estate->parent = parent;
+    estate->aux = NULL;
+    estate->result = NULL;
+    printf("pushed. new estate sexp now: ");
+    dump(estate->sexp);
+    printf("\n");
+    return estate;
+}
+
+struct estate *pop_estate(struct estate *estate)
+{
+    struct estate *parent = estate->parent;
+    parent->result = estate->result;
+    parent->env = estate->env; /* ? */
+    free(estate);
+    printf("popped. parent result now: ");
+    dump(parent->result);
+    printf("\n");
+    return parent;
+}
+
+struct estate *eval_resumable(struct estate *estate)
+{
+    struct value *cadr = atom("cadr");
+    struct value *car = atom("car");
+    struct value *cdr = atom("cdr");
+    struct value *cond = atom("cond");
+    struct value *cons_ = atom("cons");
+    struct value *else_ = atom("else");
+    struct value *equalp = atom("equal?");
+    struct value *lambda_ = atom("lambda");
+    struct value *let = atom("let*");
+    struct value *listp = atom("list?");
+    struct value *nullp = atom("null?");
+    struct value *quote = atom("quote");
+    struct value *truth = atom("#t");
+    struct value *falsehood = atom("#f");
+
+    while (1) {
+        switch (estate->status) {
+            case E_START:
+            {
+                printf("start.  working on: ");
+                dump(estate->sexp);
+                printf("\n");
+                switch (estate->sexp->type) {
+                    case V_ATOM:
+                    {
+                        struct atom *name = (struct atom *)estate->sexp;
+                        struct value *value = lookup(estate->env, name);
+                        printf("lookuped!\n");
+                        if (value == NULL) {
+                            printf("Atom ");
+                            dump(estate->sexp);
+                            printf(" has no meaning\n");
+                            exit(1);
+                        }
+                        printf("bound to value: ");
+                        dump(value);
+                        printf("\n");
+                        estate->result = value;
+                        estate->status = E_DONE;
+                        break;
+                    }
+                    case V_CONS:
+                    {
+                        struct value *h = head(estate->sexp);
+                        struct value *t = tail(estate->sexp);
+                        struct value *bound = lookup(estate->env, (struct atom *)h);
+                        if (bound != NULL) {
+                            estate->sexp = cons(bound, t);
+                            /* estate->status = E_START; */
+                        } else if (h == cadr) {
+                            estate->status = E_CADR;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == car) {
+                            estate->status = E_CAR;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == cdr) {
+                            estate->status = E_CDR;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == cond) {
+                            struct value *branch = head(t);
+                            struct value *test = head(branch);
+                            struct value *expr = head(tail(branch));
+                            if (test == else_) {
+                                estate->sexp = expr;
+                                /* estate->status = E_START; */
+                            } else {
+                                estate->status = E_COND;
+                                estate->sexp = t; /* we will use sexp as a cursor here */
+                                estate = push_estate(estate, estate->env, test);
+                            }
+                        } else if (h == cons_) {
+                            estate->status = E_CONS_L;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == equalp) {
+                            estate->status = E_EQUALP_L;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == lambda_) {
+                            estate->result = lambda(estate->env, head(t), head(tail(t)));
+                            estate->status = E_DONE;
+                        } else if (h == let) {
+                            struct value *pairs = head(t);
+                            struct value *pair = head(pairs);
+                            estate->status = E_LET;
+                            estate->aux = head(tail(t)); /* stash body in aux */
+                            estate->sexp = pairs; /* we use sexp as cursor over pairs */
+                            estate = push_estate(estate, estate->env, head(tail(pair)));
+                        } else if (h == listp) {
+                            estate->status = E_LISTP;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == nullp) {
+                            estate->status = E_NULLP;
+                            estate = push_estate(estate, estate->env, head(t));
+                        } else if (h == quote) {
+                            estate->result = head(t);
+                            estate->status = E_DONE;
+                        } else if (h->type == V_LAMBDA) {
+                            struct lambda *l = (struct lambda *)h;
+                            estate->aux = l->body; /* stash lambda body in aux */
+                            estate->formals = l->formals; /* stash formals in... formals */
+                            estate->build = NULL;
+                            if (t->type == V_CONS) {
+                                estate->sexp = t; /* sexp is a cursor on actuals */
+                                estate->status = E_LAMBDA;
+                                estate = push_estate(estate, estate->env, head(t));
+                            } else {
+                                /* you just said "((lambda ...) . foo)" ! */
+                                estate->result = nil;
+                                estate->status = E_DONE;
+                            }
+                        } else {
+                            printf("Cannot evaluate ");
+                            dump(h);
+                            printf("\n");
+                            exit(1);
+                        }
+                        break;
+                    }
+                    case V_LAMBDA:
+                    {
+                        estate->status = E_DONE;
+                        break;
+                    }
+                }
+                break;
+            }
+            case E_CADR:
+                estate->result = head(tail(estate->result));
+                estate->status = E_DONE;
+                break;
+            case E_CAR:
+                estate->result = head(estate->result);
+                estate->status = E_DONE;
+                break;
+            case E_CDR:
+                estate->result = tail(estate->result);
+                estate->status = E_DONE;
+                break;
+            case E_COND:
+            {
+                if (estate->result != falsehood) {
+                    estate->sexp = head(tail(head(estate->sexp)));
+                    estate->status = E_START;
+                } else {
+                    struct value *branch, *test, *expr;
+                    estate->sexp = tail(estate->sexp);
+                    branch = head(estate->sexp);
+                    test = head(branch);
+                    expr = head(tail(branch));
+                    if (test == else_) {
+                        estate->sexp = expr;
+                        estate->status = E_START;
+                    } else {
+                        estate->status = E_COND;
+                        estate = push_estate(estate, estate->env, test);
+                    }
+                }
+                break;
+            }
+            case E_CONS_L:
+                /* estate->sexp will be the original (cons a b) sexp still */
+                printf("e_cons_l. my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                estate->aux = estate->result;
+                estate->status = E_CONS_R;
+                estate = push_estate(estate, estate->env, head(tail(tail(estate->sexp))));
+                estate->status = E_START;
+                break;
+            case E_CONS_R:
+                printf("e_cons_r. my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                estate->result = cons(estate->aux, estate->result);
+                estate->status = E_DONE;
+                break;
+            case E_EQUALP_L:
+                /* estate->sexp will be the original (cons a b) sexp still */
+                printf("e_equalp_l. my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                estate->aux = estate->result;
+                estate->status = E_EQUALP_R;
+                estate = push_estate(estate, estate->env, head(tail(tail(estate->sexp))));
+                estate->status = E_START;
+                break;
+            case E_EQUALP_R:
+                printf("e_equalp_r. my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                if (equal(estate->aux, estate->result)) {
+                    estate->result = truth;
+                } else {
+                    estate->result = falsehood;
+                }
+                estate->status = E_DONE;
+                break;
+            case E_LAMBDA:
+            {
+                estate->build = bind(estate->build,
+                                     (struct atom *)head(estate->formals),
+                                     estate->result);
+                estate->formals = tail(estate->formals);
+                estate->sexp = tail(estate->sexp);
+                if (estate->formals != nil) {
+                    estate = push_estate(estate, estate->env, head(estate->sexp));
+                } else {
+                    estate->sexp = estate->aux; /* lambda body */
+                    estate->env = estate->build;
+                    estate->status = E_START;
+                }
+                break;
+            }
+            case E_LET:
+                /* name is head(head(sexp)) */
+                printf("e_let. my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                estate->env = bind(estate->env,
+                                   (struct atom *)head(head(estate->sexp)),
+                                   estate->result);
+                dump_env(estate->env);
+                estate->sexp = tail(estate->sexp);
+                printf("now my sexp is: ");
+                dump(estate->sexp);
+                printf("\n");
+                if (estate->sexp != nil) {
+                    struct value *pair = head(estate->sexp);
+                    estate = push_estate(estate, estate->env, head(tail(pair)));
+                } else {
+                    estate->sexp = estate->aux;
+                    estate->status = E_START;
+                }
+                break;
+            case E_LISTP:
+                if (estate->result == nil || estate->result->type == V_CONS) {
+                    estate->result = truth;
+                } else {
+                    estate->result = falsehood;
+                }
+                estate->status = E_DONE;
+                break;
+            case E_NULLP:
+                if (estate->result == nil) {
+                    estate->result = truth;
+                } else {
+                    estate->result = falsehood;
+                }
+                estate->status = E_DONE;
+                break;
+
+            /* ... */
+            case E_DONE:
+                printf("done.  result was: ");
+                dump(estate->result);
+                printf("\n");
+                if (estate->parent == NULL)
+                    return estate;
+                printf("popping...\n");
+                estate = pop_estate(estate);
+                break;
+            default:
+                /* ugh catchall for now */
+                break;
+        }
+    }
+    return estate;
+}

File impl/mignon/eval.h

+#ifndef EVAL_H_
+#define EVAL_H_
+
+#include "sexp.h"
+
+struct env {
+    struct atom *name;
+    struct value *value;
+    struct env *next;
+};
+
+enum estatus {
+    E_START,
+    E_CADR,
+    E_CAR,
+    E_CDR,
+    E_COND,
+    E_CONS_L,
+    E_CONS_R,
+    E_EQUALP_L,
+    E_EQUALP_R,
+    E_LET,
+    E_LISTP,
+    E_NULLP,
+    E_LAMBDA,
+    E_DONE
+};
+
+struct estate {
+    enum estatus status;
+    struct value *sexp;   /* the sexp we were working on */
+    struct env *env;      /* the env we were working in */
+    struct value *result; /* result we got from our child */
+    struct value *aux;    /* an auxilliary value for 2-arg things */
+    struct value *formals; /* for evaluating args to lambda */
+    struct env *build;     /* for building env to evaluate lambda */
+    struct estate *parent;
+};
+
+struct value *lookup(struct env *, struct atom *);
+struct env *bind(struct env *, struct atom *, struct value *);
+
+struct value *eval(struct value *, struct env *);
+struct estate *eval_resumable(struct estate *);
+struct estate *push_estate(struct estate *, struct env *, struct value *);
+struct estate *pop_estate(struct estate *);
+
+#endif /* !EVAL_H_ */

File impl/mignon/main.c

+#include <stdio.h>
+#include <stdlib.h>
+
+#include "sexp.h"
+#include "parse.h"
+#include "eval.h"
+
+int main(int argc, char **argv)
+{
+    struct pstate *state = initial_pstate(argv[1]);
+    struct env *env = NULL;
+    int done = 0;
+    int argn = 1;
+
+    nil = (struct value *)atom("nil");
+
+    while (!done) {
+        state = parse_resumable(state);
+        /*dump_pstate(state);*/
+        if (state->status == P_DONE) {
+            /*
+            printf("Program: ");
+            dump(state->result);
+            printf("\n");
+            */
+            struct estate *estate = push_estate(NULL, env, state->result);
+            estate = eval_resumable(estate);
+            /*printf("Result: ");*/
+            dump(estate->result);
+            printf("\n");
+            done = 1;
+        } else {
+            argn++;
+            state->ptr = argv[argn];
+        }
+    }
+    free(state);
+    argc = argc;
+    exit(0);
+}

File impl/mignon/mignon.c

+#ifndef SEXP_H_
+#define SEXP_H_
+
+enum vtype {
+    V_CONS,
+    V_ATOM,
+    V_LAMBDA
+};
+
+/*
+ * Cast this to struct cons or struct atom after examining type.
+ */
+struct value {
+    enum vtype type;
+};
+
+struct cons {
+    enum vtype type; /* = V_CONS */
+    struct value *head;
+    struct value *tail;
+};
+
+struct atom {
+    enum vtype type; /* = V_ATOM */
+    char *string;
+    struct atom *next;
+};
+
+struct lambda {
+    enum vtype type; /* = V_LAMBDA */
+    struct env *env;
+    struct value *formals;
+    struct value *body;
+};
+
+extern struct value *nil;
+
+struct value *cons(struct value *, struct value *);
+struct value *head(struct value *);
+struct value *tail(struct value *);
+struct value *atom(const char *);
+int equal(struct value *, struct value *);
+void dump(struct value *);
+
+#endif /* !SEXP_H_ */
+#ifndef EVAL_H_
+#define EVAL_H_
+
+
+struct env {
+    struct atom *name;
+    struct value *value;
+    struct env *next;
+};
+
+struct value *lookup(struct env *, struct atom *);
+struct env *bind(struct env *, struct atom *, struct value *);
+
+struct value *eval(struct value *, struct env *);
+
+#endif /* !EVAL_H_ */
+#ifndef PARSE_H_
+#define PARSE_H_
+
+
+enum pstatus {
+    P_START,  /* before we know if we have an atom or a list */
+    P_ATOM,
+    P_LIST,
+    P_DONE
+};
+
+struct pstate { /* like ptarmigan, psychic, pshrimp... */
+    /* where we are in the string */
+    const char *ptr;
+    /* for list: head of the list we are currently constructing */
+    struct cons *head;
+    /* for list: tail of the list we are currently constructing */
+    struct cons *tail;
+    /* for list: previous tail of the list (for linking up) */
+    struct cons *prev;
+    /* result of parsing so far in this level */
+    struct value *result;
+    /* result of what any child pstate parsed */
+    struct value *child_result;
+    /* where we are in the PDA's finite control, basically */
+    enum pstatus status;
+    /* to encode recursion */
+    struct pstate *parent;
+};
+
+struct pstate *initial_pstate(const char *);
+void dump_pstate(struct pstate *);
+void parse(struct pstate *);
+void parse_list(struct pstate *);
+struct pstate *parse_resumable(struct pstate *);
+
+#endif /* !PARSE_H_ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+/* for interning */
+struct atom *atom_list;
+
+struct value *nil;
+
+struct value *cons(struct value *h, struct value *t)
+{
+    struct cons *c = malloc(sizeof *c);
+    c->type = V_CONS;
+    c->head = h;
+    c->tail = t;
+    return (struct value *)c;
+}
+
+struct value *head(struct value *v)
+{
+    if (v->type != V_CONS) {
+        printf("Cannot get the head of non-cons cell ");
+        dump(v);
+        printf("\n");
+        exit(1);
+    }
+    return ((struct cons *)v)->head;
+}
+
+struct value *tail(struct value *v)
+{
+    if (v->type != V_CONS) {
+        printf("Cannot get the tail of non-cons cell ");
+        dump(v);
+        printf("\n");
+        exit(1);
+    }
+    return ((struct cons *)v)->tail;
+}
+
+struct value *atom(const char *s)
+{
+    struct atom *a;
+    for (a = atom_list; a != NULL; a = a->next) {
+        if (strcmp(a->string, s) == 0)
+            break;
+    }
+    if (a == NULL) {
+        a = malloc(sizeof *a);
+        a->type = V_ATOM;
+        a->string = malloc(strlen(s) + 1);
+        strcpy(a->string, s);
+        a->next = atom_list;
+        atom_list = a;
+    }
+    return (struct value *)a;
+}
+
+int equal(struct value *a, struct value *b)
+{
+    if (a->type != b->type) {
+        return 0;
+    } else switch (a->type) {
+        case V_ATOM:
+            return a == b;
+        case V_CONS:
+            while (a->type == V_CONS && b->type == V_CONS) {
+                if (!equal(head(a), head(b))) {
+                    return 0;
+                } else {
+                    a = tail(a);
+                    b = tail(b);
+                }
+            }
+            return a == b;
+        case V_LAMBDA:
+            return 0;
+    }
+    return 0;
+}
+
+void dump(struct value *v)
+{
+    switch (v->type) {
+        case V_CONS:
+            printf("(");
+            dump(((struct cons *)v)->head);
+            printf(".");
+            dump(((struct cons *)v)->tail);
+            printf(")");
+            break;
+        case V_ATOM:
+            printf("%s", ((struct atom *)v)->string);
+            break;
+        case V_LAMBDA:
+            printf("(lambda ");
+            dump(((struct lambda *)v)->formals);
+            printf(" ");
+            dump(((struct lambda *)v)->body);
+            printf(")");
+            break;
+    }
+}
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+
+
+struct value *lookup(struct env *env, struct atom *name)
+{
+    for (; env != NULL; env = env->next) {
+        if (env->name == name) {
+            return env->value;
+        }
+    }
+    return NULL;
+}
+
+struct env *bind(struct env *env, struct atom *name, struct value *value)
+{
+    struct env *e = malloc(sizeof *e);
+    e->name = name;
+    e->value = value;
+    e->next = env;
+    return e;
+}
+
+struct value *eval(struct value *sexp, struct env *env)
+{
+    struct value *cadr = atom("cadr");
+    struct value *car = atom("car");
+    struct value *cdr = atom("cdr");
+    struct value *cond = atom("cond");
+    struct value *cons_ = atom("cons");
+    struct value *else_ = atom("else");
+    struct value *equalp = atom("equal?");
+    struct value *lambda = atom("lambda");
+    struct value *let = atom("let*");
+    struct value *listp = atom("list?");
+    struct value *nullp = atom("null?");
+    struct value *quote = atom("quote");
+    struct value *truth = atom("#t");
+    struct value *falsehood = atom("#f");
+
+    if (sexp->type == V_ATOM) {
+        struct atom *name = (struct atom *)sexp;
+        struct value *value = lookup(env, name);
+        if (value == NULL) {
+            printf("Atom ");
+            dump(sexp);
+            printf(" has no meaning\n");
+            exit(1);
+        }
+        return value;
+    } else /* sexp->type == V_CONS) */ {
+        struct value *h = head(sexp);
+        struct value *t = tail(sexp);
+        struct value *bound = lookup(env, (struct atom *)h);
+        if (bound != NULL) {
+            /* this could be SO much more efficient */
+            struct value *newprog = cons(bound, t);
+            return eval(newprog, env);
+        } else if (h == cadr) {
+            struct value *k = eval(head(t), env);
+            return head(tail(k));
+        } else if (h == car) {
+            struct value *k = eval(head(t), env);
+            return head(k);
+        } else if (h == cdr) {
+            struct value *k = eval(head(t), env);
+            return tail(k);
+        } else if (h == cond) {
+            struct value *branch = head(t);
+            /* this will error out with car(nil) if no 'else' in cond */
+            while (1) {
+                struct value *test = head(branch);
+                struct value *expr = head(tail(branch));
+                /*
+                printf("branch: ");
+                dump(branch);
+                printf("\n");
+                */                
+                if (test == else_) {
+                    return eval(expr, env);
+                } else {
+                    test = eval(test, env);
+                    if (test != falsehood) {
+                        return eval(expr, env);
+                    }
+                }
+                t = tail(t);
+                branch = head(t);
+            }
+            return nil;
+        } else if (h == cons_) {
+            struct value *j = eval(head(t), env);
+            struct value *k = eval(head(tail(t)), env);
+            return cons(j, k);
+        } else if (h == equalp) {
+            struct value *j = eval(head(t), env);
+            struct value *k = eval(head(tail(t)), env);
+            if (equal(j, k)) {
+                return truth;
+            } else {
+                return falsehood;
+            }
+        } else if (h == lambda) {
+            /* (lambda (a b c) (let ...)) */
+            struct lambda *l = malloc(sizeof *l);
+            l->type = V_LAMBDA;
+            l->env = env;
+            l->formals = head(t);
+            l->body = head(tail(t));
+            return (struct value *)l;
+        } else if (h == let) {
+            /* (let* ((a b) (c d)) body) */
+            /* t = ( ((a b) (c d)) body) */
+            /* head(t) = ((a b) (c d)) */
+            /* tail(t) = (body) */
+            struct value *pairs = head(t);
+            struct value *body = head(tail(t));
+
+            while (pairs != nil) {
+                struct value *pair = head(pairs);
+                struct value *name = head(pair);
+                struct value *value = eval(head(tail(pair)), env);
+                /*
+                printf("let ");
+                dump(name);
+                printf(" = ");
+                dump(value);
+                printf("\n");
+                */
+                /* TODO: check that head(pair) is an atom! */
+                env = bind(env, (struct atom *)name, value);
+                pairs = tail(pairs);
+            }
+            /* TODO: free the no-longer-used parts of env */
+            return eval(body, env);
+        } else if (h == listp) {
+            struct value *k = eval(head(t), env);
+            if (k == nil || k->type == V_CONS) {
+                return truth;
+            } else {
+                return falsehood;
+            }
+        } else if (h == nullp) {
+            struct value *k = eval(head(t), env);
+            if (k == nil) {
+                return truth;
+            } else {
+                return falsehood;
+            }
+        } else if (h == quote) {
+            return head(t);
+        } else if (h->type == V_LAMBDA) {
+            struct lambda *l = (struct lambda *)h;
+            struct value *formals = l->formals;
+            env = l->env;
+            while (t->type == V_CONS) {
+                struct value *formal = head(formals);
+                struct value *value = eval(head(t), env);
+                env = bind(env, (struct atom *)formal, value);
+                formals = tail(formals);
+                t = tail(t);
+            }
+            return eval(l->body, env);
+            
+            /*
+                           (arg-vals    (interpret-args interpret-args args env))
+                           (arg-env     (expand-args expand-args l->formals arg-vals))
+                           (new-env     (concat-envs concat-envs arg-env l->closure-env)))
+                      (interpret interpret body new-env)))
+            */
+            return head(t);
+        } else {
+            printf("Cannot evaluate ");
+            dump(h);
+            printf("\n");
+            exit(1);
+        }
+    }
+}
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+
+
+struct pstate *initial_pstate(const char *string)
+{
+    struct pstate *state;
+    state = malloc(sizeof(struct pstate));
+    state->ptr = string;
+    state->result = NULL;
+    state->child_result = NULL;
+    state->status = P_START;
+    state->parent = NULL;
+    return state;
+}
+
+static struct pstate *stack_pstate(struct pstate *parent)
+{
+    struct pstate *state;
+    state = malloc(sizeof(struct pstate));
+    state->ptr = parent->ptr;
+    state->result = NULL;
+    state->child_result = NULL;
+    state->status = P_START;
+    state->parent = parent;
+    return state;
+}
+
+static struct pstate *unstack_pstate(struct pstate *state)
+{
+    struct pstate *parent = state->parent;
+    parent->ptr = state->ptr;
+    parent->child_result = state->result;
+    free(state);
+    return parent;
+}
+
+void dump_pstate(struct pstate *state)
+{
+    while (state != NULL) {
+        fprintf(stderr, "{%s,%d}", state->ptr, state->status);
+        state = state->parent;
+    }
+    fprintf(stderr, "!\n");
+}
+
+struct pstate *parse_resumable(struct pstate *state)
+{
+    int done = 0;
+    while (!done) {
+        /* dump_pstate(state); */
+        switch (state->status) {
+        case P_START:
+          {
+            while (isspace(*(state->ptr))) {
+                state->ptr++;
+            }
+            if (*(state->ptr) == (char)0) {
+                return state;
+            }
+            if (*(state->ptr) == '(') {
+                state->ptr++;
+                state->status = P_LIST;
+                state->head = NULL;
+                state->tail = NULL;
+                state->prev = NULL;
+            } else {
+                state->status = P_ATOM;
+            }
+          }
+          break;
+        case P_ATOM:
+          {
+            char sym[128];
+            int i = 0;
+            while (isalpha(*(state->ptr)) ||
+                   *(state->ptr) == '*' ||
+                   *(state->ptr) == '-' ||
+                   *(state->ptr) == '_' ||
+                   *(state->ptr) == '?') {
+                sym[i] = *(state->ptr);
+                state->ptr++;
+                i++;
+            }
+            sym[i] = 0;
+            state->result = atom(sym);
+            state->status = P_DONE;
+            break;
+          }
+        case P_LIST:
+          {
+            /* if we just parsed a child of this list... */
+            if (state->child_result != NULL) {
+                state->tail = (struct cons *)cons(nil, nil);
+                if (state->prev != NULL) {
+                    state->prev->tail = (struct value *)state->tail;
+                }
+                if (state->head == NULL) {
+                    state->head = state->tail;
+                }
+                state->tail->head = state->child_result;
+                state->child_result = NULL;
+                state->prev = state->tail;
+            }
+            while (isspace(*(state->ptr))) {
+                state->ptr++;
+            }
+            if (*(state->ptr) == (char)0) {
+                return state;
+            }
+            if (*(state->ptr) == ')') {
+                state->ptr++;
+                state->result = (struct value *)state->head;
+                state->status = P_DONE;
+                break;
+            } else {
+                /* create a new level in P_START. */
+                state = stack_pstate(state);
+            }
+            break;
+          }
+        case P_DONE:
+            if (state->parent != NULL) {
+                state = unstack_pstate(state);
+            } else {
+                done = 1;
+            }
+            break;
+        }
+    }
+    return state;
+}
+#include <stdio.h>
+#include <stdlib.h>
+
+
+int main(int argc, char **argv)
+{
+    struct pstate *state = initial_pstate(argv[1]);
+    struct value *result;
+    struct env *env = NULL;
+    int done = 0;
+    int argn = 1;
+
+    nil = (struct value *)atom("nil");
+
+    while (!done) {
+        state = parse_resumable(state);
+        /*dump_pstate(state);*/
+        if (state->status == P_DONE) {
+            printf("Program: ");
+            dump(state->result);
+            printf("\n");
+            result = eval(state->result, env);
+            printf("Result: ");
+            dump(result);
+            printf("\n");
+            done = 1;
+        } else {
+            argn++;
+            state->ptr = argv[argn];
+        }
+    }
+    free(state);
+    argc = argc;
+    exit(0);
+}

File impl/mignon/parse.c

+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+
+#include "parse.h"
+#include "sexp.h"
+
+struct pstate *initial_pstate(const char *string)
+{
+    struct pstate *state;
+    state = malloc(sizeof(struct pstate));
+    state->ptr = string;
+    state->result = NULL;
+    state->child_result = NULL;
+    state->status = P_START;
+    state->parent = NULL;
+    return state;
+}
+
+static struct pstate *stack_pstate(struct pstate *parent)
+{
+    struct pstate *state;
+    state = malloc(sizeof(struct pstate));
+    state->ptr = parent->ptr;
+    state->result = NULL;
+    state->child_result = NULL;
+    state->status = P_START;
+    state->parent = parent;
+    return state;
+}
+
+static struct pstate *unstack_pstate(struct pstate *state)
+{
+    struct pstate *parent = state->parent;
+    parent->ptr = state->ptr;
+    parent->child_result = state->result;
+    free(state);
+    return parent;
+}
+
+void dump_pstate(struct pstate *state)
+{
+    while (state != NULL) {
+        fprintf(stderr, "{%s,%d}", state->ptr, state->status);
+        state = state->parent;
+    }
+    fprintf(stderr, "!\n");
+}
+
+struct pstate *parse_resumable(struct pstate *state)
+{
+    int done = 0;
+    while (!done) {
+        /* dump_pstate(state); */
+        switch (state->status) {
+            case P_START:
+            {
+                while (isspace(*(state->ptr))) {
+                    state->ptr++;
+                }
+                if (*(state->ptr) == (char)0) {
+                    return state;
+                }
+                if (*(state->ptr) == '(') {
+                    state->ptr++;
+                    state->status = P_LIST;
+                    state->head = NULL;
+                    state->tail = NULL;
+                    state->prev = NULL;
+                } else {
+                    state->status = P_ATOM;
+                }
+                break;
+            }
+            case P_ATOM:
+            {
+                char sym[128];
+                int i = 0;
+                while (isalpha(*(state->ptr)) ||
+                       *(state->ptr) == '*' ||
+                       *(state->ptr) == '-' ||
+                       *(state->ptr) == '_' ||
+                       *(state->ptr) == '?') {
+                    sym[i] = *(state->ptr);
+                    state->ptr++;
+                    i++;
+                }
+                sym[i] = 0;
+                state->result = atom(sym);
+                state->status = P_DONE;
+                break;
+            }
+            case P_LIST:
+            {
+                /* if we just parsed a child of this list... */
+                if (state->child_result != NULL) {
+                    state->tail = (struct cons *)cons(nil, nil);
+                    if (state->prev != NULL) {
+                        state->prev->tail = (struct value *)state->tail;
+                    }
+                    if (state->head == NULL) {
+                        state->head = state->tail;
+                    }
+                    state->tail->head = state->child_result;
+                    state->child_result = NULL;
+                    state->prev = state->tail;
+                }
+                while (isspace(*(state->ptr))) {
+                    state->ptr++;
+                }
+                if (*(state->ptr) == (char)0) {
+                    return state;
+                }
+                if (*(state->ptr) == ')') {
+                    state->ptr++;
+                    state->result = (struct value *)state->head;
+                    state->status = P_DONE;
+                    break;
+                } else {
+                    /* create a new level in P_START. */
+                    state = stack_pstate(state);
+                }
+                break;
+            }
+            case P_DONE:
+                if (state->parent != NULL) {
+                    state = unstack_pstate(state);
+                } else {
+                    done = 1;
+                }
+                break;
+        }
+    }
+    return state;
+}

File impl/mignon/parse.h

+#ifndef PARSE_H_
+#define PARSE_H_
+
+#include "sexp.h"
+
+enum pstatus {
+    P_START,  /* before we know if we have an atom or a list */
+    P_ATOM,
+    P_LIST,
+    P_DONE
+};
+
+struct pstate { /* like ptarmigan, psychic, pshrimp... */
+    /* where we are in the string */
+    const char *ptr;
+    /* for list: head of the list we are currently constructing */
+    struct cons *head;
+    /* for list: tail of the list we are currently constructing */
+    struct cons *tail;
+    /* for list: previous tail of the list (for linking up) */
+    struct cons *prev;
+    /* result of parsing so far in this level */
+    struct value *result;
+    /* result of what any child pstate parsed */
+    struct value *child_result;
+    /* where we are in the PDA's finite control, basically */
+    enum pstatus status;
+    /* to encode recursion */
+    struct pstate *parent;
+};
+
+struct pstate *initial_pstate(const char *);
+void dump_pstate(struct pstate *);
+void parse(struct pstate *);
+void parse_list(struct pstate *);
+struct pstate *parse_resumable(struct pstate *);
+
+#endif /* !PARSE_H_ */

File impl/mignon/sexp.c

+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "sexp.h"
+
+/* for interning */
+struct atom *atom_list;
+
+struct value *nil;
+
+/* for gc */
+struct value *chain = NULL;
+
+struct value *cons(struct value *h, struct value *t)
+{
+    struct cons *c = malloc(sizeof *c);
+    c->type = V_CONS;
+    c->chain = chain;
+    c->head = h;
+    c->tail = t;
+    chain = (struct value *)c;
+    return (struct value *)c;
+}
+
+struct value *head(struct value *v)
+{
+    if (v->type != V_CONS) {
+        printf("Cannot get the head of non-cons cell ");
+        dump(v);
+        printf("\n");
+        exit(1);
+    }
+    return ((struct cons *)v)->head;
+}
+
+struct value *tail(struct value *v)
+{
+    if (v->type != V_CONS) {
+        printf("Cannot get the tail of non-cons cell ");
+        dump(v);
+        printf("\n");
+        exit(1);
+    }
+    return ((struct cons *)v)->tail;
+}
+
+struct value *atom(const char *s)
+{
+    struct atom *a;
+    for (a = atom_list; a != NULL; a = a->next) {
+        if (strcmp(a->string, s) == 0)
+            break;
+    }
+    if (a == NULL) {
+        a = malloc(sizeof *a);
+        a->type = V_ATOM;
+        a->chain = NULL; /* atoms are not GC'ed */
+        a->string = malloc(strlen(s) + 1);
+        strcpy(a->string, s);
+        a->next = atom_list;
+        atom_list = a;
+    }
+    return (struct value *)a;
+}
+
+struct value *lambda(struct env *env, struct value *formals, struct value *body)
+{
+    struct lambda *l = malloc(sizeof *l);
+    l->type = V_LAMBDA;
+    l->chain = chain;
+    l->env = env;
+    l->formals = formals;
+    l->body = body;
+    chain = (struct value *)l;
+    return (struct value *)l;
+}
+
+int equal(struct value *a, struct value *b)
+{
+    if (a->type != b->type) {
+        return 0;
+    } else switch (a->type) {
+        case V_ATOM:
+            return a == b;
+        case V_CONS:
+            while (a->type == V_CONS && b->type == V_CONS) {
+                if (!equal(head(a), head(b))) {
+                    return 0;
+                } else {
+                    a = tail(a);
+                    b = tail(b);
+                }
+            }
+            return a == b;
+        case V_LAMBDA:
+            return 0;
+    }
+    return 0;
+}
+
+void dump(struct value *v)
+{
+    switch (v->type) {
+        case V_CONS:
+            printf("(");
+            while (v->type == V_CONS) {
+                struct value *h = ((struct cons *)v)->head;
+                struct value *t = ((struct cons *)v)->tail;
+                dump(h);
+                v = t;
+                if (v->type == V_CONS) {
+                    printf(" ");
+                }
+            }
+            if (v != nil) {
+                printf(" . ");
+                dump(v);
+            }
+            printf(")");
+            break;
+        case V_ATOM:
+            printf("%s", ((struct atom *)v)->string);
+            break;
+        case V_LAMBDA:
+            printf("(lambda ");
+            dump(((struct lambda *)v)->formals);
+            printf(" ");
+            dump(((struct lambda *)v)->body);
+            printf(")");
+            break;
+    }
+}

File impl/mignon/sexp.h

+#ifndef SEXP_H_
+#define SEXP_H_
+
+enum vtype {
+    V_CONS,
+    V_ATOM,
+    V_LAMBDA
+};
+
+/*
+ * Cast this to struct cons or struct atom after examining type.
+ */
+struct value {
+    enum vtype type;
+    struct value *chain; /* for garbage collection */
+};
+
+struct cons {
+    enum vtype type; /* = V_CONS */
+    struct value *chain; /* for garbage collection */
+    struct value *head;
+    struct value *tail;
+};
+
+struct atom {
+    enum vtype type; /* = V_ATOM */
+    struct value *chain; /* for garbage collection */
+    char *string;
+    struct atom *next;
+};
+
+struct lambda {
+    enum vtype type; /* = V_LAMBDA */
+    struct value *chain; /* for garbage collection */
+    struct env *env;
+    struct value *formals;
+    struct value *body;
+};
+
+extern struct value *nil;
+
+struct value *cons(struct value *, struct value *);
+struct value *head(struct value *);
+struct value *tail(struct value *);
+struct value *atom(const char *);
+struct value *lambda(struct env *, struct value *, struct value *);
+int equal(struct value *, struct value *);
+void dump(struct value *);
+
+#endif /* !SEXP_H_ */