Lexical jumps

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