Add eval

src/base.c

@@ -22,13 +22,13 @@ void *lisp_alloc_object(size_t size, LispValType type) {
     LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size);
     obj->type = type;
     obj->gc.mark = false;
-    obj->gc.local_ref_count = 0;
+    obj->gc.has_local_ref = false;
     // TODO set the below
     obj->gc.entry = NULL;
     return obj;
 }
 
-void signal_type_error(LispVal *obj, size_t count,
+void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                            const LispValType types[count]) {
     // TODO actually throw an error
     fprintf(stderr, "Type error! Got: %s | Expected: (or ",
@@ -40,15 +40,19 @@ void signal_type_error(LispVal *obj, size_t count,
     abort();
 }
 
+noreturn void signal_type_error(LispVal *obj, LispVal *typespec) {
+    // TODO actually throw an error
+    fprintf(stderr,
+            "Type error! Got: %s | Expected: ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
+    debug_print(stderr, typespec);
+    fputc('\n', stderr);
+    abort();
+}
+
 DEFINE_SYMBOL(nil, "nil");
 DEFINE_SYMBOL(t, "t");
 DEFINE_SYMBOL(unbound, "unbound");
 
-DEFINE_SYMBOL(quote, "quote");
-DEFINE_SYMBOL(backquote, "`");
-DEFINE_SYMBOL(comma, ",");
-DEFINE_SYMBOL(comma_at, ",@");
-
 DEFUN(id, "id", (LispVal * obj), "(id)", "") {
     // TODO not all values are handled here
     return MAKE_FIXNUM((uintptr_t) obj);
@@ -58,6 +62,10 @@ DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
     return obj1 == obj2 ? Qt : Qnil;
 }
 
+DEFSPECIAL(quote, "quote", (LispVal * form), "(form)", "") {
+    return form;
+}
+
 // ################
 // # Constructors #
 // ################
@@ -109,3 +117,7 @@ DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve),
     }
     return sym;
 }
+
+DEFINE_SYMBOL(backquote, "`");
+DEFINE_SYMBOL(comma, ",");
+DEFINE_SYMBOL(comma_at, ",@");

src/base.h

@@ -111,6 +111,17 @@ static ALWAYS_INLINE bool OBJECT_MARKED_P(LispVal *val) {
     return ((LispObject *) val)->gc.mark;
 }
 
+static ALWAYS_INLINE void SET_OBJECT_HAS_LOCAL_REFERENCE(LispVal *val,
+                                                         bool has_local_ref) {
+    assert(OBJECTP(val));
+    ((LispObject *) val)->gc.has_local_ref = has_local_ref;
+}
+
+static ALWAYS_INLINE bool OBJECT_HAS_LOCAL_REFERENCE_P(LispVal *val) {
+    assert(OBJECTP(val));
+    return ((LispObject *) val)->gc.has_local_ref;
+}
+
 static ALWAYS_INLINE LispValType TYPE_OF(LispVal *val) {
     if (FIXNUMP(val)) {
         return TYPE_FIXNUM;
@@ -131,7 +142,8 @@ static ALWAYS_INLINE bool LISP_TYPEP(LispVal *val, LispValType type) {
     }
 }
 
-noreturn void signal_type_error(LispVal *obj, size_t count,
+noreturn void
+internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                       const LispValType types[count]);
 static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
                                               LispValType v1, LispValType v2,
@@ -144,7 +156,7 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
         }
     }
     // Failed
-    signal_type_error(obj, count, types);
+    internal_CHECK_TYPE_signal_type_error(obj, count, types);
 }
 #define internal_CHECK_TYPE1(obj, type) internal_CHECK_TYPE(obj, v1, )
 #define internal_CHECK_TYPE_SUB(obj, count, a1, a2, a3, a4, a5, a6, ...) \
@@ -154,6 +166,8 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
                             TYPE_FIXNUM, TYPE_FIXNUM, TYPE_FIXNUM,       \
                             TYPE_FIXNUM, TYPE_FIXNUM, TYPE_FIXNUM)
 
+noreturn void signal_type_error(LispVal *obj, LispVal *typespec);
+
 #define DEFOBJTYPE(Name, NAME, NAME_P, body)         \
     typedef struct {                                 \
         LispObject header;                           \
@@ -218,6 +232,8 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     const size_t internal_F##cname##_docstr_len = sizeof(doc) - 1;       \
     LispVal *Q##cname;                                                   \
     LispVal *F##cname cargs
+#define DEFSPECIAL(cname, lisp_name, cargs, lisp_args, doc) \
+    DEFUN(cname, lisp_name, cargs, lisp_args, doc)
 
 #define REGISTER_GLOBAL_SYMBOL(cname)                                     \
     {                                                                     \
@@ -231,6 +247,14 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
         ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
     }
 
+#define REGISTER_GLOBAL_SPECIAL(cname)                                     \
+    {                                                                      \
+        REGISTER_GLOBAL_SYMBOL(cname);                                     \
+        ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
+        ((LispFunction *) ((LispSymbol *) Q##cname)->function)             \
+            ->flags.no_eval_args = true;                                   \
+    }
+
 DECLARE_SYMBOL(nil);
 DECLARE_SYMBOL(t);
 DECLARE_SYMBOL(unbound);
@@ -242,6 +266,7 @@ static ALWAYS_INLINE bool NILP(LispVal *val) {
 // Some core functions
 DECLARE_FUNCTION(id, (LispVal * obj));
 DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
+DECLARE_FUNCTION(quote, (LispVal * form));
 
 // TODO probably move these to another file
 LispVal *make_vector(LispVal **data, size_t length, bool take);
@@ -249,8 +274,7 @@ DECLARE_FUNCTION(make_symbol, (LispVal * name));
 DECLARE_FUNCTION(intern, (LispVal * name));
 DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve));
 
-// TODO these are actually special-forms
+// Defined in lisp code (eventually) but used in read.c
-DECLARE_SYMBOL(quote);
 DECLARE_SYMBOL(backquote);
 DECLARE_SYMBOL(comma);
 DECLARE_SYMBOL(comma_at);

src/function.c

@@ -226,37 +226,44 @@ call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
         fprintf(stderr, "Wrong arg count!!\n");
         abort();
     }
+    LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS];
+    size_t acount = 0;
     FOREACH(args, arg) {
-        add_local_reference(arg);
+        if (fobj->flags.no_eval_args) {
+            arg_arr[acount] = arg;
+        } else {
+            arg_arr[acount] = Feval(arg);
+        }
+        add_local_reference(arg_arr[acount++]);
     }
     LispVal *retval;
-    switch (fobj->args.n_req) {
+    switch (acount) {
     case 0:
         retval = fobj->impl.native.zero();
         break;
     case 1:
-        retval = fobj->impl.native.one(FIRST(args));
+        retval = fobj->impl.native.one(arg_arr[0]);
         break;
     case 2:
-        retval = fobj->impl.native.two(FIRST(args), SECOND(args));
+        retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
         break;
     case 3:
-        retval =
+        retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
-            fobj->impl.native.three(FIRST(args), SECOND(args), THIRD(args));
         break;
     case 4:
-        retval = fobj->impl.native.four(FIRST(args), SECOND(args), THIRD(args),
+        retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        FOURTH(args));
+                                        arg_arr[3]);
         break;
     case 5:
-        retval = fobj->impl.native.five(FIRST(args), SECOND(args), THIRD(args),
+        retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
-                                        FOURTH(args), FIFTH(args));
+                                        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;
 }
 
@@ -351,9 +358,10 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
     for (intptr_t i = 0; i < count; ++i) {
         if (!arg_arr[i]) {
             arg_arr[i] = Qnil;
-        } else {
+        } else if (!fobj->flags.no_eval_args) {
-            add_local_reference(arg_arr[i]);
+            arg_arr[i] = Feval(arg_arr[i]);
         }
+        add_local_reference(arg_arr[i]);
     }
     LispVal *retval;
     switch (count) {
@@ -382,6 +390,7 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
     }
     the_stack.nogc_retval = retval;
     pop_stack_frame();
+    add_local_reference(the_stack.nogc_retval);
     return retval;
 }
 

src/gc.h

@@ -11,7 +11,7 @@ typedef struct GCEntry {
 
 typedef struct {
     unsigned int mark : 1;
-    unsigned int local_ref_count : 7;
+    unsigned int has_local_ref : 1;
     GCEntry *entry;
 } ObjectGCInfo;
 

src/gen-init-globals.awk

@@ -76,6 +76,11 @@ function maybe_emit_next_symbol(entity) {
     maybe_emit_next_symbol("FUNCTION")
 }
 
+/DEFSPECIAL\(/ {
+    maybe_print_file_header()
+    maybe_emit_next_symbol("SPECIAL")
+}
+
 /DEFINE_SYMBOL\(/ {
     maybe_print_file_header()
     maybe_emit_next_symbol("SYMBOL")

src/lisp.c

@@ -49,6 +49,49 @@ void lisp_init() {
 
 void lisp_shutdown() {}
 
+DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
+    if (!OBJECTP(form)) {
+        // fixnum or float
+        return form;
+    }
+    switch (((LispObject *) form)->type) {
+    case TYPE_HASH_TABLE:
+    case TYPE_FUNCTION:
+    case TYPE_STRING:
+        return form;
+    case TYPE_VECTOR: {
+        LispVector *vec = form;
+        LispVal **out_data = lisp_malloc(sizeof(LispVal *) * vec->length);
+        LispVector *newvec = make_vector(out_data, vec->length, true);
+        for (size_t i = 0; i < vec->length; ++i) {
+            out_data[i] = Qnil;
+        }
+        for (size_t i = 0; i < vec->length; ++i) {
+            out_data[i] = Feval(vec->data[i]);
+        }
+        return newvec;
+    }
+    case TYPE_SYMBOL: {
+        // TODO local bindings
+        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));
+    }
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    default:
+        abort();
+    }
+}
+
 void debug_print(FILE *file, LispVal *obj) {
     switch (TYPE_OF(obj)) {
     case TYPE_FIXNUM:

src/lisp.h

@@ -16,6 +16,8 @@ void lisp_init(void);
 
 void lisp_shutdown(void);
 
+DECLARE_FUNCTION(eval, (LispVal * form));
+
 void debug_print(FILE *file, LispVal *obj);
 void debug_obj_info(FILE *file, LispVal *obj);
 

src/list.c

@@ -17,7 +17,6 @@ intptr_t list_length(LispVal *list) {
 }
 
 bool list_length_eq(LispVal *list, intptr_t size) {
-    assert(LISTP(list));
     while (size && CONSP(list)) {
         list = XCDR(list);
         --size;
@@ -52,3 +51,11 @@ DEFUN(nreverse, "nreverse", (LispVal * list), "(list)", "") {
     }
     return rev;
 }
+
+DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
+    return LISTP(obj) ? Qt : Qnil;
+}
+
+DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
+    return args;
+}

src/list.h

@@ -112,5 +112,12 @@ DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr));
 DECLARE_FUNCTION(length, (LispVal * list));
 DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
+DECLARE_FUNCTION(listp, (LispVal * obj));
+DECLARE_FUNCTION(list, (LispVal * args));
+static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
+    if (!LISTP(obj)) {
+        signal_type_error(obj, LIST(Qlist));
+    }
+}
 
 #endif

src/main.c

@@ -17,7 +17,7 @@ int main(int argc, const char **argv) {
     REGISTER_GLOBAL_FUNCTION(cool_func);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "()";
+    const char BUF[] = "(1 'a)";
     read_stream_init(&s, BUF, sizeof(BUF) - 1);
     LispVal *l = read(&s);
     Ffuncall(Qcool_func, l);

src/stack.c

@@ -45,13 +45,15 @@ static void reset_local_refs(struct LocalReferences *refs) {
     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]));
-            --((LispObject *) refs->blocks[i]->refs[j])->gc.local_ref_count;
+            // TODO recurse into object
+            SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[i]->refs[j], false);
         }
     }
     for (size_t i = 0; i < last_block_size; ++i) {
         assert(OBJECTP(refs->blocks[num_full_blocks]->refs[i]));
-        --((LispObject *) refs->blocks[num_full_blocks]->refs[i])
+        // TODO recurse into object
-              ->gc.local_ref_count;
+        SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[num_full_blocks]->refs[i],
+                                       false);
     }
 }
 
@@ -84,10 +86,11 @@ static bool store_local_reference_in_frame(struct StackFrame *frame,
 
 void add_local_reference(LispVal *obj) {
     assert(the_stack.depth > 0);
-    if (OBJECTP(obj)) {
+    if (OBJECTP(obj) && OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
         if (store_local_reference_in_frame(LISP_STACK_TOP(), obj)) {
             the_stack.first_clear_local_refs = the_stack.depth;
         }
-        ++((LispObject *) obj)->gc.local_ref_count;
+        // TODO recurse into object
+        SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
     }
 }