TXR gets delimited continuations.

* unwind.c (sys_cont_s): New symbol variable.
(uw_pop_block): New function, supporting uw_block_end macro.
Special logic is needed for popping blocks now, because a
block can be a captured stub at the top of a continuation,
which must not be popped in the
regular manner.
(struct cont): New struct type.
(cont_destroy, cont_mark): New static functions.
(cont_ops): New static structure.
(revive_cont, capture_cont): New static functions.
(uw_capture_cont): New functions.
(uw_init): Initialize sys_cont_s.
Register sys:capture-cont intrinsic.

* unwind.h (enum uw_frtype): New enum member
UW_CAPTURED_BLOCK. When a block is captured as a stub copy of
the prompt block of a delimited continuation, its type is
changed from UW_BLOCK to this new type. This does two things:
it makes the block invisible to block-related code that does
nothing with continuations (code that looks for UW_BLOCK
and ignores anything else). Secondly, there is some special
handling related to UW_CAPTURED_BLOCK frames.
(uw_pop_block, uw_capture_cont): Declared.
(uw_block_begin): New local pointer uw_rslt introduced
which helps communicate the result variable over to the
uw_block_end macro (so we don't have to add a variable
argument to the latter).
(uw_block_end): Use uw_pop_block instead of uw_pop_frame.

* txr.1: Documented delimited continuations.

3 files changed, 345 insertions, 5 deletions

diff --git a/txr.1 b/txr.1
index 899b3c69..9b33de81 100644
--- a/txr.1
+++ b/txr.1
@@ -12506,6 +12506,23 @@ and
 A block named by the symbol nil is slightly special: it is
 understood to be an anonymous block.
 
+A named or anonymous block establishes an exit point for the
+.code return-from
+or
+.code return
+operator, respectively. These operators can be invoked within a block
+to cause its immediate termination with a specified return value.
+
+A block also establishes a prompt for a
+.IR "delimited continuation" .
+Anywhere in a block, a continuation can be captured using the
+.code sys:capture-cont
+function. Delimited continuations are described in the section
+Delimited Continuations. A delimited continuation allows an apparently
+abandoned block to be restarted at the capture point, with the
+entire call chain and dynamic environment between the prompt and the capture
+point intact.
+
 Blocks in \*(TL have dynamic scope. This means that the following
 situation is allowed:
 
@@ -12547,6 +12564,8 @@ the construct.
 .code throw
 itself is a function and not an operator.
 
+Common Lisp blocks also do not support delimited continuations.
+
 .coNP Operators @ return and @ return-from
 .synb
 .mets (return <> [ value ])
@@ -27301,6 +27320,170 @@ The frame receives control even if it it is not otherwise eligible for
 catching the exception type denoted by
 .metn symbol .
 
+.SS* Delimited Continuations
+
+\*(TL supports delimited continuations, which are integrated with the
+.code block
+feature. Any named or anonymous block, including the implicit blocks
+created around function bodies, can be used as the delimiting
+.I prompt
+for the capture of a continuation.
+
+A delimited continuation consists of a copy
+of entire activation chain ("call stack") segment between the delimiting
+prompt and the capture point,
+.I reified
+as a first-class function. The function takes one argument. When the
+continuation function is called, the copy of the evaluation context is
+reinstated and its execution is restarted. Within the reinstated context,
+control resumes at the point where the continuation was originally captured.
+
+The argument passed to the continuation function appears as a return value from
+the capture form. Thus the capture form appears to return multiple times: the
+first time it returns, it returns the continuation.  Then each time the
+continuation is called, and thereby resumed, the capture form appears to return
+again, this time returning the value which was passed in.
+
+A restarted continuation can terminate normally: that is, by simply continuing
+to execute and then finally terminating the block which served as its
+delimiting prompt. When this happens, the continuation function terminates
+and returns the block's value.
+
+Thus, a delimited continuation is an ordinary function. It can be invoked
+multiple times, composed with other functions and so forth.
+
+.TP* Notes:
+
+Delimited continuations resemble lexical closures in some ways. Both
+constructs provide a way to return to some context whose evaluation
+has already been abandoned, and to access some aspects of that context.
+However, lexical closures are statically scoped. Closures capture the lexically
+apparent scope at a given point, and produce a function whose body has access
+to that scope, as well as to some arbitrary arguments. Thus, a lexical scope
+is reified as a first-class function. By contrast, a delimited continuation
+is dynamic. It captures an an entire segment of a program activation chain,
+up to the delimiting prompt. This segment includes scopes which are not
+lexically visible at the capture point: the scopes of parent functions.
+Moreover, the segment includes not only scopes, but also other aspects of
+the evaluation context, such as the possibility of returning to callers,
+and the (captured portion of) the original dynamic environment, such as
+exception handlers.  That is to say, a lexical closure's body cannot return to
+the surrounding code or see any of its original dynamic environment; it can
+only inspect the environment, and then return to its own caller.  Whereas a
+restarted delimited continuation can continue evaluation of the surrounding
+code, return to surrounding forms and parent functions, and access the dynamic
+environment. The continuation function returns to its caller when that entire
+restarted context terminates, whereas a closure returns to its caller as soon
+as the closure body terminates.
+
+.coNP Function @ sys:capture-cont
+.synb
+.mets (sys:capture-cont < name << error-report-sym )
+.syne
+.desc
+The
+.code sys:capture-cont
+function captures a continuation, and also serves as the resume point
+for the resulting continuation. Which of these two situations is the
+case (capture or resumption) is distinguished by the return value.
+
+A block named
+.meta name
+must be visible; the continuation is delimited by the closest
+enclosing block of this name.
+
+The
+.meta error-report-sym
+argument should be a symbol. It is used in the error message if
+.code sys:capture-cont
+is incorrectly used. The intent is that higher level constructs built
+on this function can pass their own name, so the resulting diagnostic
+pertains to these constructs, rather than the lower level interface.
+
+The
+.code sys:capture-cont
+function returns a cons cell. The
+.code car
+field of the cell distinguishes the capture and resume situations.
+If the
+.code car
+is the object
+.codn t ,
+then it indicates capture, and in this case, the
+.code cdr
+field contains the continuation function.  When the continuation
+function is called, the
+.code sys:capture-cont
+function appears to return again. This time the
+.code car
+of the returned cell is
+.code nil
+indicating that the
+.code cdr
+field holds the argument value which was passed to the continuation
+function.
+
+The invoked continuation function will terminate when the resumed context
+terminates. If that context terminates normally (by returning from the
+delimiting block named by
+.metn name ),
+then the result value of that block will appear as the return value
+of the continuation function.
+
+.TP* Note:
+
+The continuation function may be used any time after it is produced, and may be
+called more than once, regardless of whether the originally captured dynamic
+context is still executing. The underlying continuation stores a copy of the
+captured dynamic context.  Whenever the continuation function is invoked, a
+copy of the captured context is made again and reinstated as if it were a new
+context.  Thus the apparent additional returns from
+.code sys:capture-cont
+are not actually made in the original context, but a copy. The copy of the
+context is not complete; it only extends up to the enclosing block which was
+named in the capturing call.
+
+.TP* "Example:"
+
+The following example shows an implementation of the
+.meta shift
+and
+.meta reset
+operators which often appear in literature about delimited continuations.
+To avoid a clash with the
+.code shift
+macro, the
+.meta shift
+operator is named
+.codn shft .
+Note that the example shows the extended
+.meta shift
+and
+.meta reset
+with named prompts.
+
+.cblk
+  ;; Definition:
+
+  (defmacro reset (name . body)
+    ^(block ,name ,*body))
+
+  (defun shft-helper (name fun)
+    (let ((val (sys:capture-cont name 'shft)))
+      (if (car val)
+        (call fun (lambda (arg)
+                    (call (cdr val) arg)))
+        (cdr val))))
+
+  (defmacro shft (name var . body)
+    ^(shft-helper ',name
+       (lambda (,var) (return-from ,name ,*body))))
+
+  ;; Usage:
+  (reset foo (* 2 (shft foo k [k 3]) (shft foo l [l 4])))
+  --> 24
+.cble
+
 .SS* Regular Expression Library
 .coNP Functions @ search-regex and @ range-regex
 .synb
diff --git a/unwind.c b/unwind.c
index 0e075306..6064ccfd 100644
--- a/unwind.c
+++ b/unwind.c
@@ -50,7 +50,7 @@ static uw_frame_t *uw_env_stack;
 static uw_frame_t *uw_exit_point;
 static uw_frame_t toplevel_env;
 
-static val unhandled_hook_s, types_s, jump_s;
+static val unhandled_hook_s, types_s, jump_s, sys_cont_s;
 
 static val frame_type, catch_frame_type, handle_frame_type;
 
@@ -203,6 +203,20 @@ void uw_pop_frame(uw_frame_t *fr)
   }
 }
 
+void uw_pop_block(uw_frame_t *fr, val *pret)
+{
+  if (uw_stack->uw.type == UW_CAPTURED_BLOCK) {
+    assert (fr->uw.type == UW_BLOCK || fr->uw.type == UW_CAPTURED_BLOCK);
+    assert (uw_stack->bl.tag == fr->bl.tag);
+
+    uw_stack = fr->uw.up;
+    uw_block_return(uw_stack->bl.tag, *pret);
+    abort();
+  }
+
+  uw_pop_frame(fr);
+}
+
 void uw_pop_until(uw_frame_t *fr)
 {
   while (uw_stack != fr)
@@ -614,6 +628,144 @@ void uw_continue(uw_frame_t *current, uw_frame_t *cont)
   uw_unwind_to_exit_point();
 }
 
+struct cont {
+  uw_frame_t *orig;
+  cnum size;
+  val tag;
+  mem_t *stack;
+};
+
+static void cont_destroy(val obj)
+{
+  struct cont *cont = coerce(struct cont *, obj->co.handle);
+  free(cont->stack);
+  free(cont);
+}
+
+static void cont_mark(val obj)
+{
+  struct cont *cont = coerce(struct cont *, obj->co.handle);
+  val *mem = coerce(val *, cont->stack);
+  gc_mark_mem(mem, mem + cont->size / sizeof *mem);
+  gc_mark(cont->tag);
+}
+
+static struct cobj_ops cont_ops = cobj_ops_init(eq,
+                                                cobj_print_op,
+                                                cont_destroy,
+                                                cont_mark,
+                                                cobj_hash_op);
+
+static val revive_cont(val dc, val arg)
+{
+  const int frame_slack = 32 * sizeof (val);
+  struct cont *cont = coerce(struct cont *, cobj_handle(dc, sys_cont_s));
+  mem_t *space = coerce(mem_t *, alloca(cont->size + frame_slack)) + frame_slack;
+  uint_ptr_t orig_start = coerce(uint_ptr_t, cont->orig);
+  uint_ptr_t orig_end = orig_start + cont->size;
+  cnum delta = space - coerce(mem_t *, cont->orig);
+  mem_t *ptr;
+  uw_frame_t *new_uw_stack = coerce(uw_frame_t *, space), *fr;
+  int env_set = 0;
+
+  memcpy(space, cont->stack, cont->size);
+
+  for (ptr = space; ptr < space + cont->size; ptr += sizeof (cnum))
+  {
+    uint_ptr_t *wordptr = coerce(uint_ptr_t *, ptr);
+    uint_ptr_t word = *wordptr;
+
+    if (word >= orig_start - frame_slack &&
+        word < orig_end && is_ptr(coerce(val, word)))
+      *wordptr = word + delta;
+  }
+
+  uw_block_begin (cont->tag, result);
+
+  for (fr = new_uw_stack; ; fr = fr->uw.up) {
+    if (!env_set && fr->uw.type == UW_ENV) {
+      uw_env_stack = fr;
+      env_set = 1;
+    }
+    if (fr->uw.up == 0) {
+      bug_unless (fr->uw.type == UW_CAPTURED_BLOCK);
+      bug_unless (fr->bl.tag == cont->tag);
+      fr->uw.up = uw_stack;
+      break;
+    }
+  }
+
+  uw_stack = new_uw_stack;
+
+  bug_unless (uw_stack->uw.type == UW_BLOCK);
+
+  uw_stack->bl.result = cons(nil, arg);
+  uw_exit_point = uw_stack;
+  uw_unwind_to_exit_point();
+  abort();
+
+  uw_block_end;
+
+  return result;
+}
+
+static val capture_cont(val tag, uw_frame_t *block)
+{
+  uw_block_begin (nil, result);
+
+  bug_unless (uw_stack < block);
+
+  {
+    cnum bloff = coerce(mem_t *, block) - coerce(mem_t *, uw_stack);
+    cnum size = bloff + sizeof *block;
+    mem_t *stack = chk_malloc(size);
+    uw_frame_t *blcopy = coerce(uw_frame_t *, stack + bloff);
+    struct cont *cont = coerce(struct cont *, chk_malloc(sizeof *cont));
+
+    cont->orig = uw_stack;
+    cont->size = size;
+    cont->stack = stack;
+    cont->tag = nil;
+
+    memcpy(stack, uw_stack, size);
+
+    blcopy->uw.up = 0;
+    blcopy->uw.type = UW_CAPTURED_BLOCK;
+
+    result = cobj(coerce(mem_t *, cont), sys_cont_s, &cont_ops);
+
+    cont->tag = tag;
+
+    result = cons(t, func_f1(result, revive_cont));
+  }
+
+  uw_block_end;
+
+  return result;
+}
+
+val uw_capture_cont(val tag, val ctx)
+{
+  uw_frame_t *fr;
+
+  for (fr = uw_stack; fr != 0; fr = fr->uw.up) {
+    if (fr->uw.type == UW_BLOCK && fr->bl.tag == tag)
+      break;
+  }
+
+  if (!fr) {
+    if (tag)
+      uw_throwf(error_s, lit("~s: no block ~s is visible"),
+                ctx, tag, nao);
+    else
+      uw_throwf(error_s, lit("~s: no anonymous block is visible"),
+                ctx, nao);
+    abort();
+  }
+
+  return capture_cont(tag, fr);
+}
+
 void uw_init(void)
 {
   protect(&toplevel_env.ev.func_bindings,
@@ -638,6 +790,7 @@ void uw_late_init(void)
           convert(val *, 0));
   types_s = intern(lit("types"), user_package);
   jump_s = intern(lit("jump"), user_package);
+  sys_cont_s = intern(lit("cont"), system_package);
   frame_type = make_struct_type(intern(lit("frame"), user_package),
                                 nil, nil, nil, nil, nil, nil);
   catch_frame_type = make_struct_type(intern(lit("catch-frame"),
@@ -656,4 +809,5 @@ void uw_late_init(void)
   reg_fun(intern(lit("find-frame"), user_package), func_n2o(uw_find_frame, 0));
   reg_fun(intern(lit("invoke-catch"), user_package),
           func_n2v(uw_invoke_catch));
+  reg_fun(intern(lit("capture-cont"), system_package), func_n2(uw_capture_cont));
 }
diff --git a/unwind.h b/unwind.h
index 97d1026a..d6753da4 100644
--- a/unwind.h
+++ b/unwind.h
@@ -32,7 +32,7 @@
 
 typedef union uw_frame uw_frame_t;
 typedef enum uw_frtype {
-  UW_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE, UW_DBG
+  UW_BLOCK, UW_CAPTURED_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE, UW_DBG
 } uw_frtype_t;
 
 struct uw_common {
@@ -123,12 +123,14 @@ void uw_push_debug(uw_frame_t *, val func, struct args *,
                    val ub_p_a_pairs, val env, val data,
                    val line, val chr);
 void uw_pop_frame(uw_frame_t *);
+void uw_pop_block(uw_frame_t *, val *pret);
 void uw_pop_until(uw_frame_t *);
 uw_frame_t *uw_current_frame(void);
 uw_frame_t *uw_current_exit_point(void);
 val uw_get_frames(void);
 val uw_find_frame(val extype, val frtype);
 val uw_invoke_catch(val catch_frame, val sym, struct args *);
+val uw_capture_cont(val tag, val ctx);
 void uw_init(void);
 void uw_late_init(void);
 
@@ -147,15 +149,16 @@ noreturn val type_mismatch(val, ...);
   obj_t *RESULTVAR = nil;                       \
   do {                                          \
     uw_frame_t uw_blk;                          \
+    obj_t **uw_rslt = &RESULTVAR;               \
     uw_push_block(&uw_blk, TAG);                \
     if (extended_setjmp(uw_blk.bl.jb)) {        \
       RESULTVAR = uw_blk.bl.result;             \
     } else {                                    \
       do { } while (0)
 
-#define uw_block_end                    \
-    }                                   \
-    uw_pop_frame(&uw_blk);              \
+#define uw_block_end                            \
+    }                                           \
+    uw_pop_block(&uw_blk, uw_rslt);             \
   } while (0)
 
 #define uw_env_begin                    \