Basic support for lisp functions

src/lisp.c

@@ -1,6 +1,7 @@
 #include "lisp.h"
 
-#include "read.h"
+// used by static function registering macros
+#include "read.h" // IWYU pragma: keep
 
 #include <ctype.h>
 #include <stdarg.h>
@@ -92,6 +93,9 @@ void _internal_lisp_delete_object(LispVal *val) {
         LispFunction *fn = (LispFunction *) val;
         lisp_unref(fn->doc);
         lisp_unref(fn->args);
+        lisp_unref(fn->rargs);
+        lisp_unref(fn->oargs);
+        lisp_unref(fn->rest_arg);
         lisp_unref(fn->kwargs);
         if (!fn->is_builtin) {
             lisp_unref(fn->body);
@@ -219,23 +223,30 @@ DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
 DEF_STATIC_SYMBOL(rest, "&rest");
 
 void set_function_args(LispFunction *func, LispVal *args) {
-    // in case func is static
+    // TODO disallow duplicate args
-    if (func->args) {
+    lisp_unref(func->args);
-        lisp_unref(func->args);
+    lisp_unref(func->kwargs);
-    }
+    lisp_unref(func->rargs);
-    if (func->kwargs) {
+    lisp_unref(func->oargs);
-        lisp_unref(func->kwargs);
+    lisp_unref(func->rest_arg);
-    }
+
     int mode = 0; // required
     bool has_opt = false; // mode 1
     bool has_key = false; // mode 2
     bool has_rest = false; // mode 3
+
     func->n_req = 0;
+    func->rargs = Qnil;
     func->n_opt = 0;
-    func->has_rest = false;
+    func->oargs = Qnil;
+    func->rest_arg = Qnil;
     size_t n_kw = 0;
     func->kwargs = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
     func->allow_other_keys = false;
+
+    LispVal *rargs_end;
+    LispVal *oargs_end;
+
     FOREACH(arg, args) {
         if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
             goto malformed;
@@ -266,9 +277,25 @@ void set_function_args(LispFunction *func, LispVal *args) {
         } else {
             switch (mode) {
             case 0:
+                if (NILP(func->rargs)) {
+                    func->rargs = Fpair(arg, Qnil);
+                    rargs_end = func->rargs;
+                } else {
+                    LispVal *new_end = Fpair(arg, Qnil);
+                    Fsettail(rargs_end, new_end);
+                    rargs_end = new_end;
+                }
                 ++func->n_req;
                 break;
             case 1:
+                if (NILP(func->oargs)) {
+                    func->oargs = Fpair(arg, Qnil);
+                    oargs_end = func->oargs;
+                } else {
+                    LispVal *new_end = Fpair(arg, Qnil);
+                    Fsettail(oargs_end, new_end);
+                    oargs_end = new_end;
+                }
                 ++func->n_opt;
                 break;
             case 2: {
@@ -280,14 +307,15 @@ void set_function_args(LispFunction *func, LispVal *args) {
                 LispVal *kn =
                     make_lisp_string(kns, sn->length + 1, false, false);
                 lisp_ref(kn);
-                Fputhash(func->kwargs, Fintern(kn), make_lisp_integer(n_kw));
+                Fputhash(func->kwargs, Fintern(kn),
+                         Fpair(make_lisp_integer(n_kw), arg));
                 lisp_unref(kn);
             } break;
             case 3:
-                if (func->has_rest) {
+                if (!NILP(func->rest_arg)) {
                     goto malformed;
                 }
-                func->has_rest = true;
+                func->rest_arg = lisp_ref(arg);
                 mode = -1;
                 break;
             case -1:
@@ -295,6 +323,8 @@ void set_function_args(LispFunction *func, LispVal *args) {
             }
         }
     }
+    lisp_ref(func->rargs);
+    lisp_ref(func->oargs);
     // do this last
     func->args = lisp_ref(args);
     return;
@@ -311,6 +341,9 @@ LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
     self->is_builtin = false;
     self->is_macro = is_macro;
     self->args = Qnil;
+    self->rargs = Qnil;
+    self->oargs = Qnil;
+    self->rest_arg = Qnil;
     self->kwargs = Qnil;
     void *cl = register_cleanup(&free_double_ptr, &self);
     set_function_args(self, args);
@@ -775,7 +808,9 @@ void lisp_init() {
     REGISTER_SYMBOL(allow_other_keys);
     REGISTER_SYMBOL(key);
     REGISTER_SYMBOL(rest);
+    REGISTER_SYMBOL(type_error);
 
+    REGISTER_FUNCTION(throw, "(signal &rest data)", "");
     REGISTER_FUNCTION(pair, "(head tail)",
                       "Return a new pair with HEAD and TAIL.");
     REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR.");
@@ -802,6 +837,11 @@ void lisp_init() {
     REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
     REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
     REGISTER_FUNCTION(fset, "(sym new-func)", "");
+    REGISTER_FUNCTION(defun, "(name args &rest body)",
+                      "Define NAME to be a new function.");
+    REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR");
+    REGISTER_FUNCTION(read, "(source)",
+                      "Read and return the next s-expr from SOURCE.");
 }
 
 void lisp_shutdown() {
@@ -876,7 +916,7 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
                                       size_t *nargs) {
     size_t raw_count =
         (func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count
-         + (func->has_rest));
+         + !NILP(func->rest_arg));
     *nargs = raw_count;
     LispVal **vec = lisp_malloc(sizeof(LispVal *) * raw_count);
     memset(vec, 0, sizeof(LispVal *) * raw_count);
@@ -890,7 +930,7 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
         if (have_count < func->n_req + func->n_opt) {
             vec[have_count++] = lisp_ref(arg);
         } else if (KEYWORDP(arg)
-                   && !NILP(index = Fgethash(func->kwargs, arg, Qnil))
+                   && !NILP(index = Fhead(Fgethash(func->kwargs, arg, Qnil)))
                    && NILP(rest)) {
             LispInteger *n = (LispInteger *) index;
             if (vec[n->value]) {
@@ -903,7 +943,7 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
             vec[n->value] = lisp_ref(Fhead(arg));
         } else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
             goto unknown_key;
-        } else if (!func->has_rest) {
+        } else if (NILP(func->rest_arg)) {
             goto too_many;
         } else if (NILP(rest)) {
             rest = Fpair(arg, Qnil);
@@ -918,7 +958,7 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
     if (have_count < func->n_req) {
         goto too_few;
     }
-    if (func->has_rest) {
+    if (!NILP(func->rest_arg)) {
         vec[raw_count - 1] = lisp_ref(rest);
     }
     for (size_t i = 0; i < raw_count; ++i) {
@@ -994,13 +1034,90 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
     return retval;
 }
 
-static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
+static void process_lisp_args(LispFunction *func, LispVal *args,
-                                   LispVal *args) {
+                              LispVal *lexenv) {
-    // TODO do this
+    enum { REQ, OPT, KEY, REST } mode = REQ;
-    return Qnil;
+    LispVal *rargs = func->rargs;
+    LispVal *oargs = func->oargs;
+    // TODO fix macro to avoid warnings
+    HASHTABLE_FOREACH(arg, info, func->kwargs, {
+        // TODO allow default values
+        Fputhash(lexenv, Fhead(info), Qnil);
+    });
+    while (!NILP(args)) {
+        LispVal *arg = Fhead(args);
+        switch (mode) {
+        case REQ: {
+            if (NILP(rargs)) {
+                mode = OPT;
+                continue; // skip increment
+            }
+            Fputhash(lexenv, Fhead(rargs), arg);
+            rargs = Ftail(rargs);
+        } break;
+        case OPT: {
+            if (NILP(oargs)) {
+                mode = KEY;
+                continue; // skip increment
+            }
+            Fputhash(lexenv, Fhead(oargs), arg);
+            oargs = Ftail(oargs);
+        } break;
+        case KEY:
+            if (!KEYWORDP(arg)) {
+                mode = REST;
+                continue; // skip increment
+            }
+            LispVal *var_name = Fhead(Fgethash(func->kwargs, arg, Qnil));
+            if (NILP(var_name)) {
+                if (!func->allow_other_keys) {
+                    goto unknown_key;
+                }
+                mode = REST;
+                continue; // skip increment
+            }
+            args = Ftail(args);
+            if (NILP(args)) {
+                goto missing_value;
+            }
+            LispVal *value = Fhead(args);
+            Fputhash(lexenv, var_name, value);
+        case REST:
+            if (NILP(func->rest_arg)) {
+                goto too_many_args;
+            }
+            Fputhash(lexenv, func->rest_arg, args);
+            // done processing
+            return;
+        }
+        args = Ftail(args);
+    }
+    if (!NILP(rargs)) {
+        goto missing_required;
+    }
+    FOREACH(arg, oargs) {
+        Fputhash(lexenv, arg, Qnil);
+    }
+    return;
+    // TODO different messages
+missing_required:
+too_many_args:
+missing_value:
+unknown_key:
+    Fthrow(Qargument_error, Qnil);
 }
 
-static void check_args_for_function(LispFunction *fun, LispVal *args) {}
+static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
+                                   LispVal *args) {
+    process_lisp_args(func, args, the_stack->lexenv);
+    // TODO handle macros
+    LispVal *body = Fpair(Qprogn, func->body);
+    LispVal *retval = Qnil;
+    WITH_CLEANUP(body, {
+        retval = Feval(body); //
+    });
+    return retval;
+}
 
 static LispVal *call_function(LispVal *func, LispVal *args,
                               LispVal *args_lexenv, bool eval_args) {
@@ -1023,7 +1140,6 @@ static LispVal *call_function(LispVal *func, LispVal *args,
     WITH_PUSH_FRAME(func, args, fobj->is_macro && fobj->is_builtin, {
         void *cl_handle = register_cleanup(
             (lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
-        check_args_for_function(fobj, args);
         if (fobj->is_builtin) {
             retval = call_builtin(func, fobj, args);
         } else {
@@ -1213,6 +1329,14 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
     return new_func;
 }
 
+DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
+    CHECK_TYPE(TYPE_SYMBOL, name);
+    LispVal *func =
+        make_lisp_function(args, Qnil, the_stack->lexenv, body, false);
+    Ffset(name, func);
+    return func;
+}
+
 static void debug_dump_real(FILE *stream, void *obj, bool first) {
     switch (TYPEOF(obj)) {
     case TYPE_STRING: {

src/lisp.h

@@ -99,10 +99,12 @@ typedef struct {
     bool is_macro;
 
     size_t n_req;
+    LispVal *rargs;
     size_t n_opt;
+    LispVal *oargs;
     LispVal *kwargs; // hash table
     bool allow_other_keys;
-    bool has_rest;
+    LispVal *rest_arg;
     union {
         void *builtin;
         LispVal *body;
@@ -220,6 +222,9 @@ inline static bool NUMBERP(LispVal *v) {
         .builtin = &F##c_name,                                      \
         .doc = Qnil,                                                \
         .args = Qnil,                                               \
+        .rargs = Qnil,                                              \
+        .oargs = Qnil,                                              \
+        .rest_arg = Qnil,                                           \
         .kwargs = Qnil,                                             \
         .lexenv = Qnil,                                             \
     };                                                              \
@@ -490,6 +495,7 @@ DECLARE_FUNCTION(add, (LispVal * n1, LispVal *n2));
 DECLARE_FUNCTION(setq, (LispVal * name, LispVal *value));
 DECLARE_FUNCTION(progn, (LispVal * forms));
 DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
+DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
 
 void debug_dump(FILE *stream, void *obj, bool newline);
 void debug_print_hashtable(FILE *stream, LispVal *table);

src/main.c

@@ -12,6 +12,9 @@ static LispFunction _Ftoplevel_exit_handler_function = {
     .builtin = &Ftoplevel_exit_handler,
     .args = Qnil,
     .kwargs = Qnil,
+    .rargs = Qnil,
+    .oargs = Qnil,
+    .rest_arg = Qnil,
     .lexenv = Qnil,
 };
 #define Ftoplevel_exit_handler_function \
@@ -38,6 +41,9 @@ static LispFunction _Ftoplevel_error_handler_function = {
     .args = Qnil,
     .kwargs = Qnil,
     .lexenv = Qnil,
+    .rargs = Qnil,
+    .oargs = Qnil,
+    .rest_arg = Qnil,
 };
 #define Ftoplevel_error_handler_function \
     LISPVAL(&_Ftoplevel_error_handler_function)