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

Get returns working

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-19 14:41:32 -07:00
parent 2b7f9b2fd6
commit 342bdfb169
4 changed files with 175 additions and 77 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/kernel.sl
View File

@ -138,3 +138,8 @@
(defmacro unwind-protect (form &rest unwind-forms)
(list 'condition-case form
(pair :finally unwind-forms)))
(defun test ()
(return-from test 10))
(println (test))

167
src/lisp.c
View File

@ -370,8 +370,8 @@ malformed:
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}
LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv,
LispVal *body, bool is_macro) {
LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
LispVal *lexenv, LispVal *body, bool is_macro) {
CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
self->is_builtin = false;
self->is_macro = is_macro;
@ -386,6 +386,7 @@ LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv,
// do these after the potential throw
self->name = refcount_ref(name);
self->return_tag = refcount_ref(return_tag);
self->lexenv = refcount_ref(lexenv);
if (STRINGP(HEAD(body))) {
self->doc = refcount_ref(HEAD(body));
@ -687,7 +688,8 @@ DEF_STATIC_SYMBOL(toplevel, "toplevel");
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = (LispSymbol *) name;
frame->name = name;
frame->return_tag = Qnil;
frame->hidden = true;
frame->detail = detail;
frame->lexenv = Qnil;
@ -707,6 +709,7 @@ void stack_leave(void) {
StackFrame *frame = the_stack;
the_stack = the_stack->next;
refcount_unref(frame->name);
refcount_unref(frame->return_tag);
refcount_unref(frame->detail);
refcount_unref(frame->lexenv);
refcount_unref(frame->handlers);
@ -797,9 +800,18 @@ DEFUN(backtrace, "backtrace", (void) ) {
return head;
}
DEFUN(return_from, "return-from", (LispVal * name, LispVal *value)) {
// TODO actually write this
abort();
DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) {
Fthrow(Qreturn_frame_error, const_list(true, 2, name, value));
}
STATIC_DEFMACRO(internal_real_return, "internal-real-return",
(LispVal * name, LispVal *tag, LispVal *value)) {
for (StackFrame *cur = the_stack; cur; cur = cur->next) {
if (!NILP(cur->return_tag) && cur->return_tag == tag) {
Fthrow(cur->return_tag, const_list(true, 1, value));
}
}
Fthrow(Qreturn_frame_error, const_list(true, 2, name, value));
}
#pragma GCC diagnostic push
@ -938,6 +950,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
case TYPE_FUNCTION: {
LispFunction *fn = obj;
*held = refcount_list_push(*held, fn->name);
*held = refcount_list_push(*held, fn->return_tag);
*held = refcount_list_push(*held, fn->args);
*held = refcount_list_push(*held, fn->kwargs);
*held = refcount_list_push(*held, fn->oargs);
@ -1000,6 +1013,8 @@ static void free_obj_callback(void *obj, void *ignored) {
lisp_free(obj);
}
static DECLARE_FUNCTION(set_for_return, (LispVal * entry, LispVal *dest));
void lisp_init(void) {
RefcountContext *ctx = refcount_make_context(
offsetof(LispVal, refcount), Qnil, held_refs_callback,
@ -1038,8 +1053,10 @@ void lisp_init(void) {
REGISTER_SYMBOL(no_applicable_method_error);
REGISTER_SYMBOL(return_frame_error);
refcount_init_static(Qtoplevel);
refcount_init_static(&_Qtoplevel_symnamestr);
// some stuff that musn't be user accesable
REGISTER_SYMBOL_NOINTERN(toplevel);
REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", "");
REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", "");
REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
REGISTER_FUNCTION(sethead, "(pair newval)",
@ -1313,6 +1330,7 @@ too_few:
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
LispVal *args_lexenv) {
// builtin macros inherit their parents lexenv
if (func->is_macro) {
the_stack->lexenv = refcount_ref(args_lexenv);
}
@ -1501,6 +1519,23 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
}
}
STATIC_DEFUN(set_for_return, "set-for-return",
(LispVal * entry, LispVal *dest)) {
LispVal *retval = HEAD(TAIL(HEAD(entry)));
Fsethead(dest, retval);
return Qnil;
}
static inline void setup_return_handler(LispVal *tag, LispVal *dest) {
LispVal *err_var = INTERN_STATIC("e");
LispVal *quoted_dest = const_list(false, 2, Qquote, dest);
LispVal *handler =
const_list(true, 4, err_var, Qset_for_return, err_var, quoted_dest);
refcount_unref(quoted_dest);
puthash(the_stack->handlers, tag, handler);
refcount_unref(handler);
}
static LispVal *call_function(LispVal *func, LispVal *args,
LispVal *args_lexenv, bool eval_args,
bool allow_macro) {
@ -1524,21 +1559,32 @@ static LispVal *call_function(LispVal *func, LispVal *args,
args = eval_function_args(args, args_lexenv);
}
LispVal *retval = Qnil;
// builtin macros inherit their parents lexenv
LispVal *return_ptr = Fpair(Qnil, Qnil);
void *return_cl_handle =
register_cleanup(refcount_unref_as_callback, return_ptr);
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_PUSH_FRAME(
SYMBOLP(func) ? func : Qlambda, args,
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
refcount_ref(fobj->name), refcount_ref(args),
false, // make sure the lexenv is nil
{
the_stack->hidden = false;
if (!NILP(fobj->return_tag)) {
the_stack->return_tag = refcount_ref(fobj->return_tag);
setup_return_handler(fobj->return_tag, return_ptr);
}
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args, args_lexenv);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
},
{
retval = refcount_ref(HEAD(return_ptr)); //
});
});
cancel_cleanup(return_cl_handle);
refcount_unref(return_ptr);
cancel_cleanup(cl_handle);
return retval;
}
@ -1674,12 +1720,12 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
}
// func should ref its return value
static LispVal *filter_body_tree(LispVal *form,
static LispVal *filter_body_form(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
if (PAIRP(form)) {
LispVal *toplevel_orig = func(form, user_data);
if (PAIRP(toplevel_orig)) {
LispVal *toplevel;
WITH_CLEANUP(toplevel_orig, {
toplevel = Fcopy_list(toplevel_orig); //
@ -1689,24 +1735,46 @@ static LispVal *filter_body_tree(LispVal *form,
if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) {
FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail,
filter_body_tree(HEAD(tail), func, user_data));
filter_body_form(HEAD(tail), func, user_data));
}
}
cancel_cleanup(cl_handler);
});
return toplevel;
} else {
return refcount_ref(form);
return toplevel_orig;
}
return Qnil;
}
static LispVal *filter_body_tree(LispVal *body,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
LispVal *start = Qnil;
LispVal *end;
FOREACH(form, body) {
LispVal *filtered = filter_body_form(form, func, user_data);
if (NILP(start)) {
start = Fpair(filtered, Qnil);
end = start;
} else {
LispVal *new_end = Fpair(filtered, Qnil);
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
refcount_unref(filtered);
}
return start;
}
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);
return filter_body_form(form, macroexpand_toplevel_as_callback, NULL);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
@ -2009,12 +2077,45 @@ static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
return false;
}
struct NameAndReturnTag {
LispVal *name;
LispVal *return_tag;
};
static LispVal *expand_function_body_callback(LispVal *body, void *data) {
return Fmacroexpand_toplevel(body);
struct NameAndReturnTag *name_and_return_tag = data;
LispVal *expansion = Fmacroexpand_toplevel(body);
// this mess checks that the call is exactly one of
// - (return-from 'symbol)
// - (return-from 'symbol val)
if (PAIRP(expansion) && HEAD(expansion) == Qreturn_from
&& PAIRP(TAIL(expansion)) && LISTP(TAIL(TAIL(expansion)))
&& NILP(TAIL(TAIL(TAIL(expansion)))) && SYMBOLP(HEAD(TAIL(expansion)))
&& HEAD(TAIL(expansion)) == name_and_return_tag->name) {
LispVal *retval = Qnil;
if (!NILP(TAIL(TAIL(expansion)))) {
retval = refcount_ref(HEAD(TAIL(TAIL(expansion))));
}
refcount_unref(expansion);
return const_list(false, 4, Qinternal_real_return,
refcount_ref(name_and_return_tag->name),
refcount_ref(name_and_return_tag->return_tag),
retval);
} else if (PAIRP(expansion) && HEAD(expansion) == Qinternal_real_return
&& list_length(expansion) == 4
&& HEAD(TAIL(expansion)) == name_and_return_tag->name
&& HEAD(TAIL(TAIL(expansion)))
!= name_and_return_tag->return_tag) {
Fsethead(TAIL(TAIL(expansion)), name_and_return_tag->return_tag);
}
return expansion;
}
static inline LispVal *expand_function_body(LispVal *body) {
return filter_body_tree(body, expand_function_body_callback, NULL);
static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag,
LispVal *body) {
return filter_body_tree(
body, expand_function_body_callback,
&(struct NameAndReturnTag) {.name = name, .return_tag = return_tag});
}
DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
@ -2022,10 +2123,13 @@ DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *expanded_body = expand_function_body(name, return_tag, body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, false);
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, false);
});
refcount_unref(Ffset(name, func));
return func;
@ -2036,25 +2140,36 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *expanded_body = expand_function_body(name, return_tag, body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, true);
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, true);
});
refcount_unref(Ffset(name, func));
return func;
}
DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
LispVal *name = Qlambda;
LispVal *name = Qunbound;
if (parse_function_declare(HEAD(body), &name)) {
body = TAIL(body);
}
LispVal *return_tag;
if (name == Qunbound) {
name = Qlambda;
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name));
} else {
CHECK_TYPE(TYPE_SYMBOL, name);
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
}
LispVal *expanded_body = Fmacroexpand_all(body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, expanded_body,
false);
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, false);
});
return func;
}

24
src/lisp.h
View File

@ -108,6 +108,7 @@ typedef struct {
LISP_OBJECT_HEADER;
LispVal *name;
LispVal *return_tag;
LispVal *doc;
LispVal *args;
bool is_builtin;
@ -267,6 +268,8 @@ inline static bool NUMBERP(LispVal *v) {
_INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, )
#define STATIC_DEFUN(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, static)
#define STATIC_DEFMACRO(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, static)
// ###############
// # Loop macros #
@ -318,8 +321,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 *name, LispVal *args, LispVal *lexenv,
LispVal *body, bool is_macro);
LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, 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) \
@ -422,7 +425,8 @@ struct CleanupHandlerEntry {
typedef struct StackFrame {
struct StackFrame *next;
bool hidden;
LispSymbol *name;
LispVal *name;
LispVal *return_tag;
LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value
bool enable_handlers;
@ -519,14 +523,18 @@ LispVal *predicate_for_type(LispType type);
extern LispVal *Vobarray;
#define REGISTER_SYMBOL(sym) \
#define REGISTER_SYMBOL_NOINTERN(sym) \
{ \
refcount_init_static(Q##sym); \
refcount_init_static(((LispSymbol *) Q##sym)->name); \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \
}
#define REGISTER_STATIC_FUNCTION(obj, args, docstr) \
#define REGISTER_SYMBOL(sym) \
REGISTER_SYMBOL_NOINTERN(sym) \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym);
#define REGISTER_STATIC_FUNCTION(name, args, docstr) \
REGISTER_SYMBOL_NOINTERN(name); \
{ \
LispVal *obj = ((LispSymbol *) Q##name)->function; \
refcount_init_static(obj); \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
LispVal *src = STATIC_STRING(args); \
@ -536,8 +544,8 @@ extern LispVal *Vobarray;
refcount_unref(a); \
}
#define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_SYMBOL(fn); \
REGISTER_STATIC_FUNCTION(((LispSymbol *) Q##fn)->function, args, docstr);
REGISTER_STATIC_FUNCTION(fn, args, docstr); \
puthash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn);
void lisp_init(void);
void lisp_shutdown(void);

46
src/main.c
View File

@ -3,22 +3,8 @@
static int exit_status = 0;
LispVal *Ftoplevel_exit_handler(LispVal *except);
static LispFunction _Ftoplevel_exit_handler_function = {
.type = TYPE_FUNCTION,
.is_builtin = true,
.is_macro = false,
.builtin = (lisp_function_ptr_t) &Ftoplevel_exit_handler,
.args = Qnil,
.kwargs = Qnil,
.rargs = Qnil,
.oargs = Qnil,
.rest_arg = Qnil,
.lexenv = Qnil,
};
#define Ftoplevel_exit_handler_function \
LISPVAL(&_Ftoplevel_exit_handler_function)
LispVal *Ftoplevel_exit_handler(LispVal *except) {
STATIC_DEFUN(toplevel_exit_handler, "toplevel-exit-handler",
(LispVal * except)) {
LispVal *detail = TAIL(HEAD(except));
if (NILP(detail) || NILP(HEAD(detail))) {
exit_status = 0;
@ -30,22 +16,8 @@ LispVal *Ftoplevel_exit_handler(LispVal *except) {
return Qnil;
}
LispVal *Ftoplevel_error_handler(LispVal *except);
static LispFunction _Ftoplevel_error_handler_function = {
.type = TYPE_FUNCTION,
.is_builtin = true,
.is_macro = false,
.builtin = (lisp_function_ptr_t) &Ftoplevel_error_handler,
.args = Qnil,
.kwargs = Qnil,
.lexenv = Qnil,
.rargs = Qnil,
.oargs = Qnil,
.rest_arg = Qnil,
};
#define Ftoplevel_error_handler_function \
LISPVAL(&_Ftoplevel_error_handler_function)
LispVal *Ftoplevel_error_handler(LispVal *except) {
STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler",
(LispVal * except)) {
LispVal *type = HEAD(HEAD(except));
LispVal *detail = TAIL(HEAD(except));
LispVal *backtrace = HEAD(TAIL(except));
@ -84,19 +56,17 @@ int main(int argc, const char **argv) {
fclose(in);
lisp_init();
REGISTER_SYMBOL(toplevel_read);
REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", "");
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", "");
REGISTER_STATIC_FUNCTION(toplevel_error_handler, "(e)", "");
REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", "");
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
LispVal *err_var = INTERN_STATIC("err-var");
puthash(the_stack->handlers, Qt,
// simply call the above function
const_list(true, 3, err_var, Ftoplevel_error_handler_function,
err_var));
const_list(true, 3, err_var, Qtoplevel_error_handler, err_var));
puthash(the_stack->handlers, Qshutdown_signal,
// simply call the above function
const_list(true, 3, err_var, Ftoplevel_exit_handler_function,
err_var));
const_list(true, 3, err_var, Qtoplevel_exit_handler, err_var));
LispVal *nil_nil = Fpair(Qnil, Qnil);
puthash(the_stack->handlers, Qeof_error,
// ignore