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

42
src/kernel.sl
View File

@ -85,23 +85,12 @@
(setq vars (pair (first ent) vars)
vals (pair (second ent) vals))
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda (reverse vars) body)
(apply 'list 'funcall (apply 'list 'lambda
(reverse vars)
'(declare (name nil))
body)
(reverse vals)))))
(defun plist-put (plist key value)
(let ((tail plist))
(while (and tail (tail tail))
(if (eq (head tail) key)
(sethead (tail tail) value))
(setq tail (tail (tail tail))))))
(defun put (symbol key value)
(let ((cur (symbol-plist symbol)))
()))
(defun get (symbol key default)
())
(defun lasttail (list)
"Return the last pair in LIST."
(let (out)
@ -146,23 +135,6 @@
(pair pred (tail cond))))
conds)))))
(defun internal-expand-\` (form &opt (level 0))
(tcase
(())))
(defmacro \` (form)
(internal-expand-\` form))
;; (println (macroexpand-1 '`(,@a)))
(defmacro a (form)
(list 'b (ensure-list form)))
(defmacro b (form)
(list 'c (ensure-list form)))
(defmacro c (form)
(list 'd form))
;; (let ((a '(1 2 3)))
;; (println `(,a)))
(defmacro unwind-protect (form &rest unwind-forms)
(list 'condition-case form
(pair :finally unwind-forms)))

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

95
src/lisp.h
View File

@ -107,6 +107,7 @@ typedef void (*lisp_function_ptr_t)(void);
typedef struct {
LISP_OBJECT_HEADER;
LispVal *name;
LispVal *doc;
LispVal *args;
bool is_builtin;
@ -217,16 +218,16 @@ inline static bool NUMBERP(LispVal *v) {
.length = sizeof(value) - 1, \
.is_static = true, \
}
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.function = Qunbound, \
.value = Qunbound, \
.is_constant = false, \
}; \
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \
DEF_STATIC_STRING(_Q##c_name##_symnamestr, lisp_name); \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.name = &_Q##c_name##_symnamestr, \
.plist = Qnil, \
.function = Qunbound, \
.value = Qunbound, \
.is_constant = false, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name)
#define DECLARE_FUNCTION(c_name, args) \
LispVal *F##c_name args; \
@ -234,12 +235,14 @@ inline static bool NUMBERP(LispVal *v) {
// The args and doc fields are filled when the function is registered
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \
static_kw LispVal *F##c_name c_args; \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \
static LispSymbol _Q##c_name; \
static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \
.is_builtin = true, \
.is_macro = macrop, \
.builtin = (void (*)(void)) & F##c_name, \
.name = LISPVAL(&_Q##c_name), \
.doc = Qnil, \
.args = Qnil, \
.rargs = Qnil, \
@ -250,7 +253,7 @@ inline static bool NUMBERP(LispVal *v) {
}; \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.name = &_Q##c_name##_name, \
.name = &_Q##c_name##_fnnamestr, \
.plist = Qnil, \
.value = Qunbound, \
.function = LISPVAL(&_Q##c_name##_function), \
@ -315,8 +318,8 @@ LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length);
void set_function_args(LispFunction *func, LispVal *args);
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);
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) \
@ -388,6 +391,28 @@ static inline LispVal *make_list(size_t len, LispVal **vals) {
}
return list;
}
static inline LispVal *push_many(LispVal *list, int count, ...) {
LispVal *new_list = list;
bool first = true;
va_list args;
va_start(args, count);
while (count--) {
new_list = Fpair(va_arg(args, LispVal *), new_list);
if (!first) {
refcount_unref(((LispPair *) new_list)->tail);
first = false;
}
}
va_end(args);
return new_list;
}
static inline void push_to_lexenv(LispVal **lexenv, LispVal *key,
LispVal *value) {
LispVal *old = *lexenv;
*lexenv = push_many(*lexenv, 2, value, key);
refcount_unref(old);
}
typedef void (*lisp_cleanup_func_t)(void *);
struct CleanupHandlerEntry {
struct CleanupHandlerEntry *next;
@ -402,15 +427,18 @@ typedef struct StackFrame {
LispVal *lexenv; // symbol -> value
bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_forms;
LispVal *unwind_form;
struct CleanupHandlerEntry *cleanup_handlers;
jmp_buf start;
} StackFrame;
#define STACK_EXIT_NORMAL 0
#define STACK_EXIT_THROW 1
extern StackFrame *the_stack;
extern LispVal *stack_return;
extern LispVal *Qtoplevel;
extern LispVal *Qparent_lexenv;
void stack_enter(LispVal *name, LispVal *detail, bool inherit);
void stack_leave(void);
@ -423,15 +451,26 @@ struct UnrefListData {
void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \
on_return) \
stack_enter(name, detail, inherit); \
{ \
int __with_push_frame_jmpval = setjmp(the_stack->start); \
if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \
body \
} else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \
on_return; \
refcount_unref(stack_return); \
stack_return = NULL; \
} \
stack_leave(); \
}
#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \
stack_enter(name, detail, inherit); \
if (setjmp(the_stack->start) == 0) { \
body \
} \
stack_leave();
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, )
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \
body)
#define WITH_CLEANUP_DOUBLE_PTR(var, body) \
{ \
void *__with_cleanup_cleanup = register_cleanup( \
@ -450,8 +489,11 @@ void cancel_cleanup(void *handle);
}
DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qsuccess;
extern LispVal *Qfinally;
extern LispVal *Qshutdown_signal;
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
@ -463,6 +505,7 @@ extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error;
extern LispVal *Qreturn_frame_error;
LispVal *predicate_for_type(LispType type);
#define CHECK_TYPE(type, val) \
@ -528,6 +571,7 @@ DECLARE_FUNCTION(sub, (LispVal * args));
DECLARE_FUNCTION(setq, (LispVal * args));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest));
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
@ -561,6 +605,12 @@ DECLARE_FUNCTION(and, (LispVal * rest));
DECLARE_FUNCTION(or, (LispVal * rest));
DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(function_docstr, (LispVal * func));
DECLARE_FUNCTION(plist_get,
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred));
DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value,
LispVal *pred));
DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred));
DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred));
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);
@ -570,7 +620,8 @@ extern LispVal *Qopt;
extern LispVal *Qkey;
extern LispVal *Qallow_other_keys;
extern LispVal *Qrest;
extern LispVal *Qreturn_signal;
extern LispVal *Qdeclare;
extern LispVal *Qname;
// some internal functions
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);

1
src/main.c
View File

@ -88,7 +88,6 @@ int main(int argc, const char **argv) {
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", "");
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
LispVal *err_var = INTERN_STATIC("err-var");
puthash(the_stack->handlers, Qt,
// simply call the above function