Fix gc bug and add condition classes

.clangd

@@ -5,8 +5,9 @@ CompileFlags:
       -Wall,
       -Wpedantic,
       -xc,
-      -D_POSIX_C_SOURCE=199309L,
+      -D_POSIX_C_SOURCE=200112L,
-      "-fsanitize=address,undefined",
+      "-Isrc",
+      "-I../",
     ]
   Compiler: gcc
 ---
@@ -14,8 +15,7 @@ If:
   PathMatch: .*\.h
 CompileFlags:
   Remove: -xc
-  Add: [-std=c11, -Wall, -Wpedantic, -xc-header]
+  Add: -xc-header
-  Compiler: gcc
 ---
 If:
   PathMatch: bin/.*\.c

Makefile

@@ -1,5 +1,5 @@
 DEBUG=1
-LLVM_SAN=0
+LLVM_SAN=1
 
 ifeq ($(DEBUG),1)
 DEBUG_CFLAGS=-g
@@ -15,7 +15,7 @@ endif
 
 CC=gcc
 CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\
-       -D_POSIX_C_SOURCE=199309L
+       -D_POSIX_C_SOURCE=200112L
 LD=gcc
 LDFLAGS=$(LLVM_SAN_FLAGS)
 
@@ -34,12 +34,11 @@ glisp: $(OBJS)
 	$(LD) $(LDFLAGS) -o $@ $^
 
 bin/init_globals.c: $(filter-out bin/init_globals.c,$(SRCS_WITH_HEADERS)) src/gen-init-globals.awk
-	@mkdir -p bin/
 	awk -f src/gen-init-globals.awk $(filter-out src/gen-init-globals.awk,$^) >$@
 
 bin/%.o: src/%.c
-	@mkdir -p bin/deps
+	@mkdir -p $(dir $(<:src/%.c=bin/deps/%.d) $(<:src/%.c=bin/%))
-	$(CC) $(CFLAGS) -c -MMD -MF $(<:src/%.c=bin/deps/%.d) -o $@ $<
+	$(CC) $(CFLAGS) -c -MMD -MF $(<:src/%.c=bin/deps/%.d) -I src/ -o $@ $<
 
 bin/init_globals.o: bin/init_globals.c
 	@mkdir -p bin/deps

lisp/kernel.gl

@@ -0,0 +1,14 @@
+;; -*- mode: lisp-data -*-
+
+(put 'x 'condition-class t)
+(put 'y 'condition-class 'x)
+
+(print (condition-class-p 'x))
+(print (condition-class-p 'y))
+(print (condition-class-p 'z))
+(print (condition-subclass-p 'y 'x))
+(print (condition-subclass-p 'y t))
+(print (condition-subclass-p 'x t))
+(print (condition-subclass-p t t))
+(print (condition-subclass-p 'z 'x))
+(print (condition-subclass-p 'x 'y))

src/base.c

@@ -3,6 +3,7 @@
 #include "gc.h"
 #include "hashtable.h"
 #include "lisp.h"
+#include "list.h"
 #include "stack.h"
 
 #include <stdio.h>
@@ -19,6 +20,8 @@ const char *LISP_TYPE_NAMES[N_LISP_TYPES] = {
     [TYPE_FUNCTION] = "function",
 };
 
+bool lisp_gc_on_alloc;
+
 void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
     assert(size >= sizeof(LispObject));
     LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size);
@@ -30,6 +33,9 @@ void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
 
 void *lisp_alloc_object(size_t size, LispValType type) {
     LispObject *obj = lisp_alloc_object_no_gc(size, type);
+    if (lisp_gc_on_alloc && the_stack.depth) {
+        lisp_gc_yield(NULL, false);
+    }
     if (the_stack.depth > 0) {
         add_local_reference_no_recurse(obj);
     }
@@ -50,7 +56,7 @@ void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
     fprintf(stderr, "Type error! Got: %s | Expected: (or ",
             LISP_TYPE_NAMES[TYPE_OF(obj)]);
     for (size_t i = 0; i < count; ++i) {
-        fprintf(stderr, "%s%s", LISP_TYPE_NAMES[i],
+        fprintf(stderr, "%s%s", LISP_TYPE_NAMES[types[i]],
                 i < count - 1 ? " " : ")\n");
     }
     abort();
@@ -75,7 +81,7 @@ DEFUN(id, "id", (LispVal * obj), "(id)", "") {
 }
 
 DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
-    return obj1 == obj2 ? Qt : Qnil;
+    return EQ(obj1, obj2) ? Qt : Qnil;
 }
 
 DEFSPECIAL(quote, "quote", (LispVal * form), "(form)", "") {
@@ -134,6 +140,51 @@ DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve),
     return sym;
 }
 
+DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") {
+    CHECK_TYPE(sym, TYPE_SYMBOL);
+    return ((LispSymbol *) sym)->plist;
+}
+
+DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)",
+      "") {
+    CHECK_TYPE(sym, TYPE_SYMBOL);
+    return ((LispSymbol *) sym)->plist = plist;
+}
+
+DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def),
+      "(sym key &optional def)", "") {
+    return Fplist_get(Fsymbol_plist(sym), key, def);
+}
+
+DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)",
+      "") {
+    return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val));
+}
+
+DEFINE_SYMBOL(condition_class, "condition-class");
+
+DEFUN(condition_class_p, "condition-class-p", (LispVal * val), "(val)", "") {
+    if (!SYMBOLP(val)) {
+        return Qnil;
+    }
+    LispVal *class = Fget(val, Qcondition_class, Qnil);
+    return !NILP(class) && SYMBOLP(class) ? class : Qnil;
+}
+
+DEFUN(condition_subclass_p, "condition-subclass-p",
+      (LispVal * child, LispVal *parent), "(child parent)", "") {
+    if (parent == child || (parent == Qt && SYMBOLP(child))) {
+        return Qt;
+    }
+    LispVal *cur = child;
+    while (!NILP((cur = Fcondition_class_p(cur))) && cur != Qt) {
+        if (cur == parent) {
+            return Qt;
+        }
+    }
+    return Qnil;
+}
+
 DEFINE_SYMBOL(backquote, "`");
 DEFINE_SYMBOL(comma, ",");
 DEFINE_SYMBOL(comma_at, ",@");

src/base.h

@@ -37,8 +37,8 @@ static ALWAYS_INLINE uintptr_t EXTRACT_TAG(LispVal *val) {
 #define LISP_OBJECT_TAG ((uintptr_t) 0)
 // 0b01
 #define FIXNUM_TAG ((uintptr_t) 1)
-// 0b11
+// 0b10
-#define LISP_FLOAT_TAG ((uintptr_t) 3)
+#define LISP_FLOAT_TAG ((uintptr_t) 2)
 
 static ALWAYS_INLINE bool LISP_OBJECT_P(LispVal *val) {
     return EXTRACT_TAG(val) == LISP_OBJECT_TAG;
@@ -77,14 +77,14 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
 // # Other types #
 // ###############
 typedef enum {
-    TYPE_FIXNUM,
+    TYPE_FIXNUM = 0,
-    TYPE_FLOAT,
+    TYPE_FLOAT = 1,
-    TYPE_CONS,
+    TYPE_CONS = 2,
-    TYPE_STRING,
+    TYPE_STRING = 3,
-    TYPE_SYMBOL,
+    TYPE_SYMBOL = 4,
-    TYPE_VECTOR,
+    TYPE_VECTOR = 5,
-    TYPE_HASH_TABLE,
+    TYPE_HASH_TABLE = 6,
-    TYPE_FUNCTION,
+    TYPE_FUNCTION = 7,
     N_LISP_TYPES,
 } LispValType;
 extern const char *LISP_TYPE_NAMES[N_LISP_TYPES];
@@ -94,6 +94,8 @@ typedef struct {
     ObjectGCInfo gc;
 } LispObject;
 
+extern bool lisp_gc_on_alloc;
+
 #define LISP_OBJECT_ALIGNMENT (1 << LISP_TAG_BITS)
 LispVal *lisp_alloc_object_no_gc(size_t size, LispValType type);
 LispVal *lisp_alloc_object(size_t size, LispValType type);
@@ -133,7 +135,7 @@ static ALWAYS_INLINE bool OBJECT_STATIC_P(LispVal *val) {
 }
 
 static inline void MARK_OBJECT_ADDED(LispVal *val, LispVal *into) {
-    if ((!OBJECT_GC_SET_P(into, GC_WHITE) || OBJECT_STATIC_P(into))
+    if (OBJECTP(val) && OBJECTP(into) && OBJECT_GC_SET_P(into, GC_BLACK)
         && OBJECT_GC_SET_P(val, GC_WHITE)) {
         gc_move_to_set(val, GC_GREY);
     }
@@ -270,7 +272,7 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
         REGISTER_GLOBAL_SYMBOL(cname);                                     \
         ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
         ((LispFunction *) ((LispSymbol *) Q##cname)->function)             \
-            ->flags.no_eval_args = true;                                   \
+            ->impl.native.no_eval_args = true;                             \
     }
 
 DECLARE_SYMBOL(nil);
@@ -281,6 +283,10 @@ static ALWAYS_INLINE bool NILP(LispVal *val) {
     return val == Qnil;
 }
 
+static ALWAYS_INLINE bool EQ(LispVal *val1, LispVal *val2) {
+    return val1 == val2;
+}
+
 // Some core functions
 DECLARE_FUNCTION(id, (LispVal * obj));
 DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
@@ -291,6 +297,15 @@ LispVal *make_vector(LispVal **data, size_t length, bool take);
 DECLARE_FUNCTION(make_symbol, (LispVal * name));
 DECLARE_FUNCTION(intern, (LispVal * name));
 DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve));
+DECLARE_FUNCTION(symbol_plist, (LispVal * sym));
+DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist));
+DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def));
+DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val));
+
+// condition stuff
+DECLARE_SYMBOL(condition_class);
+DECLARE_FUNCTION(condition_class_p, (LispVal * val));
+DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent));
 
 // Defined in lisp code (eventually) but used in read.c
 DECLARE_SYMBOL(backquote);

src/function.c

@@ -46,15 +46,19 @@ static LispVal *intern_as_keyword(LispVal *name) {
 }
 
 // on error, put the object that caused the problem in entry
-static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
+static LambdaListParseStatus
-                                                     LispVal *entry) {
+parse_optional_arg_spec(LispVal *used_names, LispVal **out, LispVal *entry) {
     // single symbol
     if (SYMBOLP(entry)) {
         if (!is_valid_variable_name(entry)) {
             *out = entry;
             return LLPS_BAD_NAME;
+        } else if (!NILP(Fgethash(used_names, entry, Qnil))) {
+            *out = entry;
+            return LLPS_REPEAT_NAME;
         }
         *out = LIST(entry, Qnil, Qnil);
+        Fputhash(used_names, entry, Qt);
         return LLPS_OK;
     } else if (!CONSP(entry)) {
         *out = entry;
@@ -65,7 +69,11 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
     if (!is_valid_variable_name(name)) {
         *out = name;
         return LLPS_BAD_NAME;
+    } else if (!NILP(Fgethash(used_names, name, Qnil))) {
+        *out = name;
+        return LLPS_REPEAT_NAME;
     }
+    Fputhash(used_names, name, Qt);
     if (list_length_eq(entry, 1)) {
         *out = LIST(XCAR(entry), Qnil, Qnil);
         return LLPS_OK;
@@ -75,8 +83,13 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
     } else if (list_length_eq(entry, 3)) {
         LispVal *pvar = XCAR(XCDR(XCDR(entry)));
         if (!is_valid_variable_name(pvar)) {
+            *out = pvar;
             return LLPS_BAD_NAME;
+        } else if (!NILP(Fgethash(used_names, pvar, Qnil))) {
+            *out = pvar;
+            return LLPS_REPEAT_NAME;
         }
+        Fputhash(used_names, pvar, Qt);
         *out = LIST(XCAR(entry), XCAR(XCDR(entry)), pvar);
         return LLPS_OK;
     } else {
@@ -85,11 +98,12 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
     }
 }
 
-#define RETURN_ERROR(err, obj)   \
+#define RETURN_ERROR(err, obj)                \
-    {                            \
+    {                                         \
-        result->status = err;    \
+        release_hash_table_no_gc(used_names); \
-        result->err_obj = (obj); \
+        result->status = err;                 \
-        return;                  \
+        result->err_obj = (obj);              \
+        return;                               \
     }
 void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     enum { REQ = 0, OPT = 1, KEY = 2, REST = 4, MUST_CHANGE } mode = REQ;
@@ -97,6 +111,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     result->err_obj = Qnil;
     result->status = LLPS_OK;
     struct LambdaList *out = &result->lambda_list;
+    LispVal *used_names = make_hash_table_no_gc(Qnil, Qnil);
     // TODO check for repeat names
     out->n_req = 0;
     out->n_opt = 0;
@@ -106,7 +121,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     out->kw = Qnil;
     out->rest = Qnil;
     size_t cur_idx = 0; // for keyword args
-    FOREACH_TAIL(list, tail) {
+    DOTAILS(tail, list) {
         if (!LISTP(tail)) {
             RETURN_ERROR(LLPS_DOTTED, list);
         } else if (out->allow_other_keys) {
@@ -148,12 +163,16 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
                 RETURN_ERROR(LLPS_REPEAT_REST, cur);
             } else if (!is_valid_variable_name(cur)) {
                 RETURN_ERROR(LLPS_BAD_NAME, cur)
+            } else if (!NILP(Fgethash(used_names, cur, Qnil))) {
+                RETURN_ERROR(LLPS_REPEAT_NAME, cur);
             }
+            Fputhash(used_names, cur, Qt);
             out->rest = cur;
             ++cur_idx;
         } else if (mode == OPT || mode == KEY) {
             LispVal *entry;
-            LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur);
+            LambdaListParseStatus status =
+                parse_optional_arg_spec(used_names, &entry, cur);
             if (status != LLPS_OK) {
                 RETURN_ERROR(status, entry)
             }
@@ -167,7 +186,10 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
             ++cur_idx;
         } else if (!is_valid_variable_name(cur)) {
             RETURN_ERROR(LLPS_BAD_NAME, cur);
+        } else if (!NILP(Fgethash(used_names, cur, Qnil))) {
+            RETURN_ERROR(LLPS_REPEAT_NAME, cur);
         } else {
+            Fputhash(used_names, cur, Qt);
             out->req = CONS(cur, out->req);
             ++out->n_req;
             ++cur_idx;
@@ -175,18 +197,19 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     }
     out->req = Fnreverse(out->req);
     out->opt = Fnreverse(out->opt);
+    release_hash_table_no_gc(used_names);
 }
 #undef RETURN_ERROR
 
-LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
+LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
                                const char *lisp_args, size_t args_len,
                                LispVal *docstr) {
     LispFunction *obj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
     obj->name = name;
-    obj->flags.type = FUNCTION_NATIVE;
+    obj->type = FUNCTION_NATIVE;
-    obj->flags.no_eval_args = false;
     obj->docstr = docstr;
-    obj->impl.native.zero = cfunc;
+    obj->impl.native.no_eval_args = false;
+    obj->impl.native.addr.zero = cfunc;
     ReadStream stream;
     read_stream_init(&stream, lisp_args, args_len);
     LispVal *args_form = read(&stream);
@@ -212,61 +235,19 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
 }
 
 // Calling functions
-// A simple function has only required args
+static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
-static ALWAYS_INLINE bool SIMPLE_FUNCTION_P(LispFunction *fobj) {
+    LispVal *start = Qnil;
-    return !fobj->args.n_opt
+    LispVal *end;
-           && (NILP(fobj->args.kw) || !HASH_TABLE_COUNT(fobj->args.kw))
+    DOLIST(arg, args) {
-           && NILP(fobj->args.rest);
+        if (NILP(start)) {
-}
+            start = CONS(Feval(arg, PARENT_LEXENV()), Qnil);
-
+            end = start;
-static ALWAYS_INLINE LispVal *
-call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
-    assert(fobj->args.n_req <= MAX_NATIVE_FUNCTION_ARGS);
-    push_stack_frame(orig_func, fobj, args);
-    if (!list_length_eq(args, fobj->args.n_req)) {
-        // TODO incorrect arg count
-        fprintf(stderr, "Wrong arg count!!\n");
-        abort();
-    }
-    LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS];
-    size_t acount = 0;
-    FOREACH(args, arg) {
-        if (fobj->flags.no_eval_args) {
-            arg_arr[acount] = arg;
         } else {
-            arg_arr[acount] = Feval(arg);
+            RPLACD(end, CONS(Feval(arg, PARENT_LEXENV()), Qnil));
+            end = XCDR(end);
         }
-        add_local_reference(arg_arr[acount++]);
     }
-    LispVal *retval;
+    return start;
-    switch (acount) {
-    case 0:
-        retval = fobj->impl.native.zero();
-        break;
-    case 1:
-        retval = fobj->impl.native.one(arg_arr[0]);
-        break;
-    case 2:
-        retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
-        break;
-    case 3:
-        retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
-        break;
-    case 4:
-        retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        arg_arr[3]);
-        break;
-    case 5:
-        retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        arg_arr[3], arg_arr[4]);
-        break;
-    default:
-        abort();
-    }
-    the_stack.nogc_retval = retval;
-    pop_stack_frame();
-    add_local_reference(the_stack.nogc_retval);
-    return retval;
 }
 
 enum ProcessArgsResult {
@@ -298,7 +279,8 @@ static ALWAYS_INLINE size_t NATIVE_FUNCTION_TOTAL_ARG_COUNT(LispVal *val) {
 
 static ALWAYS_INLINE enum ProcessArgsResult
 process_complex_native_args(LispFunction *fobj, LispVal *args,
-                            LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS]) {
+                            LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS],
+                            intptr_t *rest_idx) {
     size_t rem_req = fobj->args.n_req;
     size_t rem_opt = fobj->args.n_opt;
     size_t idx = 0;
@@ -320,7 +302,10 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
         return PROCESS_ARGS_TOO_MANY;
     }
     if (!NILP(fobj->args.rest)) {
+        *rest_idx = idx;
         out[idx++] = args;
+    } else {
+        *rest_idx = -1;
     }
     if (NILP(fobj->args.kw)) { // we are not a keyword function
         return PROCESS_ARGS_OK;
@@ -343,12 +328,18 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
     return PROCESS_ARGS_OK;
 }
 
-static ALWAYS_INLINE LispVal *
+static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
-call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
+                                          LispFunction *fobj, LispVal *args) {
+    push_stack_frame(orig_func, fobj, args);
+    if (!fobj->impl.native.no_eval_args) {
+        args = evaluate_function_arguments(args);
+    }
+    set_stack_evaluated_args(args);
     LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL};
     size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj);
+    intptr_t rest_idx;
     enum ProcessArgsResult res =
-        process_complex_native_args(fobj, args, arg_arr);
+        process_complex_native_args(fobj, args, arg_arr, &rest_idx);
     if (res != PROCESS_ARGS_OK) {
         // TODO better errors
         printf("Bad arguments to builtin \"");
@@ -356,36 +347,34 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
         printf("\": %s\n", process_args_strerror(res));
         abort();
     }
-    push_stack_frame(orig_func, fobj, args);
     for (intptr_t i = 0; i < count; ++i) {
         if (!arg_arr[i]) {
             arg_arr[i] = Qnil;
-        } else if (!fobj->flags.no_eval_args) {
-            arg_arr[i] = Feval(arg_arr[i]);
         }
         add_local_reference(arg_arr[i]);
     }
     LispVal *retval;
     switch (count) {
     case 0:
-        retval = fobj->impl.native.zero();
+        retval = fobj->impl.native.addr.zero();
         break;
     case 1:
-        retval = fobj->impl.native.one(arg_arr[0]);
+        retval = fobj->impl.native.addr.one(arg_arr[0]);
         break;
     case 2:
-        retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
+        retval = fobj->impl.native.addr.two(arg_arr[0], arg_arr[1]);
         break;
     case 3:
-        retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
+        retval =
+            fobj->impl.native.addr.three(arg_arr[0], arg_arr[1], arg_arr[2]);
         break;
     case 4:
-        retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
+        retval = fobj->impl.native.addr.four(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        arg_arr[3]);
+                                             arg_arr[3]);
         break;
     case 5:
-        retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
+        retval = fobj->impl.native.addr.five(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        arg_arr[3], arg_arr[4]);
+                                             arg_arr[3], arg_arr[4]);
         break;
     default:
         abort();
@@ -396,35 +385,166 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
     return retval;
 }
 
-static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
+static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
-                                          LispFunction *fobj, LispVal *args) {
+                                                           LispVal *value) {
-    if (SIMPLE_FUNCTION_P(fobj)) {
+    new_lexical_variable(XCAR(spec), value);
-        return call_simple_native(orig_func, fobj, args);
+    if (!NILP(THIRD(spec))) {
+        new_lexical_variable(THIRD(spec), Qt);
     }
-    return call_complex_native(orig_func, fobj, args);
+}
+
+static ALWAYS_INLINE void
+push_missing_optional_argument_to_lexenv(LispVal *spec) {
+    new_lexical_variable(XCAR(spec), Feval(SECOND(spec), TOP_LEXENV()));
+    if (!NILP(THIRD(spec))) {
+        new_lexical_variable(THIRD(spec), Qnil);
+    }
+}
+
+static ALWAYS_INLINE enum ProcessArgsResult
+push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
+    LISP_STACK_TOP()->lexenv = fobj->impl.interp.lexenv;
+    LispVal *rem_req = fobj->args.req;
+    LispVal *rem_opt = fobj->args.opt;
+    while (!NILP(rem_req)) {
+        if (NILP(args)) {
+            return PROCESS_ARGS_TOO_FEW;
+        }
+        new_lexical_variable(XCAR(rem_req), XCAR(args));
+        args = XCDR(args);
+        rem_req = XCDR(rem_req);
+    }
+    while (!NILP(rem_opt) && !NILP(args)) {
+        push_optional_argument_to_lexenv(XCAR(rem_opt), XCAR(args));
+        args = XCDR(args);
+        rem_opt = XCDR(rem_opt);
+    }
+    while (!NILP(rem_opt)) {
+        push_missing_optional_argument_to_lexenv(XCAR(rem_opt));
+        rem_opt = XCDR(rem_opt);
+    }
+    if (!NILP(fobj->args.rest)) {
+        new_lexical_variable(fobj->args.rest, args);
+    }
+    if (NILP(fobj->args.kw)) {
+        return !NILP(args) && NILP(fobj->args.rest) ? PROCESS_ARGS_TOO_MANY
+                                                    : PROCESS_ARGS_OK;
+    }
+    LispVal *seen_kw = make_hash_table_no_gc(Qnil, Qnil);
+    while (!NILP(args)) {
+        if (NILP(XCDR(args))) {
+            release_hash_table_no_gc(seen_kw);
+            return PROCESS_ARGS_NO_KEY_VALUE;
+        }
+        // has index in front
+        LispVal *i_spec = Fgethash(fobj->args.kw, XCAR(args), Qnil);
+        if (!NILP(i_spec)) {
+            Fputhash(seen_kw, XCAR(args), Qt);
+            push_optional_argument_to_lexenv(XCDR(i_spec), SECOND(args));
+        } else if (!fobj->args.allow_other_keys) {
+            release_hash_table_no_gc(seen_kw);
+            return PROCESS_ARGS_BAD_KEY;
+        }
+        args = XCDR(XCDR(args));
+    }
+    HT_FOREACH_INDEX(fobj->args.kw, i) {
+        if (NILP(Fgethash(seen_kw, HASH_KEY(fobj->args.kw, i), Qnil))) {
+            push_missing_optional_argument_to_lexenv(
+                XCDR(HASH_VALUE(fobj->args.kw, i)));
+        }
+    }
+    release_hash_table_no_gc(seen_kw);
+    return PROCESS_ARGS_OK;
+}
+
+static ALWAYS_INLINE LispVal *
+call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
+    push_stack_frame(orig_func, fobj, args);
+    LispVal *evaled_args = evaluate_function_arguments(args);
+    set_stack_evaluated_args(evaled_args);
+    enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args);
+    if (par != PROCESS_ARGS_OK) {
+        // TODO better error handling
+        fprintf(stderr, "Bad args to interp func: %s\n",
+                process_args_strerror(par));
+        abort();
+    }
+    LispVal *rval = Fprogn(fobj->impl.interp.body);
+    the_stack.nogc_retval = rval;
+    pop_stack_frame();
+    add_local_reference(rval);
+    return rval;
 }
 
 DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
       "") {
-    CHECK_TYPE(func, TYPE_FUNCTION, TYPE_SYMBOL);
     LispFunction *fobj = func;
     if (SYMBOLP(func)) {
         fobj = Fsymbol_function(func, Qt);
+    } else if (CONSP(func) && EQ(XCAR(func), Qlambda)) {
+        fobj = Feval(func, TOP_LEXENV());
     }
-    if (!FUNCTIONP(fobj)) {
+    // include symbol here for the error message
-        // TODO error
+    CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
-        abort();
+    switch (fobj->type) {
-    }
-    if (!fobj->flags.no_eval_args) {
-        // TODO evaluate arguments
-    }
-    switch (fobj->flags.type) {
     case FUNCTION_NATIVE:
         return call_native(func, fobj, args);
     case FUNCTION_INTERP:
-    case FUNCTION_BYTECOMP:
+        return call_interpreted(func, fobj, args);
     default:
-        // TODO implement
         abort();
     }
 }
+
+static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) {
+    while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) {
+        LispVal *decls = XCDR(XCAR(body));
+        DOLIST(decl, decls) {
+            if (EQ(XCAR(decl), Qname)) {
+                CHECK_TYPE(SECOND(decl), TYPE_SYMBOL);
+                if (!list_length_eq(decl, 2)) {
+                    // TODO better error
+                    fprintf(stderr, "Invalid (declare (name ...)) form!\n");
+                    abort();
+                }
+                fobj->name = SECOND(decl);
+            }
+        }
+        body = XCDR(body);
+    }
+    return body;
+}
+
+DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body),
+           "(args &rest body)", "") {
+    LambdaListParseResult llpr;
+    parse_lambda_list(&llpr, args);
+    if (llpr.status != LLPS_OK) {
+        // TODO better handling
+        fprintf(stderr,
+                "Lambda list parse error: %s: ", llps_strerror(llpr.status));
+        debug_print(stderr, args);
+        fputc('\n', stderr);
+        abort();
+    }
+    CHECK_LISTP(body);
+    LispFunction *fobj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
+    fobj->name = Qnil;
+    fobj->args = llpr.lambda_list;
+    fobj->type = FUNCTION_INTERP;
+    if (STRINGP(XCAR(body))) {
+        fobj->docstr = XCAR(body);
+        if (CONSP(XCDR(body))) {
+            body = XCDR(body);
+        }
+    } else {
+        fobj->docstr = Qnil;
+    }
+    body = parse_lambda_declare_form(fobj, body);
+    fobj->impl.interp.body = body;
+    fobj->impl.interp.lexenv = PARENT_LEXENV();
+    return fobj;
+}
+
+DEFINE_SYMBOL(declare, "declare");
+DEFINE_SYMBOL(name, "name");

src/function.h

@@ -2,7 +2,6 @@
 #define INCLUDED_FUNCTION_H
 
 #include "base.h"
-#include "lisp_string.h"
 
 DECLARE_SYMBOL(and_optional);
 DECLARE_SYMBOL(and_rest);
@@ -22,33 +21,36 @@ struct LambdaList {
 };
 
 #define MAX_NATIVE_FUNCTION_ARGS 5
-union native_function {
+struct native_function {
-    LispVal *(*zero)(void);
+    bool no_eval_args;
-    LispVal *(*one)(LispVal *);
+    union {
-    LispVal *(*two)(LispVal *, LispVal *);
+        LispVal *(*zero)(void);
-    LispVal *(*three)(LispVal *, LispVal *, LispVal *);
+        LispVal *(*one)(LispVal *);
-    LispVal *(*four)(LispVal *, LispVal *, LispVal *, LispVal *);
+        LispVal *(*two)(LispVal *, LispVal *);
-    LispVal *(*five)(LispVal *, LispVal *, LispVal *, LispVal *, LispVal *);
+        LispVal *(*three)(LispVal *, LispVal *, LispVal *);
+        LispVal *(*four)(LispVal *, LispVal *, LispVal *, LispVal *);
+        LispVal *(*five)(LispVal *, LispVal *, LispVal *, LispVal *, LispVal *);
+    } addr;
+};
+
+struct interp_function {
+    LispVal *body; // list of forms
+    LispVal *lexenv;
 };
 
 typedef enum {
     FUNCTION_NATIVE,
     FUNCTION_INTERP,
-    FUNCTION_BYTECOMP,
 } LispFunctionType;
 
-struct function_flags {
-    LispFunctionType type : 2;
-    unsigned int no_eval_args : 1;
-};
-
 DEFOBJTYPE(Function, FUNCTION, FUNCTIONP, {
     LispVal *name; // symbol (or nil for a lambda)
-    struct function_flags flags;
+    LispFunctionType type;
     struct LambdaList args;
     LispVal *docstr;
     union {
-        union native_function native;
+        struct native_function native;
+        struct interp_function interp;
     } impl;
 });
 
@@ -90,4 +92,9 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
 DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
 #define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
 
+DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
+
+DECLARE_SYMBOL(declare);
+DECLARE_SYMBOL(name);
+
 #endif

src/gc.c

@@ -8,130 +8,9 @@
 
 #include <stdlib.h>
 
-void free_object_process_stack(ObjectProcessStack *restrict stack) {
-    for (size_t i = 0; i < stack->num_blocks; ++i) {
-        lisp_free(stack->blocks[i]);
-    }
-    lisp_free(stack->blocks);
-}
-
-// Ensure STACK can hold at least NEW_ENTS more entries
-static void ensure_object_process_stack_size(ObjectProcessStack *restrict stack,
-                                             size_t new_ents) {
-    size_t total_spaces = stack->num_blocks * OBJECT_PROCESS_STACK_BLOCK_SIZE;
-    size_t ents_left = total_spaces - stack->num_objs;
-    if (ents_left < new_ents) {
-        // grow the stack
-        size_t need_to_alloc =
-            (new_ents - ents_left) / OBJECT_PROCESS_STACK_BLOCK_SIZE;
-        if ((new_ents - ents_left) % OBJECT_PROCESS_STACK_BLOCK_SIZE != 0) {
-            ++need_to_alloc;
-        }
-        stack->blocks = lisp_realloc(stack->blocks,
-                                     sizeof(struct ObjectProcessStackBlock *)
-                                         * (stack->num_blocks + need_to_alloc));
-        for (size_t i = 0; i < need_to_alloc; ++i) {
-            stack->blocks[i + stack->num_blocks] =
-                lisp_malloc(sizeof(struct ObjectProcessStackBlock));
-        }
-        stack->num_blocks += need_to_alloc;
-    }
-}
-
-// this does NOT check if there is actually space to push the object, so make
-// sure to expand the stack with the above function before pushing
-static ALWAYS_INLINE void
-add_to_object_process_stack(ObjectProcessStack *restrict stack, void *obj) {
-    if (OBJECTP(obj)) {
-        size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
-        size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
-        stack->blocks[block_idx]->objs[small_idx] = obj;
-        ++stack->num_objs;
-    }
-}
-
-void object_process_stack_push_object(ObjectProcessStack *restrict stack,
-                                      void *obj) {
-    if (OBJECTP(obj)) {
-        ensure_object_process_stack_size(stack, 1);
-        add_to_object_process_stack(stack, obj);
-    }
-}
-
-void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
-                                            void *obj) {
-    if (!OBJECTP(obj)) {
-        return;
-    }
-    switch (((LispObject *) obj)->type) {
-    case TYPE_CONS:
-        ensure_object_process_stack_size(stack, 2);
-        add_to_object_process_stack(stack, XCAR(obj));
-        add_to_object_process_stack(stack, XCDR(obj));
-        break;
-    case TYPE_SYMBOL: {
-        LispSymbol *sym = obj;
-        ensure_object_process_stack_size(stack, 4);
-        add_to_object_process_stack(stack, sym->name);
-        add_to_object_process_stack(stack, sym->value);
-        add_to_object_process_stack(stack, sym->function);
-        add_to_object_process_stack(stack, sym->plist);
-        break;
-    }
-    case TYPE_VECTOR: {
-        LispVector *vec = obj;
-        for (size_t i = 0; i < vec->length; ++i) {
-            if (OBJECTP(vec->data[i])) {
-                ensure_object_process_stack_size(stack, 1);
-            }
-            add_to_object_process_stack(stack, vec->data[i]);
-        }
-        break;
-    }
-    case TYPE_FUNCTION: {
-        LispFunction *fobj = obj;
-        ensure_object_process_stack_size(stack, 6);
-        add_to_object_process_stack(stack, fobj->name);
-        add_to_object_process_stack(stack, fobj->docstr);
-        add_to_object_process_stack(stack, fobj->args.req);
-        add_to_object_process_stack(stack, fobj->args.opt);
-        add_to_object_process_stack(stack, fobj->args.kw);
-        add_to_object_process_stack(stack, fobj->args.rest);
-        // TODO when other function types are added, record their held
-        // references
-        break;
-    }
-    case TYPE_HASH_TABLE: {
-        HT_FOREACH_INDEX(obj, i) {
-            if (OBJECTP(HASH_KEY(obj, i)) || OBJECTP(HASH_VALUE(obj, i))) {
-                ensure_object_process_stack_size(stack, 2);
-            }
-            add_to_object_process_stack(stack, HASH_KEY(obj, i));
-            add_to_object_process_stack(stack, HASH_VALUE(obj, i));
-        }
-        break;
-    }
-    case TYPE_STRING:
-        // holds no references break;
-        break;
-    case TYPE_FIXNUM:
-    case TYPE_FLOAT:
-    default:
-        abort();
-    }
-}
-
-void *object_process_stack_pop(ObjectProcessStack *restrict stack) {
-    assert(stack->num_objs > 0);
-    --stack->num_objs;
-    size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
-    size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
-    return stack->blocks[block_idx]->objs[small_idx];
-}
-
 bool lisp_doing_gc;
 struct timespec total_gc_time;
-size_t total_gc_count;
+size_t lisp_gc_count;
 
 struct GCObjectList {
     LispVal *obj;
@@ -152,6 +31,23 @@ ObjectGCSet GC_BLACK = 0;
 ObjectGCSet GC_GREY = 1;
 ObjectGCSet GC_WHITE = 2;
 
+enum IncrementalGCSetp {
+    GC_STEP_STATICS,
+    GC_STEP_STACK,
+    GC_STEP_HEAP,
+    GC_STEP_FREE,
+};
+
+struct IncrementalGCState {
+    enum IncrementalGCSetp step;
+    struct GCObjectList *next_static;
+};
+
+static struct IncrementalGCState incremental_state = {
+    .step = GC_STEP_STATICS,
+    .next_static = NULL,
+};
+
 static ALWAYS_INLINE struct GCObjectList **HEAD_FOR_SET(ObjectGCSet set) {
     if (set == GC_BLACK) {
         return &black_objects;
@@ -213,6 +109,9 @@ void lisp_gc_register_static_object(void *val) {
     }
     node->obj = obj;
     static_objects = node;
+    // reset incremental GC to ensure we scan the new static
+    incremental_state.step = GC_STEP_STATICS;
+    incremental_state.next_static = static_objects;
 }
 
 static void unregister_object_node(LispObject *obj) {
@@ -245,7 +144,15 @@ void gc_move_to_set(void *val, ObjectGCSet new_set) {
     }
 }
 
+void gc_mark_stack_for_rescan(void) {
+    if (incremental_state.step > GC_STEP_STACK) {
+        incremental_state.step = GC_STEP_STACK;
+    }
+}
+
 static void free_object(LispVal *val) {
+    assert(OBJECT_GC_SET_P(val, GC_WHITE));
+    assert(!OBJECT_HAS_LOCAL_REFERENCE_P(val));
     switch (((LispObject *) val)->type) {
     case TYPE_HASH_TABLE: {
         LispHashTable *ht = val;
@@ -279,80 +186,146 @@ static void free_object(LispVal *val) {
     lisp_release_object(val);
 }
 
-static void mark_object_recurse(LispGCStats *restrict stats, LispVal *val) {
+static inline void make_grey_if_white(LispVal *val) {
-    if (!OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
+    if (OBJECTP(val) && OBJECT_GC_SET_P(val, GC_WHITE)) {
+        gc_move_to_set(val, GC_GREY);
+    }
+}
+
+static void mark_object(LispVal *val) {
+    // check for null for newly constructed objects
+    if (!val || !OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
         return;
     }
-    ObjectProcessStack stack;
+    switch (((LispObject *) val)->type) {
-    init_object_process_stack(&stack);
+    case TYPE_CONS:
-    object_process_stack_push_object(&stack, val);
+        make_grey_if_white(((LispCons *) val)->car);
-    while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
+        make_grey_if_white(((LispCons *) val)->cdr);
-        LispVal *cur = object_process_stack_pop(&stack);
+        break;
-        if (!OBJECT_GC_SET_P(cur, GC_BLACK)) {
+    case TYPE_SYMBOL: {
-            if (!OBJECT_STATIC_P(val)) {
+        LispSymbol *sym = val;
-                ++stats->non_statics_kept;
+        make_grey_if_white(sym->name);
-            }
+        make_grey_if_white(sym->value);
-            gc_move_to_set(cur, GC_BLACK);
+        make_grey_if_white(sym->function);
-            object_process_stack_push_held_objects(&stack, cur);
+        make_grey_if_white(sym->plist);
+        break;
+    }
+    case TYPE_VECTOR: {
+        LispVector *vec = val;
+        for (size_t i = 0; i < vec->length; ++i) {
+            make_grey_if_white(vec->data[i]);
         }
+        break;
     }
-    free_object_process_stack(&stack);
+    case TYPE_HASH_TABLE: {
+        HT_FOREACH_INDEX(val, i) {
+            make_grey_if_white(HASH_KEY(val, i));
+            make_grey_if_white(HASH_VALUE(val, i));
+        }
+        break;
+    }
+    case TYPE_FUNCTION: {
+        LispFunction *fobj = val;
+        make_grey_if_white(fobj->name);
+        make_grey_if_white(fobj->docstr);
+        make_grey_if_white(fobj->args.req);
+        make_grey_if_white(fobj->args.opt);
+        make_grey_if_white(fobj->args.kw);
+        make_grey_if_white(fobj->args.rest);
+        break;
+    }
+    case TYPE_STRING:
+        // no held refs
+        break;
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    default:
+        abort();
+    }
+    gc_move_to_set(val, GC_BLACK);
 }
 
-static void mark_statics(LispGCStats *restrict stats) {
+static inline size_t saturating_dec(size_t *restrict limit, size_t amount) {
-    for (struct GCObjectList *node = static_objects; node; node = node->next) {
+    if (amount >= *limit) {
-        mark_object_recurse(stats, node->obj);
+        *limit = 0;
+    } else {
+        *limit -= amount;
+    }
+    return *limit;
+}
+
+static void mark_statics(size_t *restrict limit) {
+    struct GCObjectList *node = incremental_state.next_static;
+    while (node && saturating_dec(limit, 1)) {
+        mark_object(node->obj);
+        node = node->next;
+    }
+    // we processed the whole list, move to the next step
+    if (!node) {
+        incremental_state.next_static = static_objects;
+        incremental_state.step = GC_STEP_STACK;
     }
 }
 
-static void mark_stack_local_refs(LispGCStats *restrict stats,
+// This mark_stack_local_refs and mark_stack_frame mark the whole frame,
-                                  struct LocalReferences *restrict refs) {
+// ignoring limit. However, they update limit with how many objects the marked.
+static void mark_stack_local_refs(struct LocalReferences *restrict refs,
+                                  size_t *restrict limit) {
     size_t full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
     size_t last_block_len = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH;
     for (size_t i = 0; i < full_blocks; ++i) {
         for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
-            mark_object_recurse(stats, refs->blocks[i]->refs[j]);
+            mark_object(refs->blocks[i]->refs[j]);
         }
     }
     for (size_t i = 0; i < last_block_len; ++i) {
-        mark_object_recurse(stats, refs->blocks[full_blocks]->refs[i]);
+        mark_object(refs->blocks[full_blocks]->refs[i]);
     }
+    saturating_dec(limit, refs->num_refs);
 }
 
-static void mark_stack_frame(LispGCStats *restrict stats,
+static void mark_stack_frame(struct StackFrame *frame, size_t *restrict limit) {
-                             struct StackFrame *frame) {
+    mark_object(frame->name);
-    mark_object_recurse(stats, frame->name);
+    mark_object(frame->args);
-    mark_object_recurse(stats, frame->args);
+    mark_object(frame->fobj);
-    mark_object_recurse(stats, frame->fobj);
+    mark_object(frame->lexenv);
-    mark_object_recurse(stats, frame->lexenv);
+    saturating_dec(limit, 4);
-    mark_stack_local_refs(stats, &frame->local_refs);
+    mark_stack_local_refs(&frame->local_refs, limit);
 }
 
-static void mark_and_compact_the_stack(LispGCStats *restrict stats) {
+static void mark_and_compact_the_stack(size_t *restrict limit) {
-    mark_object_recurse(stats, the_stack.nogc_retval);
+    if ((*limit)--) {
+        mark_object(the_stack.nogc_retval);
+    }
     size_t i;
-    for (i = 0; i < the_stack.depth; ++i) {
+    for (i = 0; i < the_stack.depth && *limit; ++i) {
-        mark_stack_frame(stats, &the_stack.frames[i]);
+        if (!the_stack.frames[i].marked) {
+            mark_stack_frame(&the_stack.frames[i], limit);
+            the_stack.frames[i].marked = true;
+        }
     }
-    for (; i < the_stack.first_clear_local_refs; ++i) {
+    if (i == the_stack.depth) {
-        compact_stack_frame(&the_stack.frames[i]);
+        for (; i < the_stack.first_clear_local_refs; ++i) {
-    }
+            compact_stack_frame(&the_stack.frames[i]);
-    the_stack.first_clear_local_refs = the_stack.depth;
+        }
-}
+        the_stack.first_clear_local_refs = the_stack.depth;
-
+        // move to the next step
-static void gc_sweep_objects(LispGCStats *restrict stats) {
+        incremental_state.step = GC_STEP_HEAP;
-    while (white_objects) {
-        ++stats->objects_cleaned;
-        free_object(white_objects->obj);
     }
 }
 
-static void maybe_free_some_object_list_nodes(void) {
+static void unmark_the_stack(void) {
-    while (free_objects_list_count > FREE_OBJECTS_LIST_LIMIT) {
+    for (size_t i = 0; i < the_stack.depth; ++i) {
-        struct GCObjectList *to_free = free_objects_list;
+        the_stack.frames[i].marked = false;
-        free_objects_list = free_objects_list->next;
+    }
-        lisp_free(to_free);
+}
-        --free_objects_list_count;
+
+static void mark_grey_objects(size_t *restrict limit) {
+    while (grey_objects && saturating_dec(limit, 1)) {
+        mark_object(grey_objects->obj);
+    }
+    if (!grey_objects) {
+        incremental_state.step = GC_STEP_FREE;
     }
 }
 
@@ -365,34 +338,86 @@ static void swap_white_black_sets(void) {
     GC_BLACK = tmp_id;
 }
 
-void lisp_gc_now(LispGCStats *restrict stats) {
+static void maybe_free_some_object_list_nodes(void) {
-    lisp_doing_gc = true;
+    while (free_objects_list_count > FREE_OBJECTS_LIST_LIMIT) {
-    LispGCStats backup_stats;
+        struct GCObjectList *to_free = free_objects_list;
-    if (!stats) {
+        free_objects_list = free_objects_list->next;
-        stats = &backup_stats;
+        lisp_free(to_free);
+        --free_objects_list_count;
     }
-    stats->objects_cleaned = 0;
-    stats->non_statics_kept = 0;
-    struct timespec start_time;
-    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &start_time);
-    mark_statics(stats);
-    mark_object_recurse(stats, obarray);
-    mark_and_compact_the_stack(stats);
-    gc_sweep_objects(stats);
-    maybe_free_some_object_list_nodes();
-    swap_white_black_sets();
-    struct timespec end_time;
-    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &end_time);
-    sub_timespecs(&end_time, &start_time, &stats->ellapsed_time);
-    add_timespecs(&stats->ellapsed_time, &total_gc_time, &total_gc_time);
-    ++total_gc_count;
-    lisp_doing_gc = false;
 }
 
-void debug_print_gc_stats(FILE *stream, const LispGCStats *stats) {
+static void gc_sweep_objects(size_t *restrict limit) {
-    fprintf(stream, "Non-Statics Kept: %zu\n", stats->non_statics_kept);
+    while (white_objects && saturating_dec(limit, 1)) {
-    fprintf(stream, "Objects Cleaned: %zu\n", stats->objects_cleaned);
+        free_object(white_objects->obj);
-    double time = stats->ellapsed_time.tv_sec * 1000
+    }
-                  + (stats->ellapsed_time.tv_nsec / 1000000.0);
+    // reset the gc
-    fprintf(stream, "Time Ellapsed (ms): %f\n", time);
+    if (!white_objects) {
+        swap_white_black_sets();
+        maybe_free_some_object_list_nodes();
+        unmark_the_stack();
+        incremental_state.step = GC_STEP_STATICS;
+    }
+}
+
+void lisp_gc_yield(struct timespec *restrict time_took, bool full) {
+    lisp_doing_gc = true;
+    struct timespec start_time;
+    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &start_time);
+    size_t limit = full ? SIZE_MAX : LISP_GC_INCREMENTAL_COUNT;
+    while (limit) {
+        // there are more grey objects, mark them before we sweep
+        if (incremental_state.step == GC_STEP_FREE && grey_objects) {
+            incremental_state.step = GC_STEP_HEAP;
+        }
+        switch (incremental_state.step) {
+        case GC_STEP_STATICS:
+            mark_statics(&limit);
+            break;
+        case GC_STEP_STACK:
+            mark_and_compact_the_stack(&limit);
+            break;
+        case GC_STEP_HEAP:
+            mark_grey_objects(&limit);
+            break;
+        case GC_STEP_FREE:
+            gc_sweep_objects(&limit);
+            // force being done
+            limit = 0;
+            break;
+        }
+    }
+    struct timespec end_time;
+    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &end_time);
+    struct timespec backup_time_took;
+    if (!time_took) {
+        time_took = &backup_time_took;
+    }
+    sub_timespecs(&end_time, &start_time, time_took);
+    add_timespecs(time_took, &total_gc_time, &total_gc_time);
+    lisp_doing_gc = false;
+    ++lisp_gc_count;
+}
+
+void lisp_gc_teardown(void) {
+    assert(the_stack.depth == 0);
+    while (white_objects) {
+        free_object(white_objects->obj);
+    }
+    while (grey_objects) {
+        free_object(grey_objects->obj);
+    }
+    while (black_objects) {
+        free_object(black_objects->obj);
+    }
+    while (static_objects) {
+        struct GCObjectList *next = static_objects->next;
+        free(static_objects);
+        static_objects = next;
+    }
+    while (free_objects_list) {
+        struct GCObjectList *next = free_objects_list->next;
+        free(free_objects_list);
+        free_objects_list = next;
+    }
 }

src/gc.h

@@ -1,50 +1,17 @@
 #ifndef INCLUDED_GC_H
 #define INCLUDED_GC_H
 
-#include "memory.h"
+#include <stdbool.h>
-
 #include <stddef.h>
-#include <stdio.h>
+#include <stdint.h>
 #include <threads.h>
 
-#define OBJECT_PROCESS_STACK_BLOCK_SIZE 64
+// number of objects to process each time we do incremental GC
-struct ObjectProcessStackBlock {
+#define LISP_GC_INCREMENTAL_COUNT 128
-    void *objs[OBJECT_PROCESS_STACK_BLOCK_SIZE];
-};
-typedef struct {
-    size_t num_blocks;
-    size_t num_objs;
-    struct ObjectProcessStackBlock **blocks;
-} ObjectProcessStack;
-
-static ALWAYS_INLINE bool
-OBJECT_PROCESS_STACK_EMPTY_P(ObjectProcessStack *restrict stack) {
-    return !stack->num_objs;
-}
-
-static ALWAYS_INLINE void
-init_object_process_stack(ObjectProcessStack *restrict stack) {
-    stack->num_blocks = 0;
-    stack->num_objs = 0;
-    stack->blocks = NULL;
-}
-
-void free_object_process_stack(ObjectProcessStack *restrict stack);
-void object_process_stack_push_object(ObjectProcessStack *restrict stack,
-                                      void *obj);
-void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
-                                            void *obj);
-void *object_process_stack_pop(ObjectProcessStack *restrict stack);
 
 extern bool lisp_doing_gc;
 extern struct timespec total_gc_time;
-extern size_t total_gc_count;
+extern size_t lisp_gc_count;
-
-typedef struct {
-    size_t non_statics_kept;
-    size_t objects_cleaned;
-    struct timespec ellapsed_time;
-} LispGCStats;
 
 typedef uint8_t ObjectGCSet;
 
@@ -66,10 +33,14 @@ void lisp_gc_register_object(void *val);
 void lisp_gc_register_static_object(void *val);
 void gc_move_to_set(void *val, ObjectGCSet new_set);
 
-// note that the argument is restrict!
+// notify the GC that the stack's referenced objects have changed.
-void lisp_gc_now(LispGCStats *restrict status);
+void gc_mark_stack_for_rescan(void);
 
-// Debug
+// do some incremental GC, with FULL, do full gc
-void debug_print_gc_stats(FILE *stream, const LispGCStats *stats);
+void lisp_gc_yield(struct timespec *restrict time_took, bool full);
+
+// Unregister all static objects and prepare for shutdown
+// The stack MUST be empty when this is called
+void lisp_gc_teardown(void);
 
 #endif

src/gen-init-globals.awk

@@ -6,6 +6,10 @@ BEGIN {
     special_syms["unbound"] = 1
     special_syms["hash_string"] = 1
     special_syms["strings_equal"] = 1
+    special_syms["and_rest"] = 1
+    special_syms["and_key"] = 1
+    special_syms["and_optional"] = 1
+    special_syms["and_allow_other_keys"] = 1
 
     FS = "[,(]"
 

src/hashtable.c

@@ -56,7 +56,7 @@ static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) {
 
 static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) {
     if (NILP(ht->eq_fn) || ht->eq_fn == Qeq) {
-        return key1 == key2;
+        return EQ(key1, key2);
     } else if (ht->eq_fn == Qstrings_equal) { // needed for initialization
         return !NILP(Fstrings_equal(key1, key2));
     }
@@ -92,6 +92,7 @@ static void rehash(LispHashTable *ht, size_t new_size) {
             nb->value = cob->value;
         }
     }
+    lisp_free(old_data);
 }
 
 static void maybe_rehash(LispHashTable *ht) {

src/lisp.c

@@ -10,6 +10,7 @@ static void construct_manual_symbols(void) {
     // IMPORTANT: the symbols listed here need to also be set as special in
     // gen-init-globals.awk
     Qnil = Fmake_symbol(LISP_LITSTR("nil"));
+    ((LispSymbol *) Qnil)->value = Qnil;
     ((LispSymbol *) Qnil)->function = Qnil;
     ((LispSymbol *) Qnil)->plist = Qnil;
     lisp_gc_register_static_object(Qnil);
@@ -18,7 +19,7 @@ static void construct_manual_symbols(void) {
     lisp_gc_register_static_object(Qt);
     Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
     ((LispSymbol *) Qunbound)->value = Qunbound;
-    ((LispSymbol *) Qnil)->value = Qunbound;
+    ((LispSymbol *) Qunbound)->value = Qunbound;
     lisp_gc_register_static_object(Qunbound);
 
     Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
@@ -41,6 +42,14 @@ static void register_manual_symbols(void) {
 void lisp_init(void) {
     construct_manual_symbols();
     obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
+    lisp_gc_register_static_object(obarray);
+
+    // Needed to register functions
+    REGISTER_GLOBAL_SYMBOL(and_allow_other_keys);
+    REGISTER_GLOBAL_SYMBOL(and_optional);
+    REGISTER_GLOBAL_SYMBOL(and_key);
+    REGISTER_GLOBAL_SYMBOL(and_rest);
+
     // these call Fintern, so they need to have obarray constructed
     ((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string);
     ((LispSymbol *) Qstrings_equal)->function =
@@ -50,11 +59,31 @@ void lisp_init(void) {
     register_globals();
 
     lisp_init_stack();
+    lisp_gc_on_alloc = true;
 }
 
-void lisp_shutdown(void) {}
+void lisp_shutdown(void) {
+    lisp_gc_teardown();
+    lisp_teardown_stack();
+}
 
-DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
+static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
+    LispVal *lexval = Fplist_get(lexenv, name, Qunbound);
+    if (lexval != Qunbound) {
+        return lexval;
+    }
+    if (name->value == Qunbound) {
+        // TODO better error
+        printf("Unbound symbol: ");
+        debug_print(stdout, name);
+        fputc('\n', stdout);
+        abort();
+    }
+    return name->value;
+}
+
+DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
+      "(form &optional lexenv)", "") {
     if (!OBJECTP(form)) {
         // fixnum or float
         return form;
@@ -72,21 +101,12 @@ DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
             out_data[i] = Qnil;
         }
         for (size_t i = 0; i < vec->length; ++i) {
-            out_data[i] = Feval(vec->data[i]);
+            out_data[i] = Feval(vec->data[i], lexenv);
         }
         return newvec;
     }
-    case TYPE_SYMBOL: {
+    case TYPE_SYMBOL:
-        // TODO local bindings
+        return lookup_variable(form, lexenv);
-        LispSymbol *sym = form;
-        if (sym->value == Qunbound) {
-            printf("Unbound symbol: ");
-            debug_print(stdout, form);
-            fputc('\n', stdout);
-            abort();
-        }
-        return sym->value;
-    }
     case TYPE_CONS: {
         return Ffuncall(XCAR(form), XCDR(form));
     }
@@ -97,6 +117,32 @@ DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
     }
 }
 
+DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
+    LispVal *rval = Qnil;
+    DOLIST(form, forms) {
+        rval = Feval(form, TOP_LEXENV());
+    }
+    return rval;
+}
+
+DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
+           "(bindings &rest body)", "") {
+    CHECK_LISTP(bindings);
+    copy_parent_lexenv();
+    DOLIST(binding, bindings) {
+        if (SYMBOLP(binding)) {
+            new_lexical_variable(binding, Qnil);
+        } else if (CONSP(binding) && list_length_eq(binding, 2)) {
+            new_lexical_variable(FIRST(binding),
+                                 Feval(SECOND(binding), TOP_LEXENV()));
+        } else {
+            // TODO better error
+            abort();
+        }
+    }
+    return Fprogn(body);
+}
+
 void debug_print(FILE *file, LispVal *obj) {
     switch (TYPE_OF(obj)) {
     case TYPE_FIXNUM:
@@ -123,12 +169,19 @@ void debug_print(FILE *file, LispVal *obj) {
         break;
     }
     case TYPE_FUNCTION: {
-        fprintf(file, "<function at 0x%jx>", (uintmax_t) obj);
+        LispFunction *fobj = obj;
+        if (NILP(fobj->name)) {
+            fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
+        } else {
+            fprintf(file, "<function ");
+            debug_print(file, fobj->name);
+            fprintf(file, " at 0x%jx>", (uintmax_t) obj);
+        }
         break;
     }
     case TYPE_CONS: {
         fputc('(', file);
-        FOREACH_TAIL(obj, tail) {
+        DOTAILS(tail, obj) {
             if (CONSP(tail)) {
                 debug_print(file, XCAR(tail));
                 if (!NILP(XCDR(tail))) {

src/lisp.h

@@ -16,7 +16,9 @@ void lisp_init(void);
 
 void lisp_shutdown(void);
 
-DECLARE_FUNCTION(eval, (LispVal * form));
+DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
+DECLARE_FUNCTION(progn, (LispVal * forms));
+DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body));
 
 __attribute__((no_sanitize("address"))) void debug_print(FILE *file,
                                                          LispVal *obj);

src/list.c

@@ -1,5 +1,7 @@
 #include "list.h"
 
+#include "function.h"
+
 intptr_t list_length(LispVal *list) {
     assert(LISTP(list));
     LispVal *tortise = list;
@@ -31,6 +33,7 @@ DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)",
 
 DEFUN(length, "length", (LispVal * list), "(list)", "") {
     // TODO type check
+    // TODO list may be circular
     return MAKE_FIXNUM(list_length(list));
 }
 
@@ -59,3 +62,45 @@ DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
 DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
     return args;
 }
+
+DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
+      "(elt list &optional pred)", "") {
+    if (NILP(pred) || pred == Qeq) {
+        // fast case
+        DOTAILS(rest, list) {
+            if (elt == XCAR(rest)) {
+                return rest;
+            }
+        }
+    } else {
+        DOTAILS(rest, list) {
+            if (CALL(pred, elt, XCAR(rest))) {
+                return rest;
+            }
+        }
+    }
+    return Qnil;
+}
+
+DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value),
+      "(plist prop value)", "") {
+    CHECK_LISTP(plist);
+    DOTAILS(rest, plist) {
+        if (EQ(XCAR(rest), prop)) {
+            RPLACA(XCDR(rest), value);
+            return plist;
+        }
+    }
+    return CONS(prop, CONS(value, plist));
+}
+
+DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def),
+      "(plist prop &optional default)", "") {
+    CHECK_LISTP(plist);
+    DOTAILS(rest, plist) {
+        if (EQ(XCAR(rest), prop)) {
+            return SECOND(rest);
+        }
+    }
+    return def;
+}

src/list.h

@@ -99,11 +99,11 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) {
 #define FOURTH(x) XCAR(XCDR(XCDR(XCDR(x))))
 #define FIFTH(x)  XCAR(XCDR(XCDR(XCDR(XCDR(x)))))
 
-#define FOREACH(l, v)                                          \
+#define DOLIST(v, l)                                           \
     for (LispVal *_tail = (l), *v = XCAR(_tail); !NILP(_tail); \
          _tail = XCDR(_tail), v = XCAR(_tail))
 
-#define FOREACH_TAIL(l, v) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
+#define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
 
 // return -1 list is circular
 intptr_t list_length(LispVal *list);
@@ -122,4 +122,10 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
     }
 }
 
+// List utility functions
+DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred));
+
+DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
+DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def));
+
 #endif

src/main.c

@@ -3,28 +3,30 @@
 
 #include <stdio.h>
 
-DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)",
+DEFUN(print, "print", (LispVal * v), "(v)", "") {
-      "") {
+    debug_obj_info(stdout, v);
-    printf("A: ");
-    debug_obj_info(stdout, a);
-    printf("B: ");
-    debug_obj_info(stdout, b);
     return Qnil;
 }
 
 int main(int argc, const char **argv) {
-    LispGCStats gc_stats;
+    FILE *in = fopen(argv[1], "r");
+    fseek(in, 0, SEEK_END);
+    off_t src_len = ftello(in);
+    char *src = malloc(src_len);
+    rewind(in);
+    fread(src, 1, src_len, in);
+    fclose(in);
     lisp_init();
-    REGISTER_GLOBAL_FUNCTION(cool_func);
+    REGISTER_GLOBAL_FUNCTION(print);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "(cool-func 1 (cons 1 2))";
+    read_stream_init(&s, src, src_len);
-    read_stream_init(&s, BUF, sizeof(BUF) - 1);
+    LispVal *r;
-    LispVal *l = read(&s);
+    while ((r = read(&s))) {
-    Feval(l);
+        Feval(r, Qnil);
-    lisp_gc_now(&gc_stats);
+    }
-    debug_print_gc_stats(stdout, &gc_stats);
     pop_stack_frame();
     lisp_shutdown();
+    free(src);
     return 0;
 }

src/memory.c

@@ -36,3 +36,69 @@ void *lisp_aligned_alloc(size_t alignment, size_t size) {
     }
     return ptr;
 }
+
+#define STRING_STREAM_BLOCK_SIZE 32
+static void ensure_string_stream_space(StringStream *restrict stream,
+                                       size_t space) {
+    size_t min_size = stream->nchars + space;
+    size_t new_size = stream->size;
+    while (new_size < min_size) {
+        new_size += STRING_STREAM_BLOCK_SIZE;
+    }
+    if (new_size != stream->size) {
+        stream->buffer = lisp_realloc(stream->buffer, new_size + 1);
+    }
+}
+
+int string_stream_printf(StringStream *restrict stream,
+                         const char *restrict format, ...) {
+    va_list args;
+    va_start(args, format);
+    int rval = string_stream_vprintf(stream, format, args);
+    va_end(args);
+    return rval;
+}
+
+int string_stream_vprintf(StringStream *restrict stream,
+                          const char *restrict format, va_list args) {
+    va_list args_copy;
+    va_copy(args_copy, args);
+    int space = vsnprintf(NULL, 0, format, args_copy);
+    if (space < 0) {
+        abort();
+    }
+    va_end(args_copy);
+    ensure_string_stream_space(stream, space);
+    int rval = vsnprintf(stream->buffer + stream->nchars,
+                         stream->size + 1 - stream->nchars, format, args);
+    if (rval < 0) {
+        abort();
+    }
+    stream->nchars += rval;
+    return rval;
+}
+
+bool strgetline(const char *restrict buf, size_t buf_length,
+                const char **restrict start, size_t *restrict length) {
+    if (!*start) {
+        *start = buf;
+        if (!buf_length) {
+            *length = 0;
+            return true;
+        }
+    } else if (!buf_length) {
+        return false;
+    } else if (*start + *length >= buf + buf_length - 1) {
+        return false;
+    } else /* if (*start) */ {
+        *start += *length + 1;
+    }
+    size_t left = buf_length - (*start - buf);
+    char *found;
+    if ((found = memchr(*start, '\n', left))) {
+        *length = found - *start;
+    } else {
+        *length = left;
+    }
+    return true;
+}

src/memory.h

@@ -2,6 +2,7 @@
 #define INCLUDED_MEMORY_H
 
 #include <float.h>
+#include <stdarg.h>
 #include <stdbool.h>
 #include <stdint.h>
 #include <stdlib.h>
@@ -18,6 +19,12 @@
 #    define ALWAYS_INLINE inline
 #endif
 
+#if __has_attribute(format)
+#    define FORMAT(n, m) __attribute__((format(printf, n, m)))
+#else
+#    define FORMAT(n, m)
+#endif
+
 // Byte order stuff
 typedef enum {
     ENDIAN_LITTLE,
@@ -123,4 +130,40 @@ static ALWAYS_INLINE void add_timespecs(const struct timespec *t1,
     out->tv_nsec = nsec;
 }
 
+typedef struct {
+    // this is actually size + 1 bytes for the null byte
+    char *buffer;
+    size_t size;
+    size_t nchars;
+} StringStream;
+
+static inline void string_stream_init(StringStream *restrict stream) {
+    stream->buffer = lisp_malloc(1);
+    stream->size = 0;
+    stream->buffer[stream->size] = '\0';
+    stream->nchars = 0;
+}
+
+static inline void string_stream_free(StringStream *restrict stream) {
+    lisp_free(stream->buffer);
+}
+
+static inline void string_stream_steal(StringStream *restrict stream,
+                                       char **restrict out,
+                                       size_t *restrict out_length) {
+    *out = stream->buffer;
+    *out_length = stream->nchars;
+}
+
+int string_stream_printf(StringStream *restrict stream,
+                         const char *restrict format, ...) FORMAT(2, 3);
+int string_stream_vprintf(StringStream *restrict stream,
+                          const char *restrict format, va_list args);
+
+// Get the next line in BUF starting at *START (or &buf[0] if *START is
+// NULL). Store the length of the line in LENGTH. BUF is BUF_LENGTH bytes
+// long. Return true if we found another line and false otherwise.
+bool strgetline(const char *restrict buf, size_t buf_length,
+                const char **restrict start, size_t *restrict length);
+
 #endif

src/stack.c

@@ -1,5 +1,6 @@
 #include "stack.h"
 
+#include "function.h"
 #include "hashtable.h"
 #include "memory.h"
 
@@ -24,19 +25,37 @@ void lisp_init_stack(void) {
     the_stack.nogc_retval = Qnil;
 }
 
+static void teardown_stack_frame(struct StackFrame *restrict frame) {
+    for (size_t i = 0; i < frame->local_refs.num_blocks; ++i) {
+        lisp_free(frame->local_refs.blocks[i]);
+    }
+    lisp_free(frame->local_refs.blocks);
+}
+
+void lisp_teardown_stack(void) {
+    assert(the_stack.depth == 0);
+    for (size_t i = 0; i < the_stack.max_depth; ++i) {
+        teardown_stack_frame(&the_stack.frames[i]);
+    }
+    lisp_free(the_stack.frames);
+}
+
 void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
     assert(the_stack.depth < the_stack.max_depth);
     struct StackFrame *frame = &the_stack.frames[the_stack.depth++];
     frame->name = name;
     frame->fobj = fobj;
+    frame->evaled_args = false;
     frame->args = args;
     frame->lexenv = Qnil;
     frame->local_refs.num_refs = 0;
+    frame->marked = false;
+    gc_mark_stack_for_rescan();
 }
 
 static void reset_local_refs(struct LocalReferences *refs) {
     size_t last_block_size = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH;
-    size_t num_full_blocks = refs->num_blocks / LOCAL_REFERENCES_BLOCK_LENGTH;
+    size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
     for (size_t i = 0; i < num_full_blocks; ++i) {
         for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
             assert(OBJECTP(refs->blocks[i]->refs[j]));
@@ -73,6 +92,10 @@ static void store_local_reference_in_frame(struct StackFrame *frame,
         refs->blocks[num_full_blocks]
             ->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj;
     }
+    SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
+    // mark the frame for rescan
+    frame->marked = false;
+    gc_mark_stack_for_rescan();
 }
 
 void add_local_reference_no_recurse(LispVal *obj) {
@@ -82,33 +105,125 @@ void add_local_reference_no_recurse(LispVal *obj) {
     }
 }
 
+static LispVal *next_local_reference(size_t *restrict i) {
+    if (*i >= LISP_STACK_TOP()->local_refs.num_refs) {
+        return NULL;
+    }
+    size_t block_idx = *i / LOCAL_REFERENCES_BLOCK_LENGTH;
+    size_t small_idx = *i % LOCAL_REFERENCES_BLOCK_LENGTH;
+    LispVal *obj =
+        LISP_STACK_TOP()->local_refs.blocks[block_idx]->refs[small_idx];
+    ++*i;
+    return obj;
+}
+
+static inline void add_local_ref_if_not_seen_no_recurse(LispVal *seen_objs,
+                                                        LispVal *obj) {
+    if (NILP(Fgethash(seen_objs, obj, Qnil))) {
+        add_local_reference_no_recurse(obj);
+        Fputhash(seen_objs, obj, Qt);
+    }
+}
+
+static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs,
+                                                      LispVal *val) {
+    switch (((LispObject *) val)->type) {
+    case TYPE_CONS:
+        add_local_ref_if_not_seen_no_recurse(seen_objs,
+                                             ((LispCons *) val)->car);
+        add_local_ref_if_not_seen_no_recurse(seen_objs,
+                                             ((LispCons *) val)->cdr);
+        break;
+    case TYPE_SYMBOL: {
+        LispSymbol *sym = val;
+        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->name);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->value);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->function);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->plist);
+        break;
+    }
+    case TYPE_VECTOR: {
+        LispVector *vec = val;
+        for (size_t i = 0; i < vec->length; ++i) {
+            add_local_ref_if_not_seen_no_recurse(seen_objs, vec->data[i]);
+        }
+        break;
+    }
+    case TYPE_HASH_TABLE: {
+        HT_FOREACH_INDEX(val, i) {
+            add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_KEY(val, i));
+            add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_VALUE(val, i));
+        }
+        break;
+    }
+    case TYPE_FUNCTION: {
+        LispFunction *fobj = val;
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->name);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->docstr);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.req);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.opt);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.kw);
+        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.rest);
+        break;
+    }
+    case TYPE_STRING:
+        // no held refs
+        break;
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    default:
+        abort();
+    }
+}
+
 void add_local_reference(LispVal *obj) {
     add_local_reference_no_recurse(obj);
     LispVal *seen_objs = make_hash_table_no_gc(Qnil, Qnil);
-    ObjectProcessStack stack;
+    Fputhash(seen_objs, obj, Qt);
-    init_object_process_stack(&stack);
+    size_t i = LISP_STACK_TOP()->local_refs.num_refs - 1;
-    object_process_stack_push_held_objects(&stack, obj);
+    LispVal *cur;
-    while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
+    while ((cur = next_local_reference(&i))) {
-        LispVal *top = object_process_stack_pop(&stack);
+        add_local_refs_for_object_sub_vals(seen_objs, cur);
-        assert(OBJECTP(top));
-        if (!OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
-            store_local_reference_in_frame(LISP_STACK_TOP(), top);
-            SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
-        }
-        if (NILP(Fgethash(seen_objs, obj, Qnil))) {
-            object_process_stack_push_held_objects(&stack, top);
-            Fputhash(seen_objs, obj, Qt);
-        }
     }
-    free_object_process_stack(&stack);
     release_hash_table_no_gc(seen_objs);
 }
 
+void set_stack_evaluated_args(LispVal *args) {
+    assert(the_stack.depth > 0);
+    LISP_STACK_TOP()->evaled_args = true;
+    LISP_STACK_TOP()->args = args;
+    LISP_STACK_TOP()->marked = false;
+    gc_mark_stack_for_rescan();
+}
+
 void compact_stack_frame(struct StackFrame *restrict frame) {
     struct LocalReferences *restrict refs = &frame->local_refs;
     for (size_t i = 1; i < refs->num_blocks; ++i) {
         lisp_free(refs->blocks[i]);
     }
-    lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *));
+    refs->blocks =
+        lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *));
     refs->num_blocks = 1;
 }
+
+bool set_lexical_variable(LispVal *name, LispVal *value,
+                          bool create_if_absent) {
+    assert(the_stack.depth != 0);
+    DOTAILS(rest, LISP_STACK_TOP()->lexenv) {
+        if (EQ(XCAR(rest), name)) {
+            RPLACA(XCDR(rest), value);
+            return true;
+        }
+    }
+    if (create_if_absent) {
+        new_lexical_variable(name, value);
+    }
+    return create_if_absent;
+}
+
+void copy_parent_lexenv(void) {
+    assert(the_stack.depth != 0);
+    if (the_stack.depth > 1) {
+        LISP_STACK_TOP()->lexenv = the_stack.frames[the_stack.depth - 2].lexenv;
+    }
+}

src/stack.h

@@ -2,6 +2,7 @@
 #define INCLUDED_STACK_H
 
 #include "base.h"
+#include "list.h"
 
 #define DEFAULT_MAX_LISP_EVAL_DEPTH   1000
 #define LOCAL_REFERENCES_BLOCK_LENGTH 64
@@ -19,9 +20,12 @@ struct LocalReferences {
 struct StackFrame {
     LispVal *name; // name of function call
     LispVal *fobj; // the function object
+    bool evaled_args; // whether args have been evaluated yet
     LispVal *args; // arguments of the function call
     LispVal *lexenv; // lexical environment (plist)
     struct LocalReferences local_refs;
+
+    bool marked; // whether we have GC'ed this frame
 };
 
 struct LispStack {
@@ -40,12 +44,40 @@ static ALWAYS_INLINE struct StackFrame *LISP_STACK_TOP(void) {
     return the_stack.depth ? &the_stack.frames[the_stack.depth - 1] : NULL;
 }
 
+static ALWAYS_INLINE LispVal *TOP_LEXENV(void) {
+    return the_stack.depth ? LISP_STACK_TOP()->lexenv : Qnil;
+}
+
+static ALWAYS_INLINE LispVal *PARENT_LEXENV(void) {
+    return the_stack.depth > 1 ? the_stack.frames[the_stack.depth - 2].lexenv
+                               : Qnil;
+}
+
 void lisp_init_stack(void);
+void lisp_teardown_stack(void);
 void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args);
 void pop_stack_frame(void);
 void add_local_reference_no_recurse(LispVal *obj);
 void add_local_reference(LispVal *obj);
 
+// replace the args in the top stack frame with ARGS and mark them as evaluted
+// (this is for backtraces)
+void set_stack_evaluated_args(LispVal *args);
+
+// Return true if successful, false if not found and not created
+bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent);
+// Just add a new lexical variable without any checking
+static inline void new_lexical_variable(LispVal *name, LispVal *value) {
+    assert(the_stack.depth != 0);
+    LISP_STACK_TOP()->lexenv =
+        CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
+    LISP_STACK_TOP()->marked = false;
+    gc_mark_stack_for_rescan();
+}
+
+// Copy the previous frame's lexenv to the top of the stack.
+void copy_parent_lexenv(void);
+
 // used by the GC
 void compact_stack_frame(struct StackFrame *restrict frame);