Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Builtin function argument parsing

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-01-19 23:29:14 -08:00
parent c63b104bc6
commit 243a012d3e
11 changed files with 243 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/base.c
View File

@ -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;
}

26
src/base.h
View File

@ -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);

204
src/function.c
View File

@ -6,6 +6,7 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
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);

11
src/function.h
View File

@ -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

5
src/hashtable.h
View File

@ -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

14
src/init_globals.h
View File

@ -6,18 +6,4 @@
// defined in a generated file
void register_globals(void);
#include <stdio.h>
#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

6
src/lisp_string.h
View File

@ -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);

3
src/list.c
View File

@ -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);
}

15
src/main.c
View File

@ -3,15 +3,24 @@
#include <stdio.h>
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;

1
src/stack.c
View File

@ -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,

2
src/stack.h
View File

@ -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;