diff --git a/src/lisp.c b/src/lisp.c index a8bbebd..b1161c3 100644 --- a/src/lisp.c +++ b/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 #include @@ -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 - if (func->args) { - lisp_unref(func->args); - } - if (func->kwargs) { - lisp_unref(func->kwargs); - } + // TODO disallow duplicate args + lisp_unref(func->args); + lisp_unref(func->kwargs); + lisp_unref(func->rargs); + lisp_unref(func->oargs); + 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, - LispVal *args) { - // TODO do this - return Qnil; +static void process_lisp_args(LispFunction *func, LispVal *args, + LispVal *lexenv) { + enum { REQ, OPT, KEY, REST } mode = REQ; + 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: { diff --git a/src/lisp.h b/src/lisp.h index 58d87b6..9828d42 100644 --- a/src/lisp.h +++ b/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); diff --git a/src/main.c b/src/main.c index e8fefb9..4068a9a 100644 --- a/src/main.c +++ b/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)