diff --git a/src/base.c b/src/base.c index 99dce66..1612723 100644 --- a/src/base.c +++ b/src/base.c @@ -78,8 +78,12 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL); obj->name = name; obj->function = Qnil; - obj->value = Qunbound; obj->plist = Qnil; + if (KEYWORDP(obj)) { + obj->value = obj; + } else { + obj->value = Qunbound; + } return obj; } diff --git a/src/base.h b/src/base.h index 752c7b0..a1e36ed 100644 --- a/src/base.h +++ b/src/base.h @@ -164,6 +164,12 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count, } \ struct __ignored +DEFOBJTYPE(String, STRING, STRINGP, { + size_t length; + char *data; + bool owned; +}); + DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, { LispVal *name; // string LispVal *function; @@ -171,6 +177,14 @@ DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, { LispVal *plist; }); +static ALWAYS_INLINE bool KEYWORDP(LispVal *val) { + if (!SYMBOLP(val)) { + return false; + } + LispString *sym = (LispString *) ((LispSymbol *) val)->name; + return sym->length && *sym->data == ':'; +} + DEFOBJTYPE(Vector, VECTOR, VECTORP, { size_t length; LispVal **data; @@ -205,6 +219,18 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { LispVal *Q##cname; \ LispVal *F##cname cargs +#define REGISTER_GLOBAL_SYMBOL(cname) \ + { \ + Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name, \ + internal_Q##cname##_name_len, \ + false, false)); \ + } +#define REGISTER_GLOBAL_FUNCTION(cname) \ + { \ + REGISTER_GLOBAL_SYMBOL(cname); \ + ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ + } + DECLARE_SYMBOL(nil); DECLARE_SYMBOL(t); DECLARE_SYMBOL(unbound); diff --git a/src/function.c b/src/function.c index e206524..a6a4c7f 100644 --- a/src/function.c +++ b/src/function.c @@ -6,6 +6,7 @@ #include #include +#include const char *llps_strerror(LambdaListParseStatus status) { static const char *MSGS[LLPS_N_ERROS] = { @@ -13,8 +14,11 @@ const char *llps_strerror(LambdaListParseStatus status) { [LLPS_DOTTED] = "Dotted list", [LLPS_REPEAT_SECTION] = "Repeated section", [LLPS_REPEAT_NAME] = "Repeated name", - [LLPS_SYNTAX] = "Syntax error", + [LLPS_ORDER] = "Section out of order", [LLPS_BAD_NAME] = "Invalid variable name", + [LLPS_REPEAT_REST] = "Too many rest variables", + [LLPS_AFTER_ALLOW_OTHER_KEYS] = "Variable after &allow-other-keys", + [LLPS_INVALID_OPT_SPEC] = "Invalid optional spec", }; return MSGS[status]; } @@ -28,6 +32,17 @@ static bool is_valid_variable_name(LispVal *val) { return SYMBOLP(val) && !NILP(val) && val != Qt && val != Qunbound; } +static LispVal *intern_as_keyword(LispVal *name) { + assert(SYMBOLP(name)); + LispString *name_str = ((LispSymbol *) name)->name; + char *kw_name = lisp_malloc(name_str->length + 2); + kw_name[0] = ':'; + memcpy(kw_name + 1, name_str->data, name_str->length); + kw_name[name_str->length + 1] = '\0'; + return Fintern( + make_lisp_string(kw_name, name_str->length + 1, true, false)); +} + // on error, put the object that caused the problem in entry static LambdaListParseStatus parse_optional_arg_spec(LispVal **out, LispVal *entry) { @@ -64,7 +79,7 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out, return LLPS_OK; } else { *out = entry; - return LLPS_SYNTAX; + return LLPS_INVALID_OPT_SPEC; } } @@ -75,7 +90,7 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out, return; \ } void parse_lambda_list(LambdaListParseResult *result, LispVal *list) { - enum { REQ = 0, OPT = 1, KEY = 2, REST, MUST_CHANGE } mode = REQ; + enum { REQ = 0, OPT = 1, KEY = 2, REST = 4, MUST_CHANGE } mode = REQ; unsigned int seen = 0; result->err_obj = Qnil; result->status = LLPS_OK; @@ -83,31 +98,39 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *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; + size_t cur_idx = 0; // for keyword args FOREACH_TAIL(list, tail) { if (!LISTP(tail)) { RETURN_ERROR(LLPS_DOTTED, list); + } else if (out->allow_other_keys) { + RETURN_ERROR(LLPS_AFTER_ALLOW_OTHER_KEYS, XCAR(tail)); } LispVal *cur = XCAR(tail); if (cur == Qand_allow_other_keys) { if (out->allow_other_keys) { - RETURN_ERROR(LLPS_REPEAT_SECTION, list); + RETURN_ERROR(LLPS_REPEAT_SECTION, cur); + } else if (!(seen & KEY)) { + RETURN_ERROR(LLPS_ORDER, cur); } 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) + if (seen & REST) { + RETURN_ERROR(LLPS_REPEAT_SECTION, cur) + } else if (seen & KEY) { + RETURN_ERROR(LLPS_ORDER, cur); } + seen |= REST; mode = REST; } else if (cur == Qand_optional) { if (seen & OPT) { - RETURN_ERROR(LLPS_REPEAT_SECTION, list) + RETURN_ERROR(LLPS_REPEAT_SECTION, cur) + } else if (seen & KEY || seen & REST) { + RETURN_ERROR(LLPS_ORDER, cur); } seen |= OPT; mode = OPT; @@ -117,15 +140,15 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) { } seen |= KEY; mode = KEY; - } else if (mode == MUST_CHANGE) { - // &rest without a variable - RETURN_ERROR(LLPS_SYNTAX, list) + out->kw = Fmake_hash_table(Qnil, Qnil); } else if (mode == REST) { - if (!is_valid_variable_name(cur)) { + if (!NILP(out->rest)) { + RETURN_ERROR(LLPS_REPEAT_REST, cur); + } else if (!is_valid_variable_name(cur)) { RETURN_ERROR(LLPS_BAD_NAME, cur) } out->rest = cur; - mode = MUST_CHANGE; + ++cur_idx; } else if (mode == OPT || mode == KEY) { LispVal *entry; LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur); @@ -136,22 +159,20 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) { out->opt = CONS(entry, out->opt); ++out->n_opt; } else { - out->kw = CONS(entry, out->kw); - ++out->n_kw; + Fputhash(out->kw, intern_as_keyword(XCAR(entry)), + CONS(MAKE_FIXNUM(cur_idx), entry)); } + ++cur_idx; } else if (!is_valid_variable_name(cur)) { RETURN_ERROR(LLPS_BAD_NAME, cur); } else { out->req = CONS(cur, out->req); ++out->n_req; + ++cur_idx; } } - 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 @@ -184,13 +205,16 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(), fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args); exit(1); } + obj->args = result.lambda_list; 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); + return !fobj->args.n_opt + && (NILP(fobj->args.kw) || !HASH_TABLE_COUNT(fobj->args.kw)) + && NILP(fobj->args.rest); } static ALWAYS_INLINE LispVal * @@ -209,24 +233,155 @@ call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) { switch (fobj->args.n_req) { case 0: retval = fobj->impl.native.zero(); + break; case 1: retval = fobj->impl.native.one(FIRST(args)); + break; case 2: retval = fobj->impl.native.two(FIRST(args), SECOND(args)); + break; case 3: retval = fobj->impl.native.three(FIRST(args), SECOND(args), THIRD(args)); + break; case 4: retval = fobj->impl.native.four(FIRST(args), SECOND(args), THIRD(args), FOURTH(args)); + break; case 5: retval = fobj->impl.native.five(FIRST(args), SECOND(args), THIRD(args), FOURTH(args), FIFTH(args)); + break; default: abort(); } + the_stack.nogc_retval = retval; + pop_stack_frame(); + return retval; +} + +enum ProcessArgsResult { + PROCESS_ARGS_OK, + PROCESS_ARGS_TOO_FEW, + PROCESS_ARGS_TOO_MANY, + PROCESS_ARGS_NO_KEY_VALUE, + PROCESS_ARGS_BAD_KEY, + PROCESS_ARGS_N_ERRORS, +}; + +static const char *process_args_strerror(enum ProcessArgsResult status) { + static const char *MSGS[PROCESS_ARGS_N_ERRORS] = { + [PROCESS_ARGS_OK] = "No error", + [PROCESS_ARGS_TOO_FEW] = "Not enough arguments", + [PROCESS_ARGS_TOO_MANY] = "Too many arguments", + [PROCESS_ARGS_NO_KEY_VALUE] = "Key without a value", + [PROCESS_ARGS_BAD_KEY] = "Unknown key", + }; + return MSGS[status]; +} + +static ALWAYS_INLINE size_t NATIVE_FUNCTION_TOTAL_ARG_COUNT(LispVal *val) { + assert(FUNCTIONP(val)); + LispFunction *fobj = val; + return fobj->args.n_req + fobj->args.n_opt + !NILP(fobj->args.rest) + + (NILP(fobj->args.kw) ? 0 : HASH_TABLE_COUNT(fobj->args.kw)); +} + +static ALWAYS_INLINE enum ProcessArgsResult +process_complex_native_args(LispFunction *fobj, LispVal *args, + LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS]) { + size_t rem_req = fobj->args.n_req; + size_t rem_opt = fobj->args.n_opt; + size_t idx = 0; + while (rem_req--) { + if (NILP(args)) { + return PROCESS_ARGS_TOO_FEW; + } + out[idx++] = XCAR(args); + args = XCDR(args); + } + while (rem_opt--) { + if (NILP(args)) { + return PROCESS_ARGS_OK; + } + out[idx++] = XCAR(args); + args = XCDR(args); + } + if (!NILP(args) && (NILP(fobj->args.kw)) && NILP(fobj->args.rest)) { + return PROCESS_ARGS_TOO_MANY; + } + if (!NILP(fobj->args.rest)) { + out[idx++] = args; + } + if (NILP(fobj->args.kw)) { // we are not a keyword function + return PROCESS_ARGS_OK; + } + while (!NILP(args)) { + if (NILP(XCDR(args))) { + return PROCESS_ARGS_NO_KEY_VALUE; + } + LispVal *entry = Fgethash(fobj->args.kw, XCAR(args), Qnil); + if (!NILP(entry)) { + fixnum_t idx = XFIXNUM(XCAR(entry)); + if (!out[idx]) { + out[idx] = XCAR(XCDR(args)); + } + } else if (!fobj->args.allow_other_keys) { + return PROCESS_ARGS_BAD_KEY; + } + args = XCDR(XCDR(args)); + } + return PROCESS_ARGS_OK; +} + +static ALWAYS_INLINE LispVal * +call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) { + LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL}; + size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj); + enum ProcessArgsResult res = + process_complex_native_args(fobj, args, arg_arr); + if (res != PROCESS_ARGS_OK) { + // TODO better errors + printf("Bad arguments to builtin \""); + debug_print(stdout, orig_func); + 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 { + add_local_reference(arg_arr[i]); + } + } + LispVal *retval; + switch (count) { + 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(); - // TODO probably need to protect retval from GC here return retval; } @@ -235,7 +390,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, if (SIMPLE_FUNCTION_P(fobj)) { return call_simple_native(orig_func, fobj, args); } - return Qnil; + return call_complex_native(orig_func, fobj, args); } DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", @@ -249,6 +404,9 @@ DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", // TODO error abort(); } + if (!fobj->flags.no_eval_args) { + // TODO evaluate arguments + } switch (fobj->flags.type) { case FUNCTION_NATIVE: return call_native(func, fobj, args); diff --git a/src/function.h b/src/function.h index 71b168b..29e65af 100644 --- a/src/function.h +++ b/src/function.h @@ -12,11 +12,12 @@ DECLARE_SYMBOL(and_allow_other_keys); struct LambdaList { size_t n_req; size_t n_opt; - size_t n_kw; bool allow_other_keys; LispVal *req; // list of symbols LispVal *opt; // list of lists of (name default has-p-name) - LispVal *kw; // ditto opt + LispVal *kw; // hash table mapping name (a keyword) to a list of (index name + // default has-p-name). This is nil if we are not a keyword + // function. LispVal *rest; // symbol (non-nil if we have a rest arg) }; @@ -56,8 +57,11 @@ typedef enum { LLPS_DOTTED, LLPS_REPEAT_SECTION, LLPS_REPEAT_NAME, - LLPS_SYNTAX, + LLPS_ORDER, LLPS_BAD_NAME, + LLPS_REPEAT_REST, + LLPS_AFTER_ALLOW_OTHER_KEYS, + LLPS_INVALID_OPT_SPEC, LLPS_N_ERROS, } LambdaListParseStatus; @@ -84,5 +88,6 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(), internal_F##cname##_docstr_len, false, false)) DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args)); +#define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__))) #endif diff --git a/src/hashtable.h b/src/hashtable.h index 55e1ad1..f6d8e0b 100644 --- a/src/hashtable.h +++ b/src/hashtable.h @@ -23,4 +23,9 @@ DECLARE_FUNCTION(puthash, (LispVal * ht, LispVal *key, LispVal *val)); DECLARE_FUNCTION(remhash, (LispVal * ht, LispVal *key)); DECLARE_FUNCTION(hash_table_count, (LispVal * ht)); +static ALWAYS_INLINE size_t HASH_TABLE_COUNT(LispVal *ht) { + assert(HASH_TABLE_P(ht)); + return ((LispHashTable *) ht)->count; +} + #endif diff --git a/src/init_globals.h b/src/init_globals.h index b5b2b91..e7fd4ad 100644 --- a/src/init_globals.h +++ b/src/init_globals.h @@ -6,18 +6,4 @@ // defined in a generated file void register_globals(void); -#include - -#define REGISTER_GLOBAL_SYMBOL(cname) \ - { \ - Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name, \ - internal_Q##cname##_name_len, \ - false, false)); \ - } -#define REGISTER_GLOBAL_FUNCTION(cname) \ - { \ - REGISTER_GLOBAL_SYMBOL(cname); \ - ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ - } - #endif diff --git a/src/lisp_string.h b/src/lisp_string.h index dccf3c0..a28ef1b 100644 --- a/src/lisp_string.h +++ b/src/lisp_string.h @@ -3,11 +3,7 @@ #include "base.h" -DEFOBJTYPE(String, STRING, STRINGP, { - size_t length; - char *data; - bool owned; -}); +// LispString (the type) is defined in base.h LispVal *make_lisp_string(const char *data, size_t length, bool take, bool copy); diff --git a/src/list.c b/src/list.c index 159696f..20b5c7b 100644 --- a/src/list.c +++ b/src/list.c @@ -18,8 +18,9 @@ intptr_t list_length(LispVal *list) { bool list_length_eq(LispVal *list, intptr_t size) { assert(LISTP(list)); - while (size-- && CONSP(list)) { + while (size && CONSP(list)) { list = XCDR(list); + --size; } return size == 0 && NILP(list); } diff --git a/src/main.c b/src/main.c index d65af14..7413f4c 100644 --- a/src/main.c +++ b/src/main.c @@ -3,15 +3,24 @@ #include +DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)", + "") { + printf("A: "); + debug_obj_info(stdout, a); + printf("B: "); + debug_obj_info(stdout, b); + return Qnil; +} + int main(int argc, const char **argv) { lisp_init(); + REGISTER_GLOBAL_FUNCTION(cool_func); push_stack_frame(Qnil, Qnil, Qnil); ReadStream s; - const char BUF[] = "(a b c d e f g h i j k l m)"; + const char BUF[] = "()"; read_stream_init(&s, BUF, sizeof(BUF) - 1); LispVal *l = read(&s); - l = Ffuncall(Qmake_symbol, LISP_LITSTR("a")); - debug_obj_info(stdout, l); + Ffuncall(Qcool_func, l); pop_stack_frame(); lisp_shutdown(); return 0; diff --git a/src/stack.c b/src/stack.c index fafbc5b..36d02b0 100644 --- a/src/stack.c +++ b/src/stack.c @@ -20,6 +20,7 @@ void lisp_init_stack() { the_stack.frames->local_refs.blocks[0] = lisp_malloc(sizeof(struct LocalReferencesBlock)); } + the_stack.nogc_retval = Qnil; } static ALWAYS_INLINE void init_stack_frame(struct StackFrame *frame, diff --git a/src/stack.h b/src/stack.h index 5073794..62f2984 100644 --- a/src/stack.h +++ b/src/stack.h @@ -30,6 +30,8 @@ struct LispStack { size_t first_clear_local_refs; // index of the first frame that has local // refs that has not been grown struct StackFrame *frames; + + LispVal *nogc_retval; }; extern struct LispStack the_stack;