Work on functions

.clangd

@@ -5,7 +5,7 @@ CompileFlags:
       -Wall,
       -Wpedantic,
       -xc,
-      -D_POSIX_C_SOURCE=199309L,
+      -D_POSIX_C_SOURCE=200112L,
       "-Isrc",
       "-I../",
     ]

Makefile

@@ -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)
 

lisp/kernel.gl

@@ -0,0 +1,4 @@
+;; -*- mode: lisp-data -*-
+
+(print (funcall (let ((te 'a))
+                    (lambda (b &optional (a te)) a)) 2))

src/base.c

@@ -51,7 +51,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();

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;
@@ -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,6 +197,7 @@ 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
 
@@ -212,61 +235,19 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
 }
 
 // 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))
-           && NILP(fobj->args.rest);
-}
-
-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;
     DOLIST(arg, args) {
-        if (fobj->flags.no_eval_args) {
+        if (NILP(start)) {
-            arg_arr[acount] = arg;
+            start = CONS(Feval(arg, PARENT_LEXENV()), Qnil);
+            end = start;
         } else {
-            arg_arr[acount] = Feval(arg, PARENT_LEXENV());
+            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->flags.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,12 +347,9 @@ 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], PARENT_LEXENV());
         }
         add_local_reference(arg_arr[i]);
     }
@@ -396,35 +384,163 @@ 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))) {
+            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) {
+            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)));
+        }
+    }
+    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);
     }
-    if (!FUNCTIONP(fobj)) {
+    // include symbol here for the error message
-        // TODO error
+    CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
-        abort();
-    }
-    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->flags.type = FUNCTION_INTERP;
+    fobj->flags.no_eval_args = false;
+    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

@@ -30,10 +30,14 @@ union native_function {
     LispVal *(*five)(LispVal *, LispVal *, LispVal *, LispVal *, LispVal *);
 };
 
+struct interp_function {
+    LispVal *body; // list of forms
+    LispVal *lexenv;
+};
+
 typedef enum {
     FUNCTION_NATIVE,
     FUNCTION_INTERP,
-    FUNCTION_BYTECOMP,
 } LispFunctionType;
 
 struct function_flags {
@@ -48,6 +52,7 @@ DEFOBJTYPE(Function, FUNCTION, FUNCTIONP, {
     LispVal *docstr;
     union {
         union native_function native;
+        struct interp_function interp;
     } impl;
 });
 
@@ -89,4 +94,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

@@ -165,7 +165,8 @@ static inline void make_grey_if_while(LispVal *val) {
 }
 
 static void mark_object(LispVal *val) {
-    if (!OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
+    // check for null for newly constructed objects
+    if (!val || !OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
         return;
     }
     switch (((LispObject *) val)->type) {

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/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,13 @@ static void register_manual_symbols(void) {
 void lisp_init(void) {
     construct_manual_symbols();
     obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
+
+    // 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 =
@@ -107,6 +115,32 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
     }
 }
 
+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:
@@ -133,7 +167,14 @@ 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: {
@@ -169,32 +210,6 @@ void debug_print(FILE *file, LispVal *obj) {
     }
 }
 
-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_obj_info(FILE *file, LispVal *obj) {
     fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
     debug_print(file, obj);

src/main.c

@@ -1,22 +1,31 @@
 #include "lisp.h"
 #include "read.h"
 
+#include <stdio.h>
+
 DEFUN(print, "print", (LispVal * v), "(v)", "") {
     debug_obj_info(stdout, v);
     return Qnil;
 }
 
 int main(int argc, const char **argv) {
+    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(print);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "(let ((a 1)) (print a))";
+    read_stream_init(&s, src, src_len);
-    read_stream_init(&s, BUF, sizeof(BUF) - 1);
     LispVal *l = read(&s);
     Feval(l, Qnil);
     lisp_gc_now(NULL);
     pop_stack_frame();
     lisp_shutdown();
+    free(src);
     return 0;
 }

src/stack.c

@@ -2,7 +2,6 @@
 
 #include "function.h"
 #include "hashtable.h"
-#include "list.h"
 #include "memory.h"
 
 #include <assert.h>
@@ -46,6 +45,7 @@ void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
     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;
@@ -182,6 +182,12 @@ void add_local_reference(LispVal *obj) {
     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;
+}
+
 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) {
@@ -206,12 +212,6 @@ bool set_lexical_variable(LispVal *name, LispVal *value,
     return create_if_absent;
 }
 
-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));
-}
-
 void copy_parent_lexenv(void) {
     assert(the_stack.depth != 0);
     if (the_stack.depth > 1) {

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,6 +20,7 @@ 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;
@@ -56,10 +58,18 @@ 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
-void new_lexical_variable(LispVal *name, LispVal *value);
+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));
+}
 
 // Copy the previous frame's lexenv to the top of the stack.
 void copy_parent_lexenv(void);