New frame type to block bad unwinding and cont capture.

If some external function is invoked which can call back
into TXR Lisp, we should guard against the called-back
code from capturing a continuation across the external
stack frames, and also from unwinding across those
frames. This patch prepares a mechanism for this.

* unwind.c (uw_unwind_to_exit_point): Abort with message on
standard error if attempt is made to unwind across UW_GUARD
frame.
(uw_push_guard): New function.
(uw_capture_cont): If the frame search
encounters a UW_GUARD block, an exception is thrown.

* unwind.h (enum uw_frtype): New enum constant, UW_GUARD.
(uw_push_guard): Declared.

2 files changed, 32 insertions, 4 deletions

diff --git a/unwind.c b/unwind.c
index e7257896..6483bbc9 100644
--- a/unwind.c
+++ b/unwind.c
@@ -90,6 +90,10 @@ static void uw_unwind_to_exit_point(void)
       /* Maintain consistency of unwind stack pointer */
       uw_env_stack = uw_env_stack->ev.up_env;
       break;
+    case UW_GUARD:
+      format(std_error, lit("~a: cannot unwind across foreign stack frames\n"),
+             prog_string, nao);
+      abort();
     default:
       break;
     }
@@ -226,6 +230,14 @@ val uw_set_match_context(val context)
   return context;
 }
 
+void uw_push_guard(uw_frame_t *fr)
+{
+  memset(fr, 0, sizeof *fr);
+  fr->uw.type = UW_GUARD;
+  fr->uw.up = uw_stack;
+  uw_stack = fr;
+}
+
 void uw_push_debug(uw_frame_t *fr, val func, struct args *args,
                    val ub_p_a_pairs, val env, val data,
                    val line, val chr)
@@ -826,16 +838,31 @@ static val capture_cont(val tag, val fun, uw_frame_t *block)
 
 val uw_capture_cont(val tag, val fun, val ctx_form)
 {
+  uses_or2;
   uw_frame_t *fr;
 
   for (fr = uw_stack; fr != 0; fr = fr->uw.up) {
-    if ((fr->uw.type == UW_BLOCK || fr->uw.type == UW_CAPTURED_BLOCK)
-        && fr->bl.tag == tag)
+    switch (fr->uw.type) {
+    case UW_BLOCK:
+    case UW_CAPTURED_BLOCK:
+      if (fr->bl.tag != tag)
+        continue;
       break;
+    case UW_GUARD:
+      {
+        val sym = or2(car(default_bool_arg(ctx_form)), sys_capture_cont_s);
+        eval_error(ctx_form, lit("~s: cannot capture continuation "
+                                 "spanning external library stack frames"),
+                   sym, nao);
+      }
+    default:
+      continue;
+    }
+
+    break;
   }
 
   if (!fr) {
-    uses_or2;
     val sym = or2(car(default_bool_arg(ctx_form)), sys_capture_cont_s);
 
     if (tag)
diff --git a/unwind.h b/unwind.h
index 8ada31d8..ba2ac767 100644
--- a/unwind.h
+++ b/unwind.h
@@ -27,7 +27,7 @@
 typedef union uw_frame uw_frame_t;
 typedef enum uw_frtype {
   UW_BLOCK, UW_CAPTURED_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE,
-  UW_CONT_COPY, UW_DBG
+  UW_CONT_COPY, UW_GUARD, UW_DBG
 } uw_frtype_t;
 
 struct uw_common {
@@ -123,6 +123,7 @@ noreturn val uw_errorfv(val fmt, struct args *args);
 val uw_register_subtype(val sub, val super);
 val uw_exception_subtype_p(val sub, val sup);
 void uw_continue(uw_frame_t *curr, uw_frame_t *target);
+void uw_push_guard(uw_frame_t *);
 void uw_push_debug(uw_frame_t *, val func, struct args *,
                    val ub_p_a_pairs, val env, val data,
                    val line, val chr);