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

Support for catching exceptions and reworked lexical variables

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-19 02:34:38 -07:00
parent 91f2ab8e0a
commit 2b7f9b2fd6
4 changed files with 393 additions and 180 deletions
Download Patch File Download Diff File Expand all files Collapse all files

435
src/lisp.c
View File

@ -170,6 +170,8 @@ DEF_STATIC_SYMBOL(opt, "&opt");
DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest");
DEF_STATIC_SYMBOL(declare, "declare");
DEF_STATIC_SYMBOL(name, "name");
static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod,
LispVal *found_args) {
@ -368,8 +370,8 @@ malformed:
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}
LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
bool is_macro) {
LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv,
LispVal *body, bool is_macro) {
CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
self->is_builtin = false;
self->is_macro = is_macro;
@ -383,6 +385,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
cancel_cleanup(cl);
// do these after the potential throw
self->name = refcount_ref(name);
self->lexenv = refcount_ref(lexenv);
if (STRINGP(HEAD(body))) {
self->doc = refcount_ref(HEAD(body));
@ -679,23 +682,21 @@ size_t list_length(LispVal *obj) {
}
StackFrame *the_stack = NULL;
LispVal *stack_return = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); // DO NOT INTERN
DEF_STATIC_SYMBOL(return_signal, "return-signal"); // DO NOT INTERN
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = (LispSymbol *) name;
frame->hidden = false;
frame->hidden = true;
frame->detail = detail;
frame->lexenv = make_lisp_hashtable(Qnil, Qnil);
frame->lexenv = Qnil;
if (inherit && the_stack) {
puthash(LISPVAL(frame->lexenv), Qparent_lexenv,
LISPVAL(the_stack->lexenv));
frame->lexenv = refcount_ref(the_stack->lexenv);
}
frame->enable_handlers = true;
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_forms = Qnil;
frame->unwind_form = Qnil;
frame->cleanup_handlers = NULL;
frame->next = the_stack;
@ -709,20 +710,21 @@ void stack_leave(void) {
refcount_unref(frame->detail);
refcount_unref(frame->lexenv);
refcount_unref(frame->handlers);
FOREACH(elt, frame->unwind_forms) {
WITH_PUSH_FRAME(Qnil, Qnil, false, {
the_stack->hidden = true;
refcount_unref(Feval(elt)); //
});
}
refcount_unref(frame->unwind_forms);
while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
lisp_free(frame->cleanup_handlers);
frame->cleanup_handlers = next;
}
LispVal *unwind_form = frame->unwind_form;
// steal the ref
frame->unwind_form = Qnil;
lisp_free(frame);
if (!NILP(unwind_form)) {
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
})
}
}
void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
@ -795,15 +797,20 @@ DEFUN(backtrace, "backtrace", (void) ) {
return head;
}
DEFUN(return_from, "return-from", (LispVal * name, LispVal *value)) {
// TODO actually write this
abort();
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg =
const_list(false, 2, Fpair(signal, rest), Fbacktrace());
for (; the_stack; stack_leave()) {
while (the_stack) {
if (!the_stack->enable_handlers) {
continue;
goto up_frame;
}
LispVal *handler =
gethash(LISPVAL(the_stack->handlers), signal, Qunbound);
@ -816,17 +823,31 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(var)) {
// TODO make sure this isn't constant
puthash(the_stack->lexenv, var, error_arg);
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP_DOUBLE_PTR(error_arg, {
refcount_unref(Feval(form)); //
WITH_CLEANUP(error_arg, {
stack_return = Feval(form); //
});
});
longjmp(the_stack->start, 1); // return a nonzero value
longjmp(the_stack->start, STACK_EXIT_THROW);
}
up_frame: {
// steal the form so we can call it after we unwind (in case it
// throws)
LispVal *unwind_form = the_stack->unwind_form;
the_stack->unwind_form = Qnil;
stack_leave();
if (!NILP(unwind_form)) {
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, error_arg);
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
});
cancel_cleanup(cl_handler);
}
}
}
fprintf(stderr,
"ERROR: An exception has propagated past the top of the stack!\n");
@ -841,6 +862,8 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
}
#pragma GCC diagnostic pop
DEF_STATIC_SYMBOL(success, ":success");
DEF_STATIC_SYMBOL(finally, ":finally");
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
@ -852,6 +875,7 @@ DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error");
DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error");
DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error");
DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error");
LispVal *predicate_for_type(LispType type) {
switch (type) {
@ -913,6 +937,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
return true;
case TYPE_FUNCTION: {
LispFunction *fn = obj;
*held = refcount_list_push(*held, fn->name);
*held = refcount_list_push(*held, fn->args);
*held = refcount_list_push(*held, fn->kwargs);
*held = refcount_list_push(*held, fn->oargs);
@ -962,11 +987,11 @@ static void free_obj_callback(void *obj, void *ignored) {
}
lisp_free(tbl->data);
} break;
case TYPE_FUNCTION:
case TYPE_SYMBOL:
case TYPE_PAIR:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_FUNCTION:
// no internal data to free
break;
default:
@ -993,9 +1018,13 @@ void lisp_init(void) {
REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key);
REGISTER_SYMBOL(rest);
REGISTER_SYMBOL(declare);
REGISTER_SYMBOL(name);
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(success);
REGISTER_SYMBOL(finally);
REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error);
@ -1007,11 +1036,10 @@ void lisp_init(void) {
REGISTER_SYMBOL(argument_error);
REGISTER_SYMBOL(invalid_function_error);
REGISTER_SYMBOL(no_applicable_method_error);
REGISTER_SYMBOL(return_frame_error);
refcount_init_static(Qtoplevel);
refcount_init_static(&_Qtoplevel_name);
refcount_init_static(Qparent_lexenv);
refcount_init_static(&_Qparent_lexenv_name);
refcount_init_static(&_Qtoplevel_symnamestr);
REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
REGISTER_FUNCTION(sethead, "(pair newval)",
@ -1106,7 +1134,14 @@ void lisp_init(void) {
"Logical or (with short circuit evaluation.)");
REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ.");
REGISTER_FUNCTION(function_docstr, "(func)",
"Return the documentation string of FUNC.")
"Return the documentation string of FUNC.");
REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", "");
REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", "");
REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", "");
REGISTER_FUNCTION(return_from, "(name &opt value)",
"Return from the function named NAME and return VALUE.");
REGISTER_FUNCTION(intern, "(name)", "");
REGISTER_FUNCTION(condition_case, "(form &rest handlers)", "");
}
void lisp_shutdown(void) {
@ -1118,15 +1153,8 @@ void lisp_shutdown(void) {
refcount_default_context = NULL;
}
static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) {
LispVal *value = gethash(lexenv, key, Qunbound);
if (value != Qunbound) {
return refcount_ref(value);
}
lexenv = gethash(lexenv, Qparent_lexenv, Qunbound);
}
return Qunbound;
static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
return Fplist_get(lexenv, key, Qunbound, Qnil);
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
@ -1140,7 +1168,6 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (sym_val != Qunbound) {
return sym_val;
}
// TODO free args (not just this call, all calls to Fthrow)
Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}
@ -1190,7 +1217,6 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end;
@ -1285,7 +1311,11 @@ too_few:
return NULL;
}
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
LispVal *args_lexenv) {
if (func->is_macro) {
the_stack->lexenv = refcount_ref(args_lexenv);
}
size_t nargs;
LispVal **arg_vec = process_builtin_args(name, func, args, &nargs);
struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs};
@ -1337,7 +1367,8 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
}
static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
LispVal *lexenv) {
LispVal **lexenv) {
LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
enum { REQ, OPT, KEY, REST } mode = REQ;
LispVal *rargs = func->rargs;
LispVal *oargs = func->oargs;
@ -1349,7 +1380,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
mode = OPT;
continue; // skip increment
}
puthash(lexenv, HEAD(rargs), arg);
push_to_lexenv(lexenv, HEAD(rargs), arg);
rargs = TAIL(rargs);
} break;
case OPT: {
@ -1358,9 +1389,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
puthash(lexenv, oad->name, arg);
push_to_lexenv(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qt);
push_to_lexenv(lexenv, oad->pred_var, Qt);
}
oargs = TAIL(oargs);
} break;
@ -1383,9 +1414,10 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto missing_value;
}
LispVal *value = HEAD(args);
puthash(lexenv, oad->name, value);
puthash(added_kwds, oad->name, Qt);
push_to_lexenv(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qt);
push_to_lexenv(lexenv, oad->pred_var, Qt);
}
break;
case REST:
@ -1401,9 +1433,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto too_many_args;
}
}
puthash(lexenv, func->rest_arg, args);
push_to_lexenv(lexenv, func->rest_arg, args);
// done processing
return;
goto done_adding;
}
args = TAIL(args);
}
@ -1415,12 +1447,12 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
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) {
if (NILP(gethash(added_kwds, oad->name, Qnil))) {
LispVal *eval_res = Feval(oad->default_form);
puthash(lexenv, oad->name, eval_res);
push_to_lexenv(lexenv, oad->name, eval_res);
refcount_unref(eval_res);
if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qnil);
push_to_lexenv(lexenv, oad->pred_var, Qnil);
}
}
});
@ -1428,28 +1460,31 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form);
puthash(lexenv, oad->name, default_val);
push_to_lexenv(lexenv, oad->name, default_val);
refcount_unref(default_val);
if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qnil);
push_to_lexenv(lexenv, oad->pred_var, Qnil);
}
}
if (!NILP(func->rest_arg)) {
puthash(lexenv, func->rest_arg, Qnil);
push_to_lexenv(lexenv, func->rest_arg, Qnil);
}
done_adding:
refcount_unref(added_kwds);
return;
// TODO different messages
missing_required:
too_many_args:
missing_value:
unknown_key:
refcount_unref(added_kwds);
Fthrow(Qargument_error, Fpair(fname, Qnil));
}
static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
LispVal *args, LispVal *args_lexenv) {
puthash(the_stack->lexenv, Qparent_lexenv, func->lexenv);
process_lisp_args(name, func, args, the_stack->lexenv);
the_stack->lexenv = refcount_ref(func->lexenv);
process_lisp_args(name, func, args, &the_stack->lexenv);
if (func->is_macro) {
if (!the_stack->next) {
abort();
@ -1492,16 +1527,17 @@ static LispVal *call_function(LispVal *func, LispVal *args,
// builtin macros inherit their parents lexenv
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_PUSH_FRAME(func, args, false, {
if (fobj->is_macro && fobj->is_builtin) {
puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv);
}
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
});
WITH_PUSH_FRAME(
SYMBOLP(func) ? func : Qlambda, args,
false, // make sure the lexenv is nil
{
the_stack->hidden = false;
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args, args_lexenv);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
});
});
cancel_cleanup(cl_handle);
return retval;
@ -1560,7 +1596,6 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
LispVal *copy = Qnil;
LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup(&unref_double_ptr, &copy);
while (!NILP(tortise)) {
if (!LISTP(LISPVAL(tortise))) {
@ -1609,9 +1644,10 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
LispVal *expansion = Qnil;
WITH_CLEANUP_DOUBLE_PTR(fobj, {
WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv);
the_stack->hidden = false;
the_stack->lexenv = refcount_ref(fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
the_stack->lexenv);
&the_stack->lexenv);
expansion = Fprogn(fobj->body);
});
});
@ -1637,9 +1673,13 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
}
}
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
// func should ref its return value
static LispVal *filter_body_tree(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
if (PAIRP(form)) {
LispVal *toplevel_orig = Fmacroexpand_toplevel(form);
LispVal *toplevel_orig = func(form, user_data);
LispVal *toplevel;
WITH_CLEANUP(toplevel_orig, {
toplevel = Fcopy_list(toplevel_orig); //
@ -1648,7 +1688,8 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel);
if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) {
FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail, Fmacroexpand_all(HEAD(tail)));
Fsethead(tail,
filter_body_tree(HEAD(tail), func, user_data));
}
}
cancel_cleanup(cl_handler);
@ -1660,6 +1701,14 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
return Qnil;
}
static LispVal *macroexpand_toplevel_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_toplevel(form);
}
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
return filter_body_tree(form, macroexpand_toplevel_as_callback, NULL);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
LispVal *args = Qnil;
LispVal *end;
@ -1741,7 +1790,6 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
LispVal *res = Feval(cond);
LispVal *retval = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(res)) {
retval = Feval(t);
} else {
@ -1843,16 +1891,14 @@ DEFUN(sub, "-", (LispVal * args)) {
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) {
while (HASHTABLEP(lexenv)) {
if (gethash(lexenv, key, Qunbound) != Qunbound) {
puthash(lexenv, key, newval);
return;
}
lexenv = gethash(lexenv, Qparent_lexenv, Qnil);
LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
if (PAIRP(lexval)) {
Fsethead(TAIL(lexval), newval);
} else {
refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval;
}
refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval;
}
DEFMACRO(setq, "setq", (LispVal * args)) {
@ -1890,28 +1936,127 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
return refcount_ref(new_func);
}
// clang-format off
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
bool success = false;
LispVal *success_form = Qunbound;
LispVal *finally_form = Qunbound;
LispVal *retval = Qnil;
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, {
void *cl_handler = register_cleanup(&unref_double_ptr, &success_form);
void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form);
FOREACH(entry, rest) {
if (HEAD(entry) == Qsuccess) {
if (success_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
success_form = Fpair(Qprogn, TAIL(entry));
} else if (HEAD(entry) == Qfinally) {
if (finally_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
finally_form = Fpair(Qprogn, TAIL(entry));
} else {
LispVal *var = HEAD(HEAD(entry)); LispVal *types = HEAD(TAIL(HEAD(entry)));
if (!PAIRP(types)) {
types = const_list(true, 1, types);
} else {
types = refcount_ref(types);
}
WITH_CLEANUP(types, {
FOREACH(type, types) {
LispVal *handler = push_many(TAIL(entry), 2,
Qprogn, var);
puthash(the_stack->handlers, type, handler);
refcount_unref(handler);
}
});
}
}
cancel_cleanup(cl_handler2);
if (finally_form != Qunbound) {
the_stack->unwind_form = finally_form;
}
retval = Feval(form);
cancel_cleanup(cl_handler);
success = true;
}, {
retval = refcount_ref(stack_return);
});
// call this out here so it is not covered by the handlers
if (success && success_form != Qunbound) {
void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval);
WITH_CLEANUP(success_form, {
refcount_unref(Feval(success_form));
});
cancel_cleanup(cl_handler);
}
return retval;
}
// clang-format on
// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
if (PAIRP(form) && HEAD(form) == Qdeclare) {
FOREACH(elt, TAIL(form)) {
if (name_ptr && PAIRP(elt) && HEAD(elt) == Qname
&& PAIRP(TAIL(elt))) {
*name_ptr = HEAD(TAIL(elt));
}
}
return true;
}
return false;
}
static LispVal *expand_function_body_callback(LispVal *body, void *data) {
return Fmacroexpand_toplevel(body);
}
static inline LispVal *expand_function_body(LispVal *body) {
return filter_body_tree(body, expand_function_body_callback, NULL);
}
DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name);
LispVal *func = make_lisp_function(args, the_stack->lexenv, body, false);
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, false);
});
refcount_unref(Ffset(name, func));
return func;
}
DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name);
LispVal *func = make_lisp_function(args, the_stack->lexenv, body, true);
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, true);
});
refcount_unref(Ffset(name, func));
return func;
}
DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
LispVal *name = Qlambda;
if (parse_function_declare(HEAD(body), &name)) {
body = TAIL(body);
}
LispVal *expanded_body = Fmacroexpand_all(body);
LispVal *retval = Qnil;
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
retval =
make_lisp_function(args, the_stack->lexenv, expanded_body, false);
func = make_lisp_function(name, args, the_stack->lexenv, expanded_body,
false);
});
return retval;
return func;
}
DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
@ -2110,6 +2255,72 @@ DEFUN(function_docstr, "function-docstr", (LispVal * func)) {
return retval;
}
static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) {
if (NILP(pred)) {
return !NILP(Feq(v1, v2));
} else {
LispVal *fcall_args = const_list(true, 2, v1, v2);
bool res = false;
WITH_CLEANUP(fcall_args, {
LispVal *lvpr = Ffuncall(pred, fcall_args); //
res = !NILP(lvpr);
refcount_unref(lvpr);
});
return res;
}
}
DEFUN(plist_get, "plist-get",
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
return refcount_ref(def);
}
return refcount_ref(HEAD(TAIL(cur)));
}
}
return refcount_ref(def);
}
DEFUN(plist_set, "plist-set",
(LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
break;
}
return refcount_ref(HEAD(TAIL(cur)));
}
}
return push_many(plist, 2, value, key);
}
DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *prev = Qnil, *cur = plist; !NILP(cur);
prev = cur, cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(prev)) {
return refcount_ref(TAIL(TAIL(plist)));
} else {
Fsettail(TAIL(prev), TAIL(TAIL(cur)));
}
return Qnil;
}
}
return refcount_ref(plist);
}
DEFUN(plist_assoc, "plist-assoc",
(LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
return cur;
}
}
return Qnil;
}
static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
@ -2158,13 +2369,23 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
}
fputc(']', stream);
} break;
case TYPE_FUNCTION:
case TYPE_FUNCTION: {
LispVal *name = ((LispFunction *) obj)->name;
if (((LispFunction *) obj)->is_builtin) {
fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj);
fprintf(stream, "<builtin ");
} else {
fprintf(stream, "<function at %#jx>", (uintmax_t) obj);
if (name == Qlambda) {
fprintf(stream, "<lambda"); // no space!
name = NULL;
} else {
fprintf(stream, "<function ");
}
}
break;
if (name) {
debug_dump_real(stream, name, false);
}
fprintf(stream, " at %#jx>", (uintmax_t) obj);
} break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) obj;
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
@ -2214,33 +2435,3 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
void debug_print_tree(FILE *stream, void *obj) {
refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
}
void debug_dump_lexenv(FILE *stream, LispVal *lexenv) {
if (!the_stack) {
fprintf(stream, "debug_dump_lexenv: No stack frames...\n");
}
if (!lexenv) {
lexenv = the_stack->lexenv;
}
bool first = true;
while (!NILP(lexenv)) {
if (first) {
fprintf(stream, "Lexical variables (most recent frame first):\n");
} else {
fprintf(stream, "\nNext parent:\n");
}
first = false;
LispVal *next_lexenv = Qnil;
HASHTABLE_FOREACH(var, val, lexenv, {
if (var == Qparent_lexenv) {
next_lexenv = val;
} else {
fprintf(stream, " - ");
debug_dump(stream, var, false);
fprintf(stream, " -> ");
debug_dump(stream, val, true);
}
});
lexenv = next_lexenv;
}
}