From 342bdfb16912ecc55784f1457bd61cd438248157 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Fri, 19 Sep 2025 14:41:32 -0700 Subject: [PATCH] Get returns working --- src/kernel.sl | 5 ++ src/lisp.c | 169 ++++++++++++++++++++++++++++++++++++++++++-------- src/lisp.h | 32 ++++++---- src/main.c | 46 +++----------- 4 files changed, 175 insertions(+), 77 deletions(-) diff --git a/src/kernel.sl b/src/kernel.sl index 80e680a..8346a54 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -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)) diff --git a/src/lisp.c b/src/lisp.c index c0a1645..635a249 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -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); + 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; } diff --git a/src/lisp.h b/src/lisp.h index 08796a5..e394511 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -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) \ - { \ - refcount_init_static(Q##sym); \ - refcount_init_static(((LispSymbol *) Q##sym)->name); \ - puthash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \ +#define REGISTER_SYMBOL_NOINTERN(sym) \ + { \ + refcount_init_static(Q##sym); \ + refcount_init_static(((LispSymbol *) Q##sym)->name); \ } -#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); \ @@ -535,9 +543,9 @@ extern LispVal *Vobarray; refcount_unref(src); \ refcount_unref(a); \ } -#define REGISTER_FUNCTION(fn, args, docstr) \ - REGISTER_SYMBOL(fn); \ - REGISTER_STATIC_FUNCTION(((LispSymbol *) Q##fn)->function, args, docstr); +#define REGISTER_FUNCTION(fn, 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); diff --git a/src/main.c b/src/main.c index 682b8da..d2c0f91 100644 --- a/src/main.c +++ b/src/main.c @@ -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