Basic evaluation, exceptions, and the stack

src/lisp.c

@@ -6,7 +6,6 @@
 #include <string.h>
 
 struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
-    [TYPE_NULL] = {"null", sizeof("null") - 1},
     [TYPE_STRING] = {"string", sizeof("string") - 1},
     [TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
     [TYPE_PAIR] = {"pair", sizeof("pair") - 1},
@@ -17,9 +16,15 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
     [TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
 };
 
-LispVal _Qnil = {
+DEF_STATIC_STRING(_Qnil_name, "nil");
-    .type = TYPE_NULL,
+LispSymbol _Qnil = {
+    .type = TYPE_SYMBOL,
     .ref_count = -1,
+    .name = &_Qnil_name,
+    .plist = Qnil,
+    .function = Qunbound,
+    .value = Qnil,
+    .is_constant = true,
 };
 
 DEF_STATIC_STRING(_Qunbound_name, "unbound");
@@ -30,6 +35,7 @@ LispSymbol _Qunbound = {
     .plist = Qnil,
     .function = Qunbound,
     .value = Qunbound,
+    .is_constant = true,
 };
 
 DEF_STATIC_STRING(_Qt_name, "t");
@@ -39,16 +45,15 @@ LispSymbol _Qt = {
     .name = &_Qt_name,
     .plist = Qnil,
     .function = Qunbound,
-    .value = Qunbound,
+    .value = Qt,
+    .is_constant = true,
 };
 
-DEF_STATIC_SYMBOL(quote, "'");
 DEF_STATIC_SYMBOL(backquote, "`");
 DEF_STATIC_SYMBOL(comma, ",");
 
 void _internal_lisp_delete_object(LispVal *val) {
     switch (TYPEOF(val)) {
-    case TYPE_NULL:
     case TYPE_INTEGER:
     case TYPE_FLOAT:
         lisp_free(val);
@@ -81,9 +86,20 @@ void _internal_lisp_delete_object(LispVal *val) {
         lisp_free(vec->data);
         lisp_free(val);
     } break;
-    case TYPE_FUNCTION:
+    case TYPE_FUNCTION: {
-        // TODO handle
+        LispFunction *fn = (LispFunction *) val;
-        break;
+        lisp_unref(fn->doc);
+        lisp_unref(fn->args);
+        for (size_t i = 0; i < fn->n_kw; ++i) {
+            lisp_unref(fn->kwargs[i]);
+        }
+        lisp_free(fn->kwargs);
+        if (!fn->is_builtin) {
+            lisp_unref(fn->body);
+        }
+        lisp_unref(fn->lexenv);
+        lisp_free(val);
+    } break;
     case TYPE_HASHTABLE: {
         LispHashtable *tbl = (LispHashtable *) val;
         for (size_t i = 0; i < tbl->table_size; ++i) {
@@ -121,13 +137,6 @@ void *lisp_realloc(void *old_ptr, size_t size) {
     return new_ptr;
 }
 
-char *lisp_strdup(const char *str) {
-    size_t len = strlen(str);
-    char *new_str = lisp_malloc(len + 1);
-    memcpy(new_str, str, len + 1);
-    return new_str;
-}
-
 LispVal *make_lisp_string(const char *data, size_t length, bool take,
                           bool is_static) {
     LispString *self = lisp_malloc(sizeof(LispString));
@@ -136,7 +145,9 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take,
     if (take) {
         self->data = (char *) data;
     } else {
-        self->data = lisp_strdup(data);
+        self->data = lisp_malloc(length + 1);
+        memcpy(self->data, data, length);
+        self->data[length] = '\0';
     }
     self->length = length;
     self->is_static = is_static;
@@ -280,8 +291,15 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
     } else if (self->eq_fn == Qstrings_equal) {
         return !NILP(Fstrings_equal(v1, v2));
     } else {
-        // TODO call the function
+        LispVal *eq_obj;
-        return false;
+        LispVal *args = make_list(2, v1, v2);
+        WITH_CLEANUP(args, {
+            eq_obj = lisp_ref(Ffuncall(self->eq_fn, args)); //
+        });
+        lisp_ref(eq_obj);
+        bool result = !NILP(eq_obj);
+        lisp_unref(eq_obj);
+        return result;
     }
 }
 
@@ -289,14 +307,23 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
     if (NILP(self->hash_fn)) {
         return (uint64_t) key;
     } else if (self->hash_fn == Qhash_string) {
-        // Make obarray lookups faster
+        // Make obarray and lexenv lookups faster
         LispVal *hash_obj = Fhash_string(key);
         uint64_t hash = ((LispInteger *) hash_obj)->value;
         UNREF_INPLACE(hash_obj);
         return hash;
     } else {
-        // TODO call the hash function
+        LispVal *hash_obj;
-        return 0;
+        LispVal *args = make_list(1, key);
+        WITH_CLEANUP(args, {
+            hash_obj = Ffuncall(self->hash_fn, args); //
+        });
+        uint64_t hash;
+        WITH_CLEANUP(hash_obj, {
+            CHECK_TYPE(TYPE_INTEGER, hash_obj);
+            hash = ((LispInteger *) hash_obj)->value;
+        });
+        return hash;
     }
 }
 
@@ -440,35 +467,424 @@ DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
     return Qnil;
 }
 
-DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
+size_t list_length(LispVal *obj) {
-    if (!SYMBOLP(signal)) {
+    if (NILP(obj)) {
-        printf("Attempt to throw non-symbol value!\n");
+        return 0;
-    } else {
-        LispSymbol *sym = (LispSymbol *) signal;
-        printf("Throw %*s! Data: ", (int) sym->name->length, sym->name->data);
-        debug_dump(stdout, rest, true);
     }
-    return Qnil;
+    CHECK_TYPE(TYPE_PAIR, obj);
+    size_t length = 0;
+    LispPair *tortise = (LispPair *) obj;
+    LispPair *hare = (LispPair *) tortise->tail;
+    while (!NILP(tortise)) {
+        if (!LISTP(LISPVAL(tortise))) {
+            break;
+        } else if (tortise == hare) {
+            Fthrow(Qcircular_error, Qnil);
+        }
+        ++length;
+        tortise = (LispPair *) tortise->tail;
+        if (PAIRP(hare)) {
+            if (PAIRP(((LispPair *) hare)->tail)) {
+                hare = (LispPair *) ((LispPair *) hare->tail)->tail;
+            } else if (NILP(((LispPair *) hare)->tail)) {
+                hare = (LispPair *) Qnil;
+            }
+        }
+    }
+    return length;
 }
 
+StackFrame *the_stack = NULL;
+DEF_STATIC_SYMBOL(toplevel, "toplevel");
+DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
+
+void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
+    StackFrame *frame = lisp_malloc(sizeof(StackFrame));
+    frame->name = lisp_ref(name);
+    frame->hidden = false;
+    frame->detail = lisp_ref(detail);
+    frame->lexenv = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
+    if (inherit && the_stack) {
+        Fputhash(LISPVAL(frame->lexenv), Qparent_lexenv,
+                 LISPVAL(the_stack->lexenv));
+    }
+    frame->enable_handlers = true;
+    frame->handlers = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
+    frame->unwind_forms = Qnil;
+    frame->cleanup_handlers = NULL;
+
+    frame->next = the_stack;
+    the_stack = frame;
+}
+
+void stack_leave(void) {
+    StackFrame *frame = the_stack;
+    the_stack = the_stack->next;
+    lisp_unref(frame->name);
+    lisp_unref(frame->detail);
+    lisp_unref(frame->lexenv);
+    lisp_unref(frame->handlers);
+    FOREACH(elt, frame->unwind_forms) {
+        WITH_PUSH_FRAME(Qnil, Qnil, false, {
+            IGNORE_REF(Feval(elt)); //
+        });
+    }
+    lisp_unref(frame->unwind_forms);
+    while (frame->cleanup_handlers) {
+        frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
+        struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
+        lisp_free(frame->cleanup_handlers);
+        frame->cleanup_handlers = next;
+    }
+    lisp_free(frame);
+}
+
+void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
+    struct CleanupHandlerEntry *entry =
+        lisp_malloc(sizeof(struct CleanupHandlerEntry));
+    entry->fun = fun;
+    entry->data = data;
+    entry->next = the_stack->cleanup_handlers;
+    the_stack->cleanup_handlers = entry;
+    return entry;
+}
+
+void cancel_cleanup(void *handle) {
+    struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers;
+    if (entry == handle) {
+        the_stack->cleanup_handlers = entry->next;
+        free(entry);
+    } else {
+        while (entry) {
+            if (entry->next == handle) {
+                struct CleanupHandlerEntry *to_free = entry->next;
+                entry->next = entry->next->next;
+                free(to_free);
+                break;
+            }
+            entry = entry->next;
+        }
+    }
+}
+
+DEFUN(backtrace, "backtrace", ()) {
+    LispVal *head = Qnil;
+    LispVal *end;
+    for (StackFrame *frame = the_stack; frame; frame = frame->next) {
+        if (frame->hidden) {
+            continue;
+        }
+        if (NILP(head)) {
+            head = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
+            end = head;
+        } else {
+            LispVal *new_end =
+                Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
+            Fsettail(end, new_end);
+            end = new_end;
+        }
+    }
+    return head;
+}
+
+DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
+    CHECK_TYPE(TYPE_SYMBOL, signal);
+    LispVal *backtrace = Fbacktrace();
+    for (; the_stack; stack_leave()) {
+        if (!the_stack->enable_handlers) {
+            continue;
+        }
+        LispVal *handler =
+            Fgethash(LISPVAL(the_stack->handlers), signal, Qunbound);
+        if (handler == Qunbound) {
+            // handler for all exceptions
+            handler = Fgethash(LISPVAL(the_stack->handlers), Qt, Qunbound);
+        }
+        if (handler != Qunbound) {
+            the_stack->enable_handlers = false;
+            LispVal *var = Fhead(handler);
+            LispVal *form = Ftail(handler);
+            WITH_PUSH_FRAME(Qnil, Qnil, true, {
+                the_stack->hidden = true;
+                if (!NILP(var)) {
+                    // TODO make sure this isn't constant
+                    Fputhash(the_stack->lexenv, var,
+                             make_list(2, Fpair(signal, rest), backtrace));
+                }
+                WITH_CLEANUP(backtrace, {
+                    IGNORE_REF(Feval(form)); //
+                });
+            });
+            longjmp(the_stack->start, 1); // return a nonzero value
+        }
+    }
+    // we never used it, so drop it
+    lisp_unref(backtrace);
+    fprintf(stderr,
+            "ERROR: An exception has propogated past the top of the stack!\n");
+    fprintf(stderr, "Type: ");
+    debug_dump(stderr, signal, true);
+    fprintf(stderr, "Args: ");
+    debug_dump(stderr, rest, true);
+    fprintf(stderr, "Lisp will now exit...");
+    abort();
+}
+
+DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
 DEF_STATIC_SYMBOL(type_error, "type-error");
 DEF_STATIC_SYMBOL(read_error, "read-error");
+DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
+DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
+DEF_STATIC_SYMBOL(circular_error, "circular-error");
 
 LispVal *Vobarray = Qnil;
 
 void lisp_init() {
     Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));
+
+#define REGISTER_SYMBOL(fn) \
+    Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn)
+
+    REGISTER_SYMBOL(nil);
+    REGISTER_SYMBOL(t);
+
+    // TODO fill in the other fields
+    REGISTER_SYMBOL(pair);
+    REGISTER_SYMBOL(head);
+    REGISTER_SYMBOL(tail);
+    REGISTER_SYMBOL(quote);
+    REGISTER_SYMBOL(exit);
+#undef REGISTER_SYMBOL
 }
 
 void lisp_shutdown() {
     UNREF_INPLACE(Vobarray);
 }
 
+static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
+    while (HASHTABLEP(lexenv)) {
+        LispVal *value = Fgethash(lexenv, key, Qunbound);
+        if (value != Qunbound) {
+            return value;
+        }
+        lexenv = Fgethash(lexenv, Qparent_lexenv, Qunbound);
+    }
+    return Qunbound;
+}
+
+static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
+    if (!NILP(lexenv)) {
+        LispVal *local = find_in_lexenv(lexenv, key);
+        if (local != Qunbound) {
+            return local;
+        }
+    }
+    LispVal *sym_val = Fsymbol_value(key);
+    if (sym_val != Qunbound) {
+        return sym_val;
+    }
+    Fthrow(Qvoid_variable_error, make_list(1, key));
+}
+
+DEFUN(symbol_function, "symbol-function",
+      (LispVal * symbol, LispVal *resolve)) {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    if (NILP(resolve)) {
+        LispVal *fn = ((LispSymbol *) symbol)->function;
+        return fn == Qunbound ? Qnil : fn;
+    }
+    while (SYMBOLP(symbol) && symbol != Qunbound) {
+        symbol = ((LispSymbol *) symbol)->function;
+    }
+    return symbol;
+}
+
+DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
+    CHECK_TYPE(TYPE_SYMBOL, symbol);
+    return ((LispSymbol *) symbol)->value;
+}
+
+static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
+    LispVal *final_args = Qnil;
+    void *cl_handle = register_cleanup(
+        (lisp_cleanup_func_t) &lisp_unref_double_ptr, &final_args);
+    LispVal *end;
+    FOREACH(elt, args) {
+        if (NILP(final_args)) {
+            final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
+            end = final_args;
+        } else {
+            LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
+            Fsettail(end, new_end);
+            end = new_end;
+        }
+    }
+    cancel_cleanup(cl_handle);
+    return final_args;
+}
+
+static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
+    // TODO actually implement this
+    size_t count = list_length(args);
+    switch (count) {
+    case 0:
+        return ((LispVal * (*) ()) func->builtin)();
+    case 1:
+        return ((LispVal * (*) (LispVal * val)) func->builtin)(Fhead(args));
+    case 2:
+        return ((LispVal * (*) (LispVal * val1, LispVal * val2))
+                    func->builtin)(Fhead(args), Fhead(Ftail(args)));
+    case 3:
+        return ((LispVal * (*) (LispVal * val1, LispVal * val2, LispVal * val3))
+                    func->builtin)(Fhead(args), Fhead(Ftail(args)),
+                                   Fhead(Ftail(Ftail(args))));
+    /* case 4: */
+    /*     return func->builtin(HEAD(args)); */
+    /* case 5: */
+    /*     return func->builtin(HEAD(args)); */
+    /* case 6: */
+    /*     return func->builtin(HEAD(args)); */
+    default:
+        return ((LispVal * (*) (LispVal * val)) func->builtin)(args);
+    }
+}
+
+static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
+                                   LispVal *args) {
+    // TODO do this
+    return Qnil;
+}
+
+static void check_args_for_function(LispFunction *fun, LispVal *args) {}
+
+static LispVal *call_function(LispVal *func, LispVal *args,
+                              LispVal *args_lexenv, bool eval_args) {
+    LispFunction *fobj;
+    if (FUNCTIONP(func)) {
+        fobj = (LispFunction *) func;
+    } else {
+        fobj = (LispFunction *) Fsymbol_function(func, Qt);
+    }
+    if (LISPVAL(fobj) == Qunbound) {
+        Fthrow(Qvoid_function_error, make_list(1, func));
+    }
+    CHECK_TYPE(TYPE_FUNCTION, fobj);
+    if (!fobj->is_macro && eval_args) {
+        args = eval_function_args(args, args_lexenv);
+    }
+    lisp_ref(args);
+    LispVal *retval = Qnil;
+    WITH_PUSH_FRAME(func, args, false, {
+        void *cl_handle = register_cleanup(
+            (lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
+        check_args_for_function(fobj, args);
+        if (fobj->is_builtin) {
+            retval = call_builtin(func, fobj, args);
+        } else {
+            retval = call_lisp_function(func, fobj, args);
+        }
+        cancel_cleanup(cl_handle);
+    })
+    lisp_unref(args);
+    return retval;
+}
+
+DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
+    switch (TYPEOF(form)) {
+    case TYPE_STRING:
+    case TYPE_FUNCTION:
+    case TYPE_INTEGER:
+    case TYPE_FLOAT:
+    case TYPE_HASHTABLE:
+        // the above all are self-evaluating
+        return form;
+    case TYPE_SYMBOL:
+        return symbol_value_in_lexenv(lexenv, form);
+    case TYPE_VECTOR: {
+        LispVector *vec = (LispVector *) form;
+        LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length);
+        for (size_t i = 0; i < vec->length; ++i) {
+            elts[i] = lisp_ref(Feval_in_env(vec->data[i], lexenv));
+        }
+        return make_lisp_vector(elts, vec->length);
+    }
+    case TYPE_PAIR: {
+        LispPair *pair = (LispPair *) form;
+        return call_function(pair->head, pair->tail, lexenv, true);
+    }
+    default:
+        abort();
+    }
+}
+
+DEFUN(eval, "eval", (LispVal * form)) {
+    return Feval_in_env(form, LISPVAL(the_stack->lexenv));
+}
+
+DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
+    return call_function(function, rest, Qnil, false);
+}
+
+DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
+    LispVal *args = Qnil;
+    LispVal *end;
+    while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) {
+        if (NILP(args)) {
+            args = Fpair(((LispPair *) rest)->head, Qnil);
+            end = args;
+        } else {
+            LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
+            Fsettail(end, new_end);
+            end = new_end;
+        }
+        rest = ((LispPair *) rest)->tail;
+    }
+    if (LISTP(((LispPair *) rest)->head)) {
+        Fsettail(end, ((LispPair *) rest)->head);
+    } else {
+        LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
+
+        Fsettail(end, new_end);
+        end = new_end;
+    }
+    lisp_ref(args);
+    void *cl_handle =
+        register_cleanup((lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
+    LispVal *retval = Ffuncall(function, args);
+    cancel_cleanup(cl_handle);
+    lisp_unref(args);
+    return retval;
+}
+
+DEFUN(head, "head", (LispVal * list)) {
+    if (NILP(list)) {
+        return Qnil;
+    }
+    CHECK_TYPE(TYPE_PAIR, list);
+    return ((LispPair *) list)->head;
+}
+
+DEFUN(tail, "tail", (LispVal * list)) {
+    if (NILP(list)) {
+        return Qnil;
+    }
+    CHECK_TYPE(TYPE_PAIR, list);
+    return ((LispPair *) list)->tail;
+}
+
+DEFUN(exit, "exit", (LispVal * code)) {
+    if (!NILP(code) && !INTEGERP(code)) {
+        Fthrow(Qtype_error, Qnil);
+    }
+    Fthrow(Qshutdown_signal, make_list(1, code));
+}
+
+DEFMACRO(quote, "'", (LispVal * form)) {
+    return form;
+}
+
 static void debug_dump_real(FILE *stream, void *obj, bool first) {
     switch (TYPEOF(obj)) {
-    case TYPE_NULL:
-        fprintf(stream, "nil");
-        break;
     case TYPE_STRING: {
         LispString *str = (LispString *) obj;
         // TODO actually quote
@@ -499,7 +915,7 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
         }
     } break;
     case TYPE_INTEGER:
-        fprintf(stream, "%jd", ((LispInteger *) obj)->value);
+        fprintf(stream, "%jd", (intmax_t) ((LispInteger *) obj)->value);
         break;
     case TYPE_FLOAT:
         fprintf(stream, "%Lf", ((LispFloat *) obj)->value);

src/lisp.h

@@ -1,12 +1,14 @@
 #ifndef INCLUDED_LISP_H
 #define INCLUDED_LISP_H
 
+#include <setjmp.h>
 #include <stdarg.h>
 #include <stdbool.h>
 #include <stddef.h>
 #include <stdint.h>
 #include <stdio.h>
 #include <stdlib.h>
+#include <stdnoreturn.h>
 
 #if __has_attribute(format)
 #    define PRINTF_FORMAT(first, second) \
@@ -16,7 +18,6 @@
 #endif
 
 typedef enum {
-    TYPE_NULL = 0,
     TYPE_STRING,
     TYPE_SYMBOL,
     TYPE_PAIR,
@@ -61,6 +62,7 @@ typedef struct {
     LispVal *plist;
     LispVal *function;
     LispVal *value;
+    bool is_constant;
 } LispSymbol;
 
 typedef struct {
@@ -73,7 +75,7 @@ typedef struct {
 typedef struct {
     LISP_OBJECT_HEADER;
 
-    intmax_t value;
+    int64_t value;
 } LispInteger;
 
 typedef struct {
@@ -89,18 +91,25 @@ typedef struct {
     size_t length;
 } LispVector;
 
-typedef LispVal *(*lisp_builtin_t)();
-
 typedef struct {
     LISP_OBJECT_HEADER;
 
     LispVal *doc;
     LispVal *args;
     bool is_builtin;
+    bool is_macro;
+
+    size_t n_req;
+    size_t n_opt;
+    size_t n_kw;
+    LispVal **kwargs;
+    bool has_rest;
     union {
+        void *builtin;
         LispVal *body;
-        lisp_builtin_t builtin;
     };
+
+    LispVal *lexenv;
 } LispFunction;
 
 struct HashtableBucket {
@@ -125,7 +134,7 @@ typedef struct {
     LispVal *hash_fn;
 } LispHashtable;
 
-#define NILP(v)       (TYPEOF(v) == TYPE_NULL)
+#define NILP(v)       (((void *) (v)) == (void *) Qnil)
 #define STRINGP(v)    (TYPEOF(v) == TYPE_STRING)
 #define SYMBOLP(v)    (TYPEOF(v) == TYPE_SYMBOL)
 #define PAIRP(v)      (TYPEOF(v) == TYPE_PAIR)
@@ -137,6 +146,14 @@ typedef struct {
 
 #define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
 
+extern LispSymbol _Qnil;
+extern LispSymbol _Qunbound;
+extern LispSymbol _Qt;
+
+#define Qnil     (LISPVAL(&_Qnil))
+#define Qunbound (LISPVAL(&_Qunbound))
+#define Qt       (LISPVAL(&_Qt))
+
 inline static bool LISTP(LispVal *v) {
     return NILP(v) || PAIRP(v);
 }
@@ -145,15 +162,6 @@ inline static bool NUMBERP(LispVal *v) {
     return INTEGERP(v) || FLOATP(v);
 }
 
-extern LispVal _Qnil;
-extern LispSymbol _Qunbound;
-extern LispSymbol _Qt;
-
-#define Qnil     (&_Qnil)
-#define Qunbound (LISPVAL(&_Qunbound))
-#define Qt       (LISPVAL(&_Qt))
-
-extern LispVal *Qquote;
 extern LispVal *Qbackquote;
 extern LispVal *Qcomma;
 
@@ -176,13 +184,13 @@ extern LispVal *Qcomma;
         .plist = Qnil,                               \
         .function = Qunbound,                        \
         .value = Qunbound,                           \
+        .is_constant = false,                        \
     };                                               \
     LispVal *Q##c_name = LISPVAL(&_Q##c_name);
 
 void *lisp_malloc(size_t size);
 void *lisp_realloc(void *old_ptr, size_t size);
 #define lisp_free free
-char *lisp_strdup(const char *str);
 
 inline static void *lisp_ref(void *val) {
     if (!STATICP(val)) {
@@ -214,6 +222,10 @@ inline static void *lisp_unref(void *val) {
     {                                    \
         variable = lisp_unref(variable); \
     }
+inline static void lisp_unref_double_ptr(void **val) {
+    lisp_unref(*val);
+}
+#define IGNORE_REF(val) (lisp_unref(lisp_ref(val)))
 
 LispVal *make_lisp_string(const char *data, size_t length, bool take,
                           bool is_static);
@@ -228,29 +240,36 @@ LispVal *make_lisp_vector(LispVal **data, size_t length);
 LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
 
 #define DECLARE_FUNCTION(c_name, args) \
-    extern LispVal *Q##c_name;         \
+    LispVal *F##c_name args;           \
-    LispVal *F##c_name args;
+    extern LispVal *Q##c_name;
 
 // The args and doc fields are filled when the function is registered
-#define DEFUN(c_name, lisp_name, c_args)             \
+#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \
-    DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
+    LispVal *F##c_name c_args;                                      \
-    static LispFunction _Q##c_name##_function = {    \
+    DEF_STATIC_STRING(_Q##c_name##_name, lisp_name);                \
-        .type = TYPE_FUNCTION,                       \
+    static LispFunction _Q##c_name##_function = {                   \
-        .ref_count = -1,                             \
+        .type = TYPE_FUNCTION,                                      \
-        .doc = Qnil,                                 \
+        .ref_count = -1,                                            \
-        .args = Qnil,                                \
+        .is_builtin = true,                                         \
-        .is_builtin = true,                          \
+        .is_macro = macrop,                                         \
-        .builtin = &F##c_name,                       \
+        .builtin = &F##c_name,                                      \
-    };                                               \
+        .lexenv = Qnil,                                             \
-    static LispSymbol _Q##c_name = {                 \
+    };                                                              \
-        .type = TYPE_SYMBOL,                         \
+    static LispSymbol _Q##c_name = {                                \
-        .ref_count = -1,                             \
+        .type = TYPE_SYMBOL,                                        \
-        .name = &_Q##c_name##_name,                  \
+        .ref_count = -1,                                            \
-        .plist = Qnil,                               \
+        .name = &_Q##c_name##_name,                                 \
-        .function = LISPVAL(&_Q##c_name##_function), \
+        .plist = Qnil,                                              \
-    };                                               \
+        .value = Qunbound,                                          \
-    LispVal *Q##c_name = (LispVal *) &_Q##c_name;    \
+        .function = LISPVAL(&_Q##c_name##_function),                \
+        .is_constant = false,                                       \
+    };                                                              \
+    LispVal *Q##c_name = (LispVal *) &_Q##c_name;                   \
     LispVal *F##c_name c_args
+#define DEFUN(c_name, lisp_name, c_args) \
+    _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args)
+#define DEFMACRO(c_name, lisp_name, c_args) \
+    _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args)
 
 DECLARE_FUNCTION(type_of, (LispVal * obj));
 DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
@@ -285,6 +304,7 @@ LispVal *intern(const char *name, size_t length, bool take);
 
 DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
 DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
+size_t list_length(LispVal *obj);
 static inline LispVal *make_list(int len, ...) {
     LispVal *list = Qnil;
     LispVal *end;
@@ -304,22 +324,87 @@ static inline LispVal *make_list(int len, ...) {
     va_end(args);
     return list;
 }
+#define FOREACH(var, list)                                  \
+    for (LispVal *__foreach_cur = list, *var = Fhead(list); \
+         !NILP(__foreach_cur);                              \
+         __foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur))
 
-DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
+typedef void (*lisp_cleanup_func_t)(void *);
+struct CleanupHandlerEntry {
+    struct CleanupHandlerEntry *next;
+    lisp_cleanup_func_t fun;
+    void *data;
+};
+typedef struct StackFrame {
+    struct StackFrame *next;
+    bool hidden;
+    LispSymbol *name;
+    LispVal *detail; // function arguments
+    LispVal *lexenv; // symbol -> value
+    bool enable_handlers;
+    LispVal *handlers; // symbol -> (error-var form)
+    LispVal *unwind_forms;
+    struct CleanupHandlerEntry *cleanup_handlers;
 
+    jmp_buf start;
+} StackFrame;
+
+extern StackFrame *the_stack;
+extern LispVal *Qtoplevel;
+extern LispVal *Qparent_lexenv;
+
+void stack_enter(LispVal *name, LispVal *detail, bool inherit);
+void stack_leave(void);
+void *register_cleanup(lisp_cleanup_func_t fun, void *data);
+void cancel_cleanup(void *handle);
+#define WITH_PUSH_FRAME(name, detail, inherit, body) \
+    stack_enter(name, detail, inherit);              \
+    if (setjmp(the_stack->start) == 0) {             \
+        body                                         \
+    }                                                \
+    stack_leave();
+#define WITH_CLEANUP(var, body)                                     \
+    lisp_ref(var);                                                  \
+    {                                                               \
+        void *__with_cleanup_cleanup = register_cleanup(            \
+            (lisp_cleanup_func_t) & lisp_unref_double_ptr, &(var)); \
+        {body};                                                     \
+        cancel_cleanup(__with_cleanup_cleanup);                     \
+        lisp_unref(var);                                            \
+    }
+
+DECLARE_FUNCTION(backtrace, ());
+noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
+
+extern LispVal *Qshutdown_signal;
 extern LispVal *Qtype_error;
 extern LispVal *Qread_error;
+extern LispVal *Qvoid_variable_error;
+extern LispVal *Qvoid_function_error;
+extern LispVal *Qcircular_error;
 
 #define CHECK_TYPE(type, val)      \
     if (TYPEOF(val) != type) {     \
         Fthrow(Qtype_error, Qnil); \
-        return Qnil;               \
     }
 
 extern LispVal *Vobarray;
 
 void lisp_init(void);
 void lisp_shutdown(void);
+
+DECLARE_FUNCTION(quote, (LispVal * form));
+
+DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
+DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
+DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
+DECLARE_FUNCTION(eval, (LispVal * form));
+DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
+DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest));
+DECLARE_FUNCTION(head, (LispVal * list));
+DECLARE_FUNCTION(tail, (LispVal * list));
+noreturn DECLARE_FUNCTION(exit, (LispVal * code));
+
 void debug_dump(FILE *stream, void *obj, bool newline);
 void debug_print_hashtable(FILE *stream, LispVal *table);
 

src/main.c

@@ -1,18 +1,84 @@
 #include "lisp.h"
 #include "read.h"
 
-#include <string.h>
+static int exit_status = 0;
+
+LispVal *Ftoplevel_exit_handler(LispVal *except);
+static LispFunction _Ftoplevel_exit_handler_function = {
+    .type = TYPE_FUNCTION,
+    .ref_count = -1,
+    .is_builtin = 1,
+    .is_macro = 0,
+    .builtin = &Ftoplevel_exit_handler,
+    .lexenv = Qnil,
+};
+#define Ftoplevel_exit_handler_function \
+    LISPVAL(&_Ftoplevel_exit_handler_function)
+LispVal *Ftoplevel_exit_handler(LispVal *except) {
+    LispVal *detail = Ftail(Fhead(except));
+    if (NILP(detail) || NILP(Fhead(detail))) {
+        exit_status = 0;
+    } else if (!INTEGERP(Fhead(detail))) {
+        exit_status = 1;
+    } else {
+        exit_status = ((LispInteger *) Fhead(detail))->value;
+    }
+    return Qnil;
+}
+
+LispVal *Ftoplevel_error_handler(LispVal *except);
+static LispFunction _Ftoplevel_error_handler_function = {
+    .type = TYPE_FUNCTION,
+    .ref_count = -1,
+    .is_builtin = 1,
+    .is_macro = 0,
+    .builtin = &Ftoplevel_error_handler,
+    .lexenv = Qnil,
+};
+#define Ftoplevel_error_handler_function \
+    LISPVAL(&_Ftoplevel_error_handler_function)
+LispVal *Ftoplevel_error_handler(LispVal *except) {
+    LispVal *type = Fhead(Fhead(except));
+    LispVal *detail = Ftail(Fhead(except));
+    LispVal *backtrace = Fhead(Ftail(except));
+    fprintf(stderr, "Caught signal of type ");
+    debug_dump(stderr, type, true);
+    if (!NILP(detail)) {
+        fprintf(stderr, "Details: ");
+        debug_dump(stderr, detail, true);
+    }
+    fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
+    FOREACH(frame, backtrace) {
+        fprintf(stderr, "  ");
+        debug_dump(stderr, frame, true);
+    }
+    exit_status = 1;
+    return Qnil;
+}
 
 int main(int argc, const char **argv) {
     lisp_init();
-    char buffer[] = "1";
+    char buffer[] = "(t)";
     LispVal *tv;
-    size_t count = read_from_buffer(buffer, sizeof(buffer) - 1, &tv);
+    read_from_buffer(buffer, sizeof(buffer) - 1, &tv);
     lisp_ref(tv);
-    printf("Read %zu chars\n", count);
+    WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
-    printf("Type: %s\n", OBJ_TYPE_NAME(tv));
+        the_stack->hidden = true;
-    debug_dump(stdout, tv, true);
+        LispVal *err_var = INTERN_STATIC("err-var");
+        Fputhash(
+            the_stack->handlers, Qt,
+            // simply call the above function
+            make_list(3, err_var, Ftoplevel_error_handler_function, err_var));
+        Fputhash(
+            the_stack->handlers, Qshutdown_signal,
+            // simply call the above function
+            make_list(3, err_var, Ftoplevel_exit_handler_function, err_var));
+        LispVal *out = Feval(tv);
+        lisp_ref(out);
+        debug_dump(stdout, out, 1);
+        lisp_unref(out);
+    })
     UNREF_INPLACE(tv);
     lisp_shutdown();
-    return 0;
+    return exit_status;
 }