Global generation

src/function.c

@@ -1 +1,184 @@
 #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;
+        }
+    }
+    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->is_native = true;
+    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;
+}