From 956297335da86f351a30910fd158c8c9873e031d Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sat, 5 Sep 2026 00:58:11 -0700 Subject: [PATCH] Lexical jumps --- lisp/kernel.gl | 7 ++-- src/base.c | 1 + src/base.h | 22 ++++++++++++ src/function.c | 4 +-- src/gc.c | 5 +++ src/gen-init-globals.awk | 6 ++++ src/lisp.c | 53 +++++++++++++++++----------- src/lisp.h | 2 ++ src/list.c | 21 +++--------- src/list.h | 2 +- src/macro.c | 3 +- src/stack.c | 74 +++++++++++++++++++++++++++++++++++++--- src/stack.h | 13 +++++++ 13 files changed, 164 insertions(+), 49 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index b3b0e47..5843012 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,7 +1,6 @@ ;; -*- mode: lisp-data -*- -(fset 'test (cons 'macro (lambda (x) (declare (name test)) (list 'princ x)))) - -(prin1 (macroexpand-all '(lambda () (test x)) - '((test . (lambda (x) (test x)))))) +(prin1 (let ((l (block 'c (lambda () (return-from 'c 3))))) + (block 'c + (funcall l)))) (write-byte ?\n) diff --git a/src/base.c b/src/base.c index 094b7ee..7531dbb 100644 --- a/src/base.c +++ b/src/base.c @@ -65,6 +65,7 @@ DEFINE_SYMBOL(nil, "nil"); DEFINE_SYMBOL(t, "t"); DEFINE_SYMBOL(unbound, "unbound"); DEFVAR(lexical_environment, "lexical-environment", "", Qnil); +DEFINE_SYMBOL(lexical_tags, "lexical-tags"); DEFUN(id, "id", (LispVal * obj), "(id)", "") { // TODO not all values are handled here diff --git a/src/base.h b/src/base.h index fe95819..b59d3c8 100644 --- a/src/base.h +++ b/src/base.h @@ -281,6 +281,8 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { LispVal *F##cname cargs #define DEFSPECIAL(cname, lisp_name, cargs, lisp_args, doc) \ DEFUN(cname, lisp_name, cargs, lisp_args, doc) +#define DEFSPECIAL_NOINTERN(cname, lisp_name, cargs, lisp_args, doc) \ + DEFUN(cname, lisp_name, cargs, lisp_args, doc) #define DEFINE_CONDITION_CLASS(cname, parent_cname) \ LispVal **internal_Q##cname##_parent_condition_class = &Q##parent_cname @@ -292,6 +294,14 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { ((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL; \ lisp_gc_register_static_object(Q##cname); \ } +#define REGISTER_GLOBAL_SYMBOL_NOINTERN(cname) \ + { \ + Q##cname = Fmake_symbol(make_lisp_string(internal_Q##cname##_name, \ + internal_Q##cname##_name_len, \ + false, false)); \ + ((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL; \ + lisp_gc_register_static_object(Q##cname); \ + } #define REGISTER_GLOBAL_VARIABLE(cname) \ REGISTER_GLOBAL_SYMBOL(cname); \ { \ @@ -303,12 +313,22 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { #define REGISTER_GLOBAL_FUNCTION(cname) \ { \ REGISTER_GLOBAL_SYMBOL(cname); \ + ((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \ ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ } +#define REGISTER_GLOBAL_SPECIAL_NOINTERN(cname) \ + { \ + REGISTER_GLOBAL_SYMBOL_NOINTERN(cname); \ + ((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \ + ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ + ((LispFunction *) ((LispSymbol *) Q##cname)->function) \ + ->impl.native.no_eval_args = true; \ + } #define REGISTER_GLOBAL_SPECIAL(cname) \ { \ REGISTER_GLOBAL_SYMBOL(cname); \ + ((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \ ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ ((LispFunction *) ((LispSymbol *) Q##cname)->function) \ ->impl.native.no_eval_args = true; \ @@ -321,8 +341,10 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { DECLARE_SYMBOL(nil); DECLARE_SYMBOL(t); +// these are uninterned DECLARE_SYMBOL(unbound); DECLARE_VARIABLE(lexical_environment); +DECLARE_VARIABLE(lexical_tags); extern LispVal *Vlexical_environment; diff --git a/src/function.c b/src/function.c index 80e3ebd..2fda93e 100644 --- a/src/function.c +++ b/src/function.c @@ -373,7 +373,7 @@ static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec, static ALWAYS_INLINE void push_missing_optional_argument_to_lexenv(LispVal *spec) { - new_lexical_variable(XCAR(spec), Feval(SECOND(spec), Vlexical_environment)); + new_lexical_variable(XCAR(spec), eval(SECOND(spec))); if (!NILP(THIRD(spec))) { new_lexical_variable(THIRD(spec), Qnil); } @@ -449,7 +449,7 @@ LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func) { if (SYMBOLP(func)) { fobj = Fsymbol_function(func, Qt); } else if (CONSP(func) && EQ(XCAR(func), Qlambda)) { - fobj = Feval(func, Vlexical_environment); + fobj = eval(func); } if (NILP(fobj)) { lisp_signal(Qvoid_function_error, LIST(orig_name)); diff --git a/src/gc.c b/src/gc.c index 0396f1d..3c7887e 100644 --- a/src/gc.c +++ b/src/gc.c @@ -308,6 +308,11 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) { mark_object(frame->dynamic_binding.old_value); saturating_dec(limit, 2); break; + case STACK_FRAME_BLOCK: + mark_object(frame->block.tag); + // leave protecting value up to internal-return-from + saturating_dec(limit, 1); + break; } } diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index 9fd5d71..f963bd4 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -5,6 +5,7 @@ BEGIN { special_syms["nil"] = 1 special_syms["unbound"] = 1 special_syms["lexical_environment"] = 1 + special_syms["lexical_tags"] = 1 special_syms["hash_string"] = 1 special_syms["strings_equal"] = 1 special_syms["and_rest"] = 1 @@ -86,6 +87,11 @@ function maybe_emit_next_symbol(entity) { maybe_emit_next_symbol("SPECIAL") } +/DEFSPECIAL_NOINTERN\(/ { + maybe_print_file_header() + maybe_emit_next_symbol("SPECIAL_NOINTERN") +} + /DEFINE_SYMBOL\(/ { maybe_print_file_header() maybe_emit_next_symbol("SYMBOL") diff --git a/src/lisp.c b/src/lisp.c index 09f5290..96f8e05 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -26,6 +26,8 @@ static void construct_manual_symbols(void) { ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE; ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment; lisp_gc_register_static_object(Qlexical_environment); + Qlexical_tags = Fmake_symbol(LISP_LITSTR("lexical-tags")); + lisp_gc_register_static_object(Qlexical_tags); Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); lisp_gc_register_static_object(Qhash_string); @@ -38,7 +40,9 @@ static void register_manual_symbols(void) { Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname); INTERN(nil); INTERN(t); - INTERN(unbound); + // don't INTERN(unbound); + // don't INTERN(lexical_environment); + // don't INTERN(lexical_tags); INTERN(hash_string); INTERN(strings_equal); #undef INTERN @@ -73,8 +77,8 @@ void lisp_shutdown(void) { lisp_gc_teardown(); } -static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { - LispVal *lexval = Fplist_get(lexenv, name, Qunbound); +static inline LispVal *lookup_variable(LispSymbol *name) { + LispVal *lexval = Fplist_get(Vlexical_environment, name, Qunbound); if (lexval != Qunbound) { return lexval; } @@ -84,24 +88,22 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { return SYMBOL_VALUE(name); } -static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args, - LispVal *lexenv) { +static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) { LispVal *start = Qnil; LispVal *end = NULL; DOLIST(arg, args) { if (NILP(start)) { - start = CONS(Feval(arg, lexenv), Qnil); + start = CONS(eval(arg), Qnil); end = start; } else { - RPLACD(end, CONS(Feval(arg, lexenv), Qnil)); + RPLACD(end, CONS(eval(arg), Qnil)); end = XCDR(end); } } return start; } -DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), - "(form &optional lexenv)", "") { +LispVal *eval(LispVal *form) { if (!OBJECTP(form)) { // fixnum or float return form; @@ -119,25 +121,25 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), out_data[i] = Qnil; } for (size_t i = 0; i < vec->length; ++i) { - out_data[i] = Feval(vec->data[i], lexenv); + out_data[i] = eval(vec->data[i]); } return newvec; } case TYPE_SYMBOL: - return lookup_variable(form, lexenv); + return lookup_variable(form); case TYPE_CONS: { LispVal *res = XCAR(form); if (SYMBOLP(res)) { res = Fsymbol_function(res, Qt); } if (!NILP(Fmacrop(res))) { - return Feval(Fmacroexpand_all(form, Qnil), lexenv); + return eval(Fmacroexpand_all(form, Qnil)); } LispVal *stack_ref = LISP_STACK_REF(); push_call_frame(XCAR(form), XCDR(form)); LispVal *evaled_args = XCDR(form); if (NILP(Fspecial_form_p(res))) { - evaled_args = evaluate_function_arguments(XCDR(form), lexenv); + evaled_args = evaluate_function_arguments(XCDR(form)); } LispVal *fobj = coerce_to_function(XCAR(form), res); set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args); @@ -150,10 +152,17 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), } } +DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), + "(form &optional lexenv)", "") { + StackFrame *stack_ref = LISP_STACK_REF(); + push_dynamic_binding(Qlexical_environment, lexenv); + return UNWIND_AND_RETURN(stack_ref, eval(form)); +} + DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { LispVal *rval = Qnil; DOLIST(form, forms) { - rval = Feval(form, Vlexical_environment); + rval = eval(form); } return rval; } @@ -168,7 +177,7 @@ DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") { for (LispVal *rest = bindings; !NILP(bindings); bindings = XCDR(XCDR(bindings))) { LispVal *name = FIRST(rest); - value = Feval(SECOND(rest), Vlexical_environment); + value = eval(SECOND(rest)); set_lexical_variable(name, value); } return value; @@ -183,7 +192,7 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), if (!SYMBOLP(XCAR(binding))) { signal_type_error(XCAR(binding), LIST(Qsymbol)); } - RPLACA(XCDR(binding), Feval(SECOND(binding), Vlexical_environment)); + RPLACA(XCDR(binding), eval(SECOND(binding))); } else if (!SYMBOLP(binding)) { signal_type_error(binding, LIST(Qsymbol)); } @@ -203,9 +212,9 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise), "(cond then &rest else)", "") { StackFrame *stack_ref = LISP_STACK_REF(); - LispVal *res = Feval(cond, Vlexical_environment); + LispVal *res = eval(cond); if (!NILP(res)) { - return UNWIND_AND_RETURN(stack_ref, Feval(then, Vlexical_environment)); + return UNWIND_AND_RETURN(stack_ref, eval(then)); } else { return UNWIND_AND_RETURN(stack_ref, Fprogn(otherwise)); } @@ -214,7 +223,7 @@ DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise), DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") { LispVal *res = Qt; DOLIST(form, forms) { - res = Feval(form, Vlexical_environment); + res = eval(form); if (NILP(res)) { return Qnil; } @@ -224,7 +233,7 @@ DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") { DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") { DOLIST(form, forms) { - LispVal *res = Feval(form, Vlexical_environment); + LispVal *res = eval(form); if (!NILP(res)) { return res; } @@ -236,5 +245,9 @@ DEFUN(null, "null", (LispVal * datum), "(datum)", "") { return NILP(datum) ? Qt : Qnil; } +DEFUN(not, "not", (LispVal * datum), "(datum)", "") { + return NILP(datum) ? Qt : Qnil; +} + DEFINE_SYMBOL(unbound_variable_error, "unbound-variable-error"); DEFINE_CONDITION_CLASS(unbound_variable_error, error); diff --git a/src/lisp.h b/src/lisp.h index 7a3bf9a..ff65322 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -16,6 +16,7 @@ void lisp_init(void); void lisp_shutdown(void); +LispVal *eval(LispVal *form); DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(setq, (LispVal * bindings)); @@ -24,6 +25,7 @@ DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise)); DECLARE_FUNCTION(and, (LispVal * forms)); DECLARE_FUNCTION(or, (LispVal * forms)); DECLARE_FUNCTION(null, (LispVal * datum)); +DECLARE_FUNCTION(not, (LispVal * datum)); DECLARE_SYMBOL(unbound_variable_error); MAKE_CONDITION_CLASS(unbound_variable_error); diff --git a/src/list.c b/src/list.c index 6cfccc0..ca9954b 100644 --- a/src/list.c +++ b/src/list.c @@ -141,22 +141,11 @@ DEFUN(nth, "nth", (LispVal * n, LispVal *list), "(n list)", "") { return nth(XFIXNUM(n), list); } -DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred), - "(elt list &optional pred)", "") { - if (NILP(pred) || pred == Qeq) { - // fast case - DOTAILS(rest, list) { - CHECK_LISTP(rest); - if (elt == XCAR(rest)) { - return rest; - } - } - } else { - DOTAILS(rest, list) { - CHECK_LISTP(rest); - if (!NILP(CALL(pred, elt, XCAR(rest)))) { - return rest; - } +DEFUN(memq, "memq", (LispVal * elt, LispVal *list), "(elt list)", "") { + DOTAILS(rest, list) { + CHECK_LISTP(rest); + if (elt == XCAR(rest)) { + return rest; } } return Qnil; diff --git a/src/list.h b/src/list.h index 28a29d5..aed91b8 100644 --- a/src/list.h +++ b/src/list.h @@ -142,7 +142,7 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) { } // List utility functions -DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred)); +DECLARE_FUNCTION(memq, (LispVal * elt, LispVal *list)); DECLARE_FUNCTION(member_if, (LispVal * pred, LispVal *list)); DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value)); diff --git a/src/macro.c b/src/macro.c index 091fd5d..ce3543f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -102,7 +102,8 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, return macroexpand_lambda_form(form, lexical_macros); } else if (IS(quote)) { return form; - } else if (IS(progn) || IS(if) || IS(and) || IS(or)) { + } else if (IS(progn) || IS(if) || IS(and) || IS(or) || IS(block) + || IS(return_from)) { if (LISTP(XCDR(form))) { return CONS(XCAR(form), macroexpand_list(XCDR(form), lexical_macros)); diff --git a/src/stack.c b/src/stack.c index bd88f3e..ae0de38 100644 --- a/src/stack.c +++ b/src/stack.c @@ -2,6 +2,7 @@ #include "function.h" #include "hashtable.h" +#include "lisp.h" #include "list.h" #include "memory.h" #include "print.h" @@ -80,6 +81,7 @@ void set_stack_evaluated_args(StackFrame *restrict frame, LispVal *fobj, LispVal *args) { gc_mark_stack_for_rescan(); assert(frame->kind == STACK_FRAME_CALL); + frame->call.fobj = fobj; frame->call.args = args; frame->call.evaled_args = true; } @@ -299,6 +301,7 @@ void unwind_to(StackFrame *frame) { break; case STACK_FRAME_HANDLER_BIND: case STACK_FRAME_CALL: + case STACK_FRAME_BLOCK: // nothing to do break; } @@ -362,21 +365,82 @@ noreturn void lisp_signal(LispVal *name, LispVal *data) { top_of_stack_exception_handler(name, data); } +static void check_block_name(LispVal *name) { + if (!SYMBOLP(name) || NILP(name)) { + signal_type_error(name, LIST(Qsymbol, LIST(Qnot, Qnull))); + } +} + +DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)", + "") { + name = eval(name); + check_block_name(name); + if (!SYMBOLP(name)) + CHECK_TYPE(name, TYPE_SYMBOL); + LispVal *volatile return_value = Qnil; + jmp_buf target; + StackFrame *stack_ref = LISP_STACK_REF(); + LispVal *tag = Fmake_symbol(((LispSymbol *) name)->name); + LispVal *cur_tags = Fplist_get(Vlexical_environment, name, Qnil); + push_copy_lexenv(); + new_lexical_variable(Qlexical_tags, CONS(CONS(name, tag), cur_tags)); + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_BLOCK); + frame->block.tag = tag; + frame->block.target = ⌖ + frame->block.value_ptr = &return_value; + frame->block.unwind_to = stack_ref; + if (setjmp(target) == 0) { + return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); + } else { + // return-from handles unwinding and putting the return value in a local + // references frame + return return_value; + } +} + +static LispVal *lookup_block_tag(LispVal *name) { + LispVal *tags = Fplist_get(Vlexical_environment, Qlexical_tags, Qnil); + LispVal *ent = Fassoc(name, tags, Qnil); + return CONSP(ent) ? XCDR(ent) : Qunbound; +} + +DEFSPECIAL(return_from, "return-from", (LispVal * name, LispVal *value), + "(name &optional value)", "") { + name = eval(name); + check_block_name(name); + LispVal *tag = lookup_block_tag(name); + if (tag != Qunbound) { + for (ptrdiff_t i = the_stack.depth; i >= 0; --i) { + StackFrame *restrict frame = &the_stack.frames[i]; + if (frame->kind == STACK_FRAME_BLOCK && EQ(frame->block.tag, tag)) { + add_local_reference(frame->block.unwind_to, value); + *frame->block.value_ptr = value; + unwind_to(frame->block.unwind_to); + longjmp(*frame->block.target, 1); + } + } + } + // block went out of scope + lisp_signal(Qno_such_block_error, LIST(name)); +} + DEFUN(backtrace, "backtrace", (void), "()", "") { LispVal *out = Qnil; for (size_t i = 0; i < the_stack.depth; ++i) { StackFrame *restrict frame = &the_stack.frames[i]; if (frame->kind == STACK_FRAME_CALL) { + LispVal *name = frame->call.name; // fobj is NULL (not Qnil) if the arguments haven't been evaluated - out = CONS(LIST(frame->call.name, - frame->call.fobj ? frame->call.fobj : Qnil, - frame->call.evaled_args ? Qt : Qnil, - frame->call.args), - out); + LispVal *fobj = frame->call.fobj ? frame->call.fobj : Qnil; + LispVal *did_eval_args = frame->call.evaled_args ? Qt : Qnil; + LispVal *args = frame->call.args; + out = CONS(LIST(name, fobj, did_eval_args, args), out); } } return out; } +DEFINE_SYMBOL(no_such_block_error, "no-such-block-error"); +DEFINE_CONDITION_CLASS(no_such_block_error, error); DEFINE_SYMBOL(excessive_lisp_nesting_error, "excessive-lisp-nesting-error"); DEFINE_CONDITION_CLASS(excessive_lisp_nesting_error, error); diff --git a/src/stack.h b/src/stack.h index 646ed11..d80fb53 100644 --- a/src/stack.h +++ b/src/stack.h @@ -3,6 +3,7 @@ #include "base.h" +#include #include enum StackFrameKind { @@ -11,6 +12,7 @@ enum StackFrameKind { STACK_FRAME_UNWIND_PROTECT, STACK_FRAME_HANDLER_BIND, STACK_FRAME_DYNAMIC_BINDING, + STACK_FRAME_BLOCK, }; #define LISP_STACK_MAX_DEPTH 4096 @@ -58,6 +60,12 @@ struct _StackFrame { LispVal *symbol; LispVal *old_value; } dynamic_binding; + struct { + LispVal *tag; + jmp_buf *target; + LispVal *volatile *value_ptr; + StackFrame *unwind_to; + } block; }; }; @@ -139,11 +147,16 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, noreturn void lisp_signal(LispVal *name, LispVal *data); +DECLARE_FUNCTION(block, (LispVal * name, LispVal *body)); +DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); + /** * Backtraces have the form (name fobj evaled? args) */ DECLARE_FUNCTION(backtrace, (void) ); +DECLARE_SYMBOL(no_such_block_error); +MAKE_CONDITION_CLASS(no_such_block_error); DECLARE_SYMBOL(excessive_lisp_nesting_error); MAKE_CONDITION_CLASS(excessive_lisp_nesting_error);