Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow default values for optional argumnts

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-07-04 02:18:40 +09:00
parent 625b8238e6
commit 2d4b963199
3 changed files with 236 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

252
src/lisp.c
View File

@ -17,8 +17,17 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
[TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
};
void free_opt_arg_desc(void *obj) {
struct OptArgDesc *oad = obj;
lisp_unref(oad->name);
lisp_unref(oad->default_form);
lisp_unref(oad->pred_var);
lisp_free(oad);
}
DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
.type = TYPE_SYMBOL,
@ -120,6 +129,13 @@ void _internal_lisp_delete_object(LispVal *val) {
lisp_unref(tbl->hash_fn);
lisp_free(val);
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = (LispUserPointer *) val;
if (ptr->free_func) {
ptr->free_func(ptr->data);
}
lisp_free(val);
} break;
default:
abort();
};
@ -222,25 +238,68 @@ DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest");
static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod,
LispVal *found_args) {
aod->name = Qnil;
aod->default_form = Qnil;
aod->pred_var = Qnil;
if (TYPEOF(ent) == TYPE_SYMBOL) {
if (VALUE_CONSTANTP(ent)) {
return false;
} else if (!NILP(Fgethash(found_args, ent, Qnil))) {
return false;
}
aod->name = lisp_ref(ent);
aod->pred_var = Qnil;
aod->default_form = Qnil;
return true;
} else if (LISTP(ent) && SYMBOLP(Fhead(ent)) && !VALUE_CONSTANTP(Fhead(ent))
&& LISTP(Ftail(ent))) {
LispVal *end = Ftail(Ftail(ent));
if (!LISTP(end) || (!SYMBOLP(Fhead(end)) && !NILP(Fhead(end)))
|| (!NILP(Fhead(end)) && VALUE_CONSTANTP(Fhead(end)))) {
return false;
} else if (!NILP(Fgethash(found_args, Fhead(ent), Qnil))) {
return false;
} else if (!NILP(end)
&& (!NILP(Fgethash(found_args, Fhead(end), Qnil))
|| VALUE_CONSTANTP(Fhead(end))
|| Fhead(end) == Fhead(ent))) {
return false;
}
aod->name = lisp_ref(Fhead(ent));
aod->default_form = lisp_ref(Fhead(Ftail(ent)));
aod->pred_var = lisp_ref(Fhead(end));
return true;
}
return false;
}
void set_function_args(LispFunction *func, LispVal *args) {
// TODO disallow duplicate args
lisp_unref(func->args);
lisp_unref(func->kwargs);
lisp_unref(func->rargs);
lisp_unref(func->oargs);
lisp_unref(func->rest_arg);
int mode = 0; // required
bool has_opt = false; // mode 1
bool has_key = false; // mode 2
bool has_rest = false; // mode 3
LispVal *found_args = make_lisp_hashtable(Qnil, Qnil);
enum {
REQ,
OPT,
KEY,
REST,
MUST_CHANGE,
} mode = REQ;
bool has_opt = false;
bool has_key = false;
bool has_rest = false;
func->n_req = 0;
func->rargs = Qnil;
func->n_opt = 0;
func->oargs = Qnil;
func->rest_arg = Qnil;
size_t n_kw = 0;
func->kwargs = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
func->allow_other_keys = false;
@ -248,35 +307,37 @@ void set_function_args(LispFunction *func, LispVal *args) {
LispVal *oargs_end;
FOREACH(arg, args) {
if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
goto malformed;
} else if (arg == Qopt) {
if (has_opt || mode == 3) {
if (arg == Qopt) {
if (has_opt || mode == REST) {
goto malformed;
}
has_opt = true;
mode = 1;
mode = OPT;
} else if (arg == Qkey) {
if (has_key || mode == 3) {
if (has_key || mode == REST) {
goto malformed;
}
has_key = true;
mode = 2;
mode = KEY;
} else if (arg == Qrest) {
if (has_rest) {
goto malformed;
}
has_rest = true;
mode = 3;
mode = REST;
} else if (arg == Qallow_other_keys) {
if (func->allow_other_keys || mode != 2) {
if (func->allow_other_keys || mode != KEY) {
goto malformed;
}
func->allow_other_keys = true;
mode = -1;
mode = MUST_CHANGE;
} else {
switch (mode) {
case 0:
case REQ:
if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)
|| !NILP(Fgethash(found_args, arg, Qnil))) {
goto malformed;
}
if (NILP(func->rargs)) {
func->rargs = Fpair(arg, Qnil);
rargs_end = func->rargs;
@ -285,21 +346,46 @@ void set_function_args(LispFunction *func, LispVal *args) {
Fsettail(rargs_end, new_end);
rargs_end = new_end;
}
Fputhash(found_args, arg, Qt);
++func->n_req;
break;
case 1:
case OPT: {
LispVal *desc =
ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
USERPTR(struct OptArgDesc, desc)->index = 0;
if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
found_args)) {
lisp_unref(desc);
goto malformed;
}
if (NILP(func->oargs)) {
func->oargs = Fpair(arg, Qnil);
func->oargs = Fpair(desc, Qnil);
oargs_end = func->oargs;
} else {
LispVal *new_end = Fpair(arg, Qnil);
LispVal *new_end = Fpair(desc, Qnil);
Fsettail(oargs_end, new_end);
oargs_end = new_end;
}
Fputhash(found_args, USERPTR(struct OptArgDesc, desc)->name,
Qt);
if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
Fputhash(found_args,
USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
}
++func->n_opt;
break;
case 2: {
LispString *sn = ((LispSymbol *) arg)->name;
} break;
case KEY: {
LispVal *desc =
ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
found_args)) {
lisp_unref(desc);
goto malformed;
}
USERPTR(struct OptArgDesc, desc)->index = 0;
LispString *sn =
((LispSymbol *) USERPTR(struct OptArgDesc, desc)->name)
->name;
char kns[sn->length + 2];
kns[0] = ':';
memcpy(kns + 1, sn->data, sn->length);
@ -307,29 +393,43 @@ void set_function_args(LispFunction *func, LispVal *args) {
LispVal *kn =
make_lisp_string(kns, sn->length + 1, false, false);
lisp_ref(kn);
Fputhash(func->kwargs, Fintern(kn),
Fpair(make_lisp_integer(n_kw), arg));
Fputhash(func->kwargs, Fintern(kn), desc);
lisp_unref(kn);
Fputhash(found_args, USERPTR(struct OptArgDesc, desc)->name,
Qt);
if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
Fputhash(found_args,
USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
}
} break;
case 3:
case REST:
if (!NILP(func->rest_arg)) {
goto malformed;
} else if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
goto malformed;
} else if (!NILP(Fgethash(found_args, arg, Qnil))) {
goto malformed;
}
func->rest_arg = lisp_ref(arg);
mode = -1;
mode = MUST_CHANGE;
break;
case -1:
case MUST_CHANGE:
goto malformed;
}
}
}
lisp_ref(func->rargs);
lisp_ref(func->oargs);
lisp_unref(found_args);
// do this last
func->args = lisp_ref(args);
return;
malformed:
lisp_unref(func->rargs);
lisp_unref(func->oargs);
lisp_unref(func->rest_arg);
lisp_unref(func->kwargs);
lisp_unref(found_args);
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}
@ -370,6 +470,15 @@ LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
return LISPVAL(self);
}
LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
LispUserPointer *self = lisp_malloc(sizeof(LispUserPointer));
self->type = TYPE_USER_POINTER;
self->ref_count = 0;
self->data = data;
self->free_func = free_func;
return LISPVAL(self);
}
DEFUN(type_of, "type-of", (LispVal * obj)) {
if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
return Qnil;
@ -923,24 +1032,24 @@ static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
LispVal *rest = Qnil;
LispVal *rest_end;
size_t have_count = 0;
LispVal *index;
LispVal *opt_desc;
LispVal *arg = Qnil; // last arg processed
while (!NILP(args)) {
arg = Fhead(args);
if (have_count < func->n_req + func->n_opt) {
vec[have_count++] = lisp_ref(arg);
} else if (KEYWORDP(arg)
&& !NILP(index = Fhead(Fgethash(func->kwargs, arg, Qnil)))
&& !NILP(opt_desc = Fhead(Fgethash(func->kwargs, arg, Qnil)))
&& NILP(rest)) {
LispInteger *n = (LispInteger *) index;
if (vec[n->value]) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, opt_desc);
if (vec[oad->index]) {
goto multikey;
}
args = Ftail(args);
if (NILP(args)) {
goto key_no_val;
}
vec[n->value] = lisp_ref(Fhead(arg));
vec[oad->index] = lisp_ref(Fhead(arg));
} else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
goto unknown_key;
} else if (NILP(func->rest_arg)) {
@ -1039,11 +1148,6 @@ static void process_lisp_args(LispFunction *func, LispVal *args,
enum { REQ, OPT, KEY, REST } mode = REQ;
LispVal *rargs = func->rargs;
LispVal *oargs = func->oargs;
// TODO fix macro to avoid warnings
HASHTABLE_FOREACH(arg, info, func->kwargs, {
// TODO allow default values
Fputhash(lexenv, Fhead(info), Qnil);
});
while (!NILP(args)) {
LispVal *arg = Fhead(args);
switch (mode) {
@ -1060,7 +1164,11 @@ static void process_lisp_args(LispFunction *func, LispVal *args,
mode = KEY;
continue; // skip increment
}
Fputhash(lexenv, Fhead(oargs), arg);
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, Fhead(oargs));
Fputhash(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
Fputhash(lexenv, oad->pred_var, Qt);
}
oargs = Ftail(oargs);
} break;
case KEY:
@ -1068,23 +1176,37 @@ static void process_lisp_args(LispFunction *func, LispVal *args,
mode = REST;
continue; // skip increment
}
LispVal *var_name = Fhead(Fgethash(func->kwargs, arg, Qnil));
if (NILP(var_name)) {
LispVal *desc_lv = Fgethash(func->kwargs, arg, Qnil);
if (NILP(desc_lv)) {
if (!func->allow_other_keys) {
goto unknown_key;
}
mode = REST;
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
args = Ftail(args);
if (NILP(args)) {
goto missing_value;
}
LispVal *value = Fhead(args);
Fputhash(lexenv, var_name, value);
Fputhash(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
Fputhash(lexenv, oad->pred_var, Qt);
}
break;
case REST:
if (NILP(func->rest_arg)) {
goto too_many_args;
if (KEYWORDP(arg)) {
args = Ftail(args);
if (NILP(args)) {
goto missing_value;
}
args = Ftail(args);
continue; // skip increment
} else {
goto too_many_args;
}
}
Fputhash(lexenv, func->rest_arg, args);
// done processing
@ -1095,8 +1217,25 @@ static void process_lisp_args(LispFunction *func, LispVal *args,
if (!NILP(rargs)) {
goto missing_required;
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-variable"
HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
// only check the current function's lexenv and not its parents'
if (Fgethash(lexenv, oad->name, Qunbound) == Qunbound) {
Fputhash(lexenv, oad->name, Feval(oad->default_form));
if (!NILP(oad->pred_var)) {
Fputhash(lexenv, oad->pred_var, Qnil);
}
}
});
#pragma GCC diagnostic pop
FOREACH(arg, oargs) {
Fputhash(lexenv, arg, Qnil);
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
Fputhash(lexenv, oad->name, Feval(oad->default_form));
if (!NILP(oad->pred_var)) {
Fputhash(lexenv, oad->pred_var, Qnil);
}
}
return;
// TODO different messages
@ -1109,14 +1248,10 @@ unknown_key:
static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
LispVal *args) {
Fputhash(the_stack->lexenv, Qparent_lexenv, func->lexenv);
process_lisp_args(func, args, the_stack->lexenv);
// TODO handle macros
LispVal *body = Fpair(Qprogn, func->body);
LispVal *retval = Qnil;
WITH_CLEANUP(body, {
retval = Feval(body); //
});
return retval;
return Fprogn(func->body);
}
static LispVal *call_function(LispVal *func, LispVal *args,
@ -1158,10 +1293,15 @@ DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_HASHTABLE:
case TYPE_USER_POINTER:
// the above all are self-evaluating
return form;
case TYPE_SYMBOL:
return symbol_value_in_lexenv(lexenv, form);
if (KEYWORDP(form)) {
return form;
} else {
return symbol_value_in_lexenv(lexenv, form);
}
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) form;
LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length);
@ -1267,10 +1407,7 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
if (!NILP(res)) {
retval = Feval(t);
} else {
LispVal *body = Fpair(Qprogn, nil);
WITH_CLEANUP(body, {
retval = Feval(body); //
});
retval = Fprogn(nil);
}
});
return retval;
@ -1397,6 +1534,11 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
tbl->table_size, tbl->count, (uintmax_t) obj);
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = (LispUserPointer *) obj;
fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
(uintmax_t) ptr->data, (uintmax_t) obj);
} break;
default:
fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);

48
src/lisp.h
View File

@ -29,6 +29,7 @@ typedef enum {
TYPE_VECTOR,
TYPE_FUNCTION,
TYPE_HASHTABLE,
TYPE_USER_POINTER,
N_LISP_TYPES,
} LispType;
@ -90,6 +91,15 @@ typedef struct {
size_t length;
} LispVector;
struct OptArgDesc {
size_t index; // only for keywords
LispVal *name;
LispVal *default_form;
LispVal *pred_var;
};
void free_opt_arg_desc(void *obj);
typedef struct {
LISP_OBJECT_HEADER;
@ -135,6 +145,14 @@ typedef struct {
LispVal *hash_fn;
} LispHashtable;
typedef struct {
LISP_OBJECT_HEADER;
void *data;
void (*free_func)(void *);
} LispUserPointer;
#define USERPTR(type, obj) ((type *) ((LispUserPointer *) (obj))->data)
// #######################
// # nil, unbound, and t #
// #######################
@ -159,15 +177,16 @@ extern LispSymbol _Qt;
// only use on symbols!
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
#define NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
#define SYMBOLP(v) (TYPEOF(v) == TYPE_SYMBOL)
#define PAIRP(v) (TYPEOF(v) == TYPE_PAIR)
#define INTEGERP(v) (TYPEOF(v) == TYPE_INTEGER)
#define FLOATP(v) (TYPEOF(v) == TYPE_FLOAT)
#define VECTORP(v) (TYPEOF(v) == TYPE_VECTOR)
#define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION)
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
#define NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
#define SYMBOLP(v) (TYPEOF(v) == TYPE_SYMBOL)
#define PAIRP(v) (TYPEOF(v) == TYPE_PAIR)
#define INTEGERP(v) (TYPEOF(v) == TYPE_INTEGER)
#define FLOATP(v) (TYPEOF(v) == TYPE_FLOAT)
#define VECTORP(v) (TYPEOF(v) == TYPE_VECTOR)
#define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION)
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
#define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER)
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
@ -328,6 +347,9 @@ void set_function_args(LispFunction *func, LispVal *args);
LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
LispVal *body, bool is_macro);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
LispVal *make_user_pointer(void *data, void (*free_func)(void *));
#define ALLOC_USERPTR(type, free_func) \
(make_user_pointer(lisp_malloc(sizeof(type)), &free_func))
// ########################
// # Utility and internal #
@ -346,7 +368,13 @@ DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
DECLARE_FUNCTION(hash_table_count, (LispVal * table));
LispVal *intern(const char *name, size_t length, bool take);
DECLARE_FUNCTION(intern, (LispVal * name));
#define INTERN_STATIC(name) (Fintern(STATIC_STRING(name)))
static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) {
LispVal *kn = lisp_ref(make_lisp_string(name, len, true, true));
LispVal *retval = Fintern(kn);
lisp_unref(kn);
return retval;
}
#define INTERN_STATIC(name) (_internal_INTERN_STATIC((name), sizeof(name) - 1))
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));

1
src/read.c
View File

@ -241,6 +241,7 @@ static int parse_base(size_t left, const char *c) {
static LispVal *read_symbol(struct ReadState *state) {
const char *start = state->head;
// TODO allow escaping characters
while (!is_symbol_end(peekc(state))) {
popc(state);
}