Builtin function argument parsing

src/base.c

@@ -78,8 +78,12 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
     LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL);
     obj->name = name;
     obj->function = Qnil;
-    obj->value = Qunbound;
     obj->plist = Qnil;
+    if (KEYWORDP(obj)) {
+        obj->value = obj;
+    } else {
+        obj->value = Qunbound;
+    }
     return obj;
 }
 

src/base.h

@@ -164,6 +164,12 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
     }                                                \
     struct __ignored
 
+DEFOBJTYPE(String, STRING, STRINGP, {
+    size_t length;
+    char *data;
+    bool owned;
+});
+
 DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, {
     LispVal *name; // string
     LispVal *function;
@@ -171,6 +177,14 @@ DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, {
     LispVal *plist;
 });
 
+static ALWAYS_INLINE bool KEYWORDP(LispVal *val) {
+    if (!SYMBOLP(val)) {
+        return false;
+    }
+    LispString *sym = (LispString *) ((LispSymbol *) val)->name;
+    return sym->length && *sym->data == ':';
+}
+
 DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     size_t length;
     LispVal **data;
@@ -205,6 +219,18 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     LispVal *Q##cname;                                                   \
     LispVal *F##cname cargs
 
+#define REGISTER_GLOBAL_SYMBOL(cname)                                     \
+    {                                                                     \
+        Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name,     \
+                                            internal_Q##cname##_name_len, \
+                                            false, false));               \
+    }
+#define REGISTER_GLOBAL_FUNCTION(cname)                                    \
+    {                                                                      \
+        REGISTER_GLOBAL_SYMBOL(cname);                                     \
+        ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
+    }
+
 DECLARE_SYMBOL(nil);
 DECLARE_SYMBOL(t);
 DECLARE_SYMBOL(unbound);

src/function.c

@@ -6,6 +6,7 @@
 
 #include <stdio.h>
 #include <stdlib.h>
+#include <string.h>
 
 const char *llps_strerror(LambdaListParseStatus status) {
     static const char *MSGS[LLPS_N_ERROS] = {
@@ -13,8 +14,11 @@ const char *llps_strerror(LambdaListParseStatus status) {
         [LLPS_DOTTED] = "Dotted list",
         [LLPS_REPEAT_SECTION] = "Repeated section",
         [LLPS_REPEAT_NAME] = "Repeated name",
-        [LLPS_SYNTAX] = "Syntax error",
+        [LLPS_ORDER] = "Section out of order",
         [LLPS_BAD_NAME] = "Invalid variable name",
+        [LLPS_REPEAT_REST] = "Too many rest variables",
+        [LLPS_AFTER_ALLOW_OTHER_KEYS] = "Variable after &allow-other-keys",
+        [LLPS_INVALID_OPT_SPEC] = "Invalid optional spec",
     };
     return MSGS[status];
 }
@@ -28,6 +32,17 @@ static bool is_valid_variable_name(LispVal *val) {
     return SYMBOLP(val) && !NILP(val) && val != Qt && val != Qunbound;
 }
 
+static LispVal *intern_as_keyword(LispVal *name) {
+    assert(SYMBOLP(name));
+    LispString *name_str = ((LispSymbol *) name)->name;
+    char *kw_name = lisp_malloc(name_str->length + 2);
+    kw_name[0] = ':';
+    memcpy(kw_name + 1, name_str->data, name_str->length);
+    kw_name[name_str->length + 1] = '\0';
+    return Fintern(
+        make_lisp_string(kw_name, name_str->length + 1, true, false));
+}
+
 // on error, put the object that caused the problem in entry
 static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
                                                      LispVal *entry) {
@@ -64,7 +79,7 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
         return LLPS_OK;
     } else {
         *out = entry;
-        return LLPS_SYNTAX;
+        return LLPS_INVALID_OPT_SPEC;
     }
 }
 
@@ -75,7 +90,7 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
         return;                  \
     }
 void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
-    enum { REQ = 0, OPT = 1, KEY = 2, REST, MUST_CHANGE } mode = REQ;
+    enum { REQ = 0, OPT = 1, KEY = 2, REST = 4, MUST_CHANGE } mode = REQ;
     unsigned int seen = 0;
     result->err_obj = Qnil;
     result->status = LLPS_OK;
@@ -83,31 +98,39 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
     // TODO check for repeat names
     out->n_req = 0;
     out->n_opt = 0;
-    out->n_kw = 0;
     out->allow_other_keys = false;
     out->req = Qnil;
     out->opt = Qnil;
     out->kw = Qnil;
     out->rest = Qnil;
+    size_t cur_idx = 0; // for keyword args
     FOREACH_TAIL(list, tail) {
         if (!LISTP(tail)) {
             RETURN_ERROR(LLPS_DOTTED, list);
+        } else if (out->allow_other_keys) {
+            RETURN_ERROR(LLPS_AFTER_ALLOW_OTHER_KEYS, XCAR(tail));
         }
         LispVal *cur = XCAR(tail);
         if (cur == Qand_allow_other_keys) {
             if (out->allow_other_keys) {
-                RETURN_ERROR(LLPS_REPEAT_SECTION, list);
+                RETURN_ERROR(LLPS_REPEAT_SECTION, cur);
+            } else if (!(seen & KEY)) {
+                RETURN_ERROR(LLPS_ORDER, cur);
             }
             out->allow_other_keys = true;
-            mode = MUST_CHANGE;
         } else if (cur == Qand_rest) {
-            if (!NILP(out->rest) || mode == REST) {
+            if (seen & REST) {
-                RETURN_ERROR(LLPS_REPEAT_SECTION, list)
+                RETURN_ERROR(LLPS_REPEAT_SECTION, cur)
+            } else if (seen & KEY) {
+                RETURN_ERROR(LLPS_ORDER, cur);
             }
+            seen |= REST;
             mode = REST;
         } else if (cur == Qand_optional) {
             if (seen & OPT) {
-                RETURN_ERROR(LLPS_REPEAT_SECTION, list)
+                RETURN_ERROR(LLPS_REPEAT_SECTION, cur)
+            } else if (seen & KEY || seen & REST) {
+                RETURN_ERROR(LLPS_ORDER, cur);
             }
             seen |= OPT;
             mode = OPT;
@@ -117,15 +140,15 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
             }
             seen |= KEY;
             mode = KEY;
-        } else if (mode == MUST_CHANGE) {
+            out->kw = Fmake_hash_table(Qnil, Qnil);
-            // &rest without a variable
-            RETURN_ERROR(LLPS_SYNTAX, list)
         } else if (mode == REST) {
-            if (!is_valid_variable_name(cur)) {
+            if (!NILP(out->rest)) {
+                RETURN_ERROR(LLPS_REPEAT_REST, cur);
+            } else if (!is_valid_variable_name(cur)) {
                 RETURN_ERROR(LLPS_BAD_NAME, cur)
             }
             out->rest = cur;
-            mode = MUST_CHANGE;
+            ++cur_idx;
         } else if (mode == OPT || mode == KEY) {
             LispVal *entry;
             LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur);
@@ -136,22 +159,20 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
                 out->opt = CONS(entry, out->opt);
                 ++out->n_opt;
             } else {
-                out->kw = CONS(entry, out->kw);
+                Fputhash(out->kw, intern_as_keyword(XCAR(entry)),
-                ++out->n_kw;
+                         CONS(MAKE_FIXNUM(cur_idx), entry));
             }
+            ++cur_idx;
         } else if (!is_valid_variable_name(cur)) {
             RETURN_ERROR(LLPS_BAD_NAME, cur);
         } else {
             out->req = CONS(cur, out->req);
             ++out->n_req;
+            ++cur_idx;
         }
     }
-    if ((seen & KEY) == 0 && out->allow_other_keys) {
-        RETURN_ERROR(LLPS_SYNTAX, list);
-    }
     out->req = Fnreverse(out->req);
     out->opt = Fnreverse(out->opt);
-    out->kw = Fnreverse(out->kw);
 }
 #undef RETURN_ERROR
 
@@ -184,13 +205,16 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
         fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args);
         exit(1);
     }
+    obj->args = result.lambda_list;
     return obj;
 }
 
 // Calling functions
 // A simple function has only required args
 static ALWAYS_INLINE bool SIMPLE_FUNCTION_P(LispFunction *fobj) {
-    return !fobj->args.n_opt && !fobj->args.n_kw && NILP(fobj->args.rest);
+    return !fobj->args.n_opt
+           && (NILP(fobj->args.kw) || !HASH_TABLE_COUNT(fobj->args.kw))
+           && NILP(fobj->args.rest);
 }
 
 static ALWAYS_INLINE LispVal *
@@ -209,24 +233,155 @@ call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
     switch (fobj->args.n_req) {
     case 0:
         retval = fobj->impl.native.zero();
+        break;
     case 1:
         retval = fobj->impl.native.one(FIRST(args));
+        break;
     case 2:
         retval = fobj->impl.native.two(FIRST(args), SECOND(args));
+        break;
     case 3:
         retval =
             fobj->impl.native.three(FIRST(args), SECOND(args), THIRD(args));
+        break;
     case 4:
         retval = fobj->impl.native.four(FIRST(args), SECOND(args), THIRD(args),
                                         FOURTH(args));
+        break;
     case 5:
         retval = fobj->impl.native.five(FIRST(args), SECOND(args), THIRD(args),
                                         FOURTH(args), FIFTH(args));
+        break;
     default:
         abort();
     }
+    the_stack.nogc_retval = retval;
+    pop_stack_frame();
+    return retval;
+}
+
+enum ProcessArgsResult {
+    PROCESS_ARGS_OK,
+    PROCESS_ARGS_TOO_FEW,
+    PROCESS_ARGS_TOO_MANY,
+    PROCESS_ARGS_NO_KEY_VALUE,
+    PROCESS_ARGS_BAD_KEY,
+    PROCESS_ARGS_N_ERRORS,
+};
+
+static const char *process_args_strerror(enum ProcessArgsResult status) {
+    static const char *MSGS[PROCESS_ARGS_N_ERRORS] = {
+        [PROCESS_ARGS_OK] = "No error",
+        [PROCESS_ARGS_TOO_FEW] = "Not enough arguments",
+        [PROCESS_ARGS_TOO_MANY] = "Too many arguments",
+        [PROCESS_ARGS_NO_KEY_VALUE] = "Key without a value",
+        [PROCESS_ARGS_BAD_KEY] = "Unknown key",
+    };
+    return MSGS[status];
+}
+
+static ALWAYS_INLINE size_t NATIVE_FUNCTION_TOTAL_ARG_COUNT(LispVal *val) {
+    assert(FUNCTIONP(val));
+    LispFunction *fobj = val;
+    return fobj->args.n_req + fobj->args.n_opt + !NILP(fobj->args.rest)
+           + (NILP(fobj->args.kw) ? 0 : HASH_TABLE_COUNT(fobj->args.kw));
+}
+
+static ALWAYS_INLINE enum ProcessArgsResult
+process_complex_native_args(LispFunction *fobj, LispVal *args,
+                            LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS]) {
+    size_t rem_req = fobj->args.n_req;
+    size_t rem_opt = fobj->args.n_opt;
+    size_t idx = 0;
+    while (rem_req--) {
+        if (NILP(args)) {
+            return PROCESS_ARGS_TOO_FEW;
+        }
+        out[idx++] = XCAR(args);
+        args = XCDR(args);
+    }
+    while (rem_opt--) {
+        if (NILP(args)) {
+            return PROCESS_ARGS_OK;
+        }
+        out[idx++] = XCAR(args);
+        args = XCDR(args);
+    }
+    if (!NILP(args) && (NILP(fobj->args.kw)) && NILP(fobj->args.rest)) {
+        return PROCESS_ARGS_TOO_MANY;
+    }
+    if (!NILP(fobj->args.rest)) {
+        out[idx++] = args;
+    }
+    if (NILP(fobj->args.kw)) { // we are not a keyword function
+        return PROCESS_ARGS_OK;
+    }
+    while (!NILP(args)) {
+        if (NILP(XCDR(args))) {
+            return PROCESS_ARGS_NO_KEY_VALUE;
+        }
+        LispVal *entry = Fgethash(fobj->args.kw, XCAR(args), Qnil);
+        if (!NILP(entry)) {
+            fixnum_t idx = XFIXNUM(XCAR(entry));
+            if (!out[idx]) {
+                out[idx] = XCAR(XCDR(args));
+            }
+        } else if (!fobj->args.allow_other_keys) {
+            return PROCESS_ARGS_BAD_KEY;
+        }
+        args = XCDR(XCDR(args));
+    }
+    return PROCESS_ARGS_OK;
+}
+
+static ALWAYS_INLINE LispVal *
+call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
+    LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL};
+    size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj);
+    enum ProcessArgsResult res =
+        process_complex_native_args(fobj, args, arg_arr);
+    if (res != PROCESS_ARGS_OK) {
+        // TODO better errors
+        printf("Bad arguments to builtin \"");
+        debug_print(stdout, orig_func);
+        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 {
+            add_local_reference(arg_arr[i]);
+        }
+    }
+    LispVal *retval;
+    switch (count) {
+    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();
-    // TODO probably need to protect retval from GC here
     return retval;
 }
 
@@ -235,7 +390,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
     if (SIMPLE_FUNCTION_P(fobj)) {
         return call_simple_native(orig_func, fobj, args);
     }
-    return Qnil;
+    return call_complex_native(orig_func, fobj, args);
 }
 
 DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
@@ -249,6 +404,9 @@ DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
         // TODO error
         abort();
     }
+    if (!fobj->flags.no_eval_args) {
+        // TODO evaluate arguments
+    }
     switch (fobj->flags.type) {
     case FUNCTION_NATIVE:
         return call_native(func, fobj, args);

src/function.h

@@ -12,11 +12,12 @@ DECLARE_SYMBOL(and_allow_other_keys);
 struct LambdaList {
     size_t n_req;
     size_t n_opt;
-    size_t n_kw;
     bool allow_other_keys;
     LispVal *req; // list of symbols
     LispVal *opt; // list of lists of (name default has-p-name)
-    LispVal *kw; // ditto opt
+    LispVal *kw; // hash table mapping name (a keyword) to a list of (index name
+                 // default has-p-name). This is nil if we are not a keyword
+                 // function.
     LispVal *rest; // symbol (non-nil if we have a rest arg)
 };
 
@@ -56,8 +57,11 @@ typedef enum {
     LLPS_DOTTED,
     LLPS_REPEAT_SECTION,
     LLPS_REPEAT_NAME,
-    LLPS_SYNTAX,
+    LLPS_ORDER,
     LLPS_BAD_NAME,
+    LLPS_REPEAT_REST,
+    LLPS_AFTER_ALLOW_OTHER_KEYS,
+    LLPS_INVALID_OPT_SPEC,
     LLPS_N_ERROS,
 } LambdaListParseStatus;
 
@@ -84,5 +88,6 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(),
                          internal_F##cname##_docstr_len, false, false))
 
 DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
+#define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
 
 #endif

src/hashtable.h

@@ -23,4 +23,9 @@ DECLARE_FUNCTION(puthash, (LispVal * ht, LispVal *key, LispVal *val));
 DECLARE_FUNCTION(remhash, (LispVal * ht, LispVal *key));
 DECLARE_FUNCTION(hash_table_count, (LispVal * ht));
 
+static ALWAYS_INLINE size_t HASH_TABLE_COUNT(LispVal *ht) {
+    assert(HASH_TABLE_P(ht));
+    return ((LispHashTable *) ht)->count;
+}
+
 #endif

src/init_globals.h

@@ -6,18 +6,4 @@
 // defined in a generated file
 void register_globals(void);
 
-#include <stdio.h>
-
-#define REGISTER_GLOBAL_SYMBOL(cname)                                     \
-    {                                                                     \
-        Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name,     \
-                                            internal_Q##cname##_name_len, \
-                                            false, false));               \
-    }
-#define REGISTER_GLOBAL_FUNCTION(cname)                                    \
-    {                                                                      \
-        REGISTER_GLOBAL_SYMBOL(cname);                                     \
-        ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
-    }
-
 #endif

src/lisp_string.h

@@ -3,11 +3,7 @@
 
 #include "base.h"
 
-DEFOBJTYPE(String, STRING, STRINGP, {
+// LispString (the type) is defined in base.h
-    size_t length;
-    char *data;
-    bool owned;
-});
 
 LispVal *make_lisp_string(const char *data, size_t length, bool take,
                           bool copy);

src/list.c

@@ -18,8 +18,9 @@ intptr_t list_length(LispVal *list) {
 
 bool list_length_eq(LispVal *list, intptr_t size) {
     assert(LISTP(list));
-    while (size-- && CONSP(list)) {
+    while (size && CONSP(list)) {
         list = XCDR(list);
+        --size;
     }
     return size == 0 && NILP(list);
 }

src/main.c

@@ -3,15 +3,24 @@
 
 #include <stdio.h>
 
+DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)",
+      "") {
+    printf("A: ");
+    debug_obj_info(stdout, a);
+    printf("B: ");
+    debug_obj_info(stdout, b);
+    return Qnil;
+}
+
 int main(int argc, const char **argv) {
     lisp_init();
+    REGISTER_GLOBAL_FUNCTION(cool_func);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "(a b c d e f g h i j k l m)";
+    const char BUF[] = "()";
     read_stream_init(&s, BUF, sizeof(BUF) - 1);
     LispVal *l = read(&s);
-    l = Ffuncall(Qmake_symbol, LISP_LITSTR("a"));
+    Ffuncall(Qcool_func, l);
-    debug_obj_info(stdout, l);
     pop_stack_frame();
     lisp_shutdown();
     return 0;

src/stack.c

@@ -20,6 +20,7 @@ void lisp_init_stack() {
         the_stack.frames->local_refs.blocks[0] =
             lisp_malloc(sizeof(struct LocalReferencesBlock));
     }
+    the_stack.nogc_retval = Qnil;
 }
 
 static ALWAYS_INLINE void init_stack_frame(struct StackFrame *frame,

src/stack.h

@@ -30,6 +30,8 @@ struct LispStack {
     size_t first_clear_local_refs; // index of the first frame that has local
                                    // refs that has not been grown
     struct StackFrame *frames;
+
+    LispVal *nogc_retval;
 };
 
 extern struct LispStack the_stack;