Work on functions

2026-01-29 00:00:05 -08:00
parent 22ffac9321
commit 5029405a70
12 changed files with 292 additions and 123 deletions
@@ -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,
-                                                     LispVal *entry) {
+static LambdaListParseStatus
+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)   \
-    {                            \
-        result->status = err;    \
-        result->err_obj = (obj); \
-        return;                  \
+#define RETURN_ERROR(err, obj)                \
+    {                                         \
+        release_hash_table_no_gc(used_names); \
+        result->status = err;                 \
+        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 bool SIMPLE_FUNCTION_P(LispFunction *fobj) {
-    return !fobj->args.n_opt
-           && (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;
+static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
+    LispVal *start = Qnil;
+    LispVal *end;
    DOLIST(arg, args) {
-        if (fobj->flags.no_eval_args) {
-            arg_arr[acount] = arg;
+        if (NILP(start)) {
+            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;
-    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;
+    return start;
 }

 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 *
-call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
+static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
+                                          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,
-                                          LispFunction *fobj, LispVal *args) {
-    if (SIMPLE_FUNCTION_P(fobj)) {
-        return call_simple_native(orig_func, fobj, args);
+static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
+                                                           LispVal *value) {
+    new_lexical_variable(XCAR(spec), value);
+    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)) {
-        // TODO error
-        abort();
-    }
-    if (!fobj->flags.no_eval_args) {
-        // TODO evaluate arguments
-    }
+    // include symbol here for the error message
+    CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
    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");