From acfd125f2351a294f8872da5736169ea3c51786b Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 28 Oct 2015 06:05:39 -0700
Subject: Context form error reporting in sys:capture-cont.

* unwind.c (sys_capture_cont_s): New variable.
(uw_capture_cont): Second argument is now a context
form rather than a symbol; eval_error is used for error
reporting. The form's operator symbol si used in the
error message, or else sys:capture-cont if the
context argument is null or missing.
(uw_late_init): Initialize sys_capture_cont_s.

* unwind.h (uw_capture_cont): Declaration updated.

* txr.1: Documented.
---
 txr.1    | 25 ++++++++++++++-----------
 unwind.c | 15 +++++++++------
 unwind.h |  2 +-
 3 files changed, 24 insertions(+), 18 deletions(-)

diff --git a/txr.1 b/txr.1
index 885bdb11..c90a4200 100644
--- a/txr.1
+++ b/txr.1
@@ -27413,7 +27413,7 @@ as the closure body terminates.
 
 .coNP Function @ sys:capture-cont
 .synb
-.mets (sys:capture-cont < name << error-report-sym )
+.mets (sys:capture-cont < name <> [ context-form ])
 .syne
 .desc
 The
@@ -27427,13 +27427,15 @@ A block named
 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
+The optional
+.meta context-form
+argument should be a compound form. If
+.code sys:capture-cont
+reports an error, it reports it against this form,
+and uses the form's operator symbol as the name of the function which
+encountered the error.  If the argument is omitted,
 .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.
+uses its own name.
 
 The
 .code sys:capture-cont
@@ -27503,16 +27505,17 @@ with named prompts.
   (defmacro reset (name . body)
     ^(block ,name ,*body))
 
-  (defun shft-helper (name fun)
-    (let ((val (sys:capture-cont name 'shft)))
+  (defun shft-helper (name fun ctx)
+    (let ((val (sys:capture-cont name ctx)))
       (if (car val)
         (call fun (lambda (arg)
                     (call (cdr val) arg)))
         (cdr val))))
 
-  (defmacro shft (name var . body)
+  (defmacro shft (:form ctx name var . body)
     ^(shft-helper ',name
-       (lambda (,var) (return-from ,name ,*body))))
+       (lambda (,var) (return-from ,name ,*body))
+       ',ctx))
 
   ;; Usage:
   (reset foo (* 2 (shft foo k [k 3]) (shft foo l [l 4])))
diff --git a/unwind.c b/unwind.c
index 0202f4e4..fe3c68b6 100644
--- a/unwind.c
+++ b/unwind.c
@@ -51,6 +51,7 @@ static uw_frame_t *uw_exit_point;
 static uw_frame_t toplevel_env;
 
 static val unhandled_hook_s, types_s, jump_s, sys_cont_s;
+static val sys_capture_cont_s;
 
 static val frame_type, catch_frame_type, handle_frame_type;
 
@@ -746,7 +747,7 @@ static val capture_cont(val tag, uw_frame_t *block)
   return result;
 }
 
-val uw_capture_cont(val tag, val ctx)
+val uw_capture_cont(val tag, val ctx_form)
 {
   uw_frame_t *fr;
 
@@ -757,12 +758,13 @@ val uw_capture_cont(val tag, val ctx)
   }
 
   if (!fr) {
+    uses_or2;
+    val sym = or2(car(default_bool_arg(ctx_form)), sys_capture_cont_s);
+
     if (tag)
-      uw_throwf(error_s, lit("~s: no block ~s is visible"),
-                ctx, tag, nao);
+      eval_error(ctx_form, lit("~s: no block ~s is visible"), sym, tag, nao);
     else
-      uw_throwf(error_s, lit("~s: no anonymous block is visible"),
-                ctx, nao);
+      eval_error(ctx_form, lit("~s: no anonymous block is visible"), sym, nao);
     abort();
   }
 
@@ -812,5 +814,6 @@ 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));
+  reg_fun(sys_capture_cont_s = intern(lit("capture-cont"), system_package),
+          func_n2o(uw_capture_cont, 1));
 }
diff --git a/unwind.h b/unwind.h
index b2242661..a9b456ae 100644
--- a/unwind.h
+++ b/unwind.h
@@ -124,7 +124,7 @@ 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);
+val uw_capture_cont(val tag, val ctx_form);
 void uw_init(void);
 void uw_late_init(void);
 
-- 
cgit v1.2.3