glisp/src/function.c

#include "function.h"

#include "lisp.h"
#include "list.h"
#include "read.h"

#include <stdio.h>
#include <stdlib.h>

const char *llps_strerror(LambdaListParseStatus status) {
    static const char *MSGS[LLPS_N_ERROS] = {
        [LLPS_OK] = "No error",
        [LLPS_DOTTED] = "Dotted list",
        [LLPS_REPEAT_SECTION] = "Repeated section",
        [LLPS_REPEAT_NAME] = "Repeated name",
        [LLPS_SYNTAX] = "Syntax error",
        [LLPS_BAD_NAME] = "Invalid variable name",
    };
    return MSGS[status];
}

DEFINE_SYMBOL(and_optional, "&optional");
DEFINE_SYMBOL(and_rest, "&rest");
DEFINE_SYMBOL(and_key, "&key");
DEFINE_SYMBOL(and_allow_other_keys, "&allow-other-keys");

static bool is_valid_variable_name(LispVal *val) {
    return SYMBOLP(val) && !NILP(val) && val != Qt && val != Qunbound;
}

// on error, put the object that caused the problem in entry
static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
                                                     LispVal *entry) {
    // single symbol
    if (SYMBOLP(entry)) {
        if (!is_valid_variable_name(entry)) {
            *out = entry;
            return LLPS_BAD_NAME;
        }
        *out = LIST(entry, Qnil, Qnil);
        return LLPS_OK;
    } else if (!CONSP(entry)) {
        *out = entry;
        return LLPS_BAD_NAME;
    }
    // list
    LispVal *name = XCAR(entry);
    if (!is_valid_variable_name(name)) {
        *out = name;
        return LLPS_BAD_NAME;
    }
    if (list_length_eq(entry, 1)) {
        *out = LIST(XCAR(entry), Qnil, Qnil);
        return LLPS_OK;
    } else if (list_length_eq(entry, 2)) {
        *out = LIST(name, XCAR(XCDR(entry)), Qnil);
        return LLPS_OK;
    } else if (list_length_eq(entry, 3)) {
        LispVal *pvar = XCAR(XCDR(XCDR(entry)));
        if (!is_valid_variable_name(pvar)) {
            return LLPS_BAD_NAME;
        }
        *out = LIST(XCAR(entry), XCAR(XCDR(entry)), pvar);
        return LLPS_OK;
    } else {
        *out = entry;
        return LLPS_SYNTAX;
    }
}

#define RETURN_ERROR(err, obj)   \
    {                            \
        result->status = err;    \
        result->err_obj = (obj); \
        return;                  \
    }
void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
    enum { REQ = 0, OPT = 1, KEY = 2, REST, MUST_CHANGE } mode = REQ;
    unsigned int seen = 0;
    result->err_obj = Qnil;
    result->status = LLPS_OK;
    struct LambdaList *out = &result->lambda_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;
    FOREACH_TAIL(list, tail) {
        if (!LISTP(tail)) {
            RETURN_ERROR(LLPS_DOTTED, list);
        }
        LispVal *cur = XCAR(tail);
        if (cur == Qand_allow_other_keys) {
            if (out->allow_other_keys) {
                RETURN_ERROR(LLPS_REPEAT_SECTION, list);
            }
            out->allow_other_keys = true;
            mode = MUST_CHANGE;
        } else if (cur == Qand_rest) {
            if (!NILP(out->rest) || mode == REST) {
                RETURN_ERROR(LLPS_REPEAT_SECTION, list)
            }
            mode = REST;
        } else if (cur == Qand_optional) {
            if (seen & OPT) {
                RETURN_ERROR(LLPS_REPEAT_SECTION, list)
            }
            seen |= OPT;
            mode = OPT;
        } else if (cur == Qand_key) {
            if (seen & KEY) {
                RETURN_ERROR(LLPS_REPEAT_SECTION, list)
            }
            seen |= KEY;
            mode = KEY;
        } else if (mode == MUST_CHANGE) {
            // &rest without a variable
            RETURN_ERROR(LLPS_SYNTAX, list)
        } else if (mode == REST) {
            if (!is_valid_variable_name(cur)) {
                RETURN_ERROR(LLPS_BAD_NAME, cur)
            }
            out->rest = cur;
            mode = MUST_CHANGE;
        } else if (mode == OPT || mode == KEY) {
            LispVal *entry;
            LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur);
            if (status != LLPS_OK) {
                RETURN_ERROR(status, entry)
            }
            if (mode == OPT) {
                out->opt = CONS(entry, out->opt);
                ++out->n_opt;
            } else {
                out->kw = CONS(entry, out->kw);
                ++out->n_kw;
            }
        } else if (!is_valid_variable_name(cur)) {
            RETURN_ERROR(LLPS_BAD_NAME, cur);
        } else {
            out->req = CONS(cur, out->req);
            ++out->n_req;
        }
    }
    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

LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
                               const char *lisp_args, size_t args_len,
                               LispVal *docstr) {
    LispFunction *obj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
    obj->name = name;
    obj->flags.type = FUNCTION_NATIVE;
    obj->flags.no_eval_args = false;
    obj->docstr = docstr;
    obj->impl.native.zero = cfunc;
    ReadStream stream;
    read_stream_init(&stream, lisp_args, args_len);
    LispVal *args_form = read(&stream);
    if (!args_form) {
        fprintf(stderr, "Builtin function lambda list had a syntax error\n");
        fprintf(stderr, "Name: ");
        debug_print(stderr, name);
        fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args);
        exit(1);
    }
    LambdaListParseResult result;
    parse_lambda_list(&result, args_form);
    if (result.status != LLPS_OK) {
        fprintf(stderr, "Error parsing builtin lambda list: %s\n",
                llps_strerror(result.status));
        fprintf(stderr, "Name: ");
        debug_print(stderr, name);
        fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args);
        exit(1);
    }
    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);
}

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();
    }
    FOREACH(args, arg) {
        add_local_reference(arg);
    }
    LispVal *retval;
    switch (fobj->args.n_req) {
    case 0:
        retval = fobj->impl.native.zero();
    case 1:
        retval = fobj->impl.native.one(FIRST(args));
    case 2:
        retval = fobj->impl.native.two(FIRST(args), SECOND(args));
    case 3:
        retval =
            fobj->impl.native.three(FIRST(args), SECOND(args), THIRD(args));
    case 4:
        retval = fobj->impl.native.four(FIRST(args), SECOND(args), THIRD(args),
                                        FOURTH(args));
    case 5:
        retval = fobj->impl.native.five(FIRST(args), SECOND(args), THIRD(args),
                                        FOURTH(args), FIFTH(args));
    default:
        abort();
    }
    pop_stack_frame();
    // TODO probably need to protect retval from GC here
    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);
    }
    return Qnil;
}

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();
    }
    switch (fobj->flags.type) {
    case FUNCTION_NATIVE:
        return call_native(func, fobj, args);
    case FUNCTION_INTERP:
    case FUNCTION_BYTECOMP:
    default:
        // TODO implement
        abort();
    }
}