add an argument to `{chaperone,impersonate}-prompt-tag'

The new argument gets to filter results that come from a
non-composable continuation that replaces one delimited
by a prompt using the chaperoned/impersonated prompt tag.

collects/scribblings/reference/chaperones.scrbl

@@ -333,6 +333,7 @@ or override impersonator-property values of @racket[hash].}
 @defproc[(impersonate-prompt-tag [prompt-tag continuation-prompt-tag?]
                                  [handle-proc procedure?]
                                  [abort-proc procedure?]
+                                 [callcc-guard-proc procedure? values]
                                  [prop impersonator-property?]
                                  [prop-val any] ... ...)
           (and/c continuation-prompt-tag? impersonator?)]{
@@ -349,6 +350,14 @@ The @racket[abort-proc] must accept the values passed to
 @racket[abort-current-continuation]; it must produce replacement
 values, which are aborted to the appropriate prompt.
 
+The @racket[callcc-guard-proc] must accept the values produced by
+@racket[call-with-continuation-prompt] in the case that a
+non-composable continuation is applied to replace the continuation
+that is delimited by the prompt, but only if
+@racket[abort-current-continuation] is not later used to abort the
+continuation delimited by the prompt (in which case
+@racket[abort-proc] is used).
+
 Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
 to @racket[impersonate-prompt-tag] must be odd) add impersonator properties
 or override impersonator-property values of @racket[prompt-tag].
@@ -604,14 +613,17 @@ or override impersonator-property values of @racket[evt].}
 @defproc[(chaperone-prompt-tag [prompt-tag continuation-prompt-tag?]
                                [handle-proc procedure?]
                                [abort-proc procedure?]
+                               [callcc-guard-proc procedure? values]
                                [prop impersonator-property?]
                                [prop-val any] ... ...)
           (and/c continuation-prompt-tag? chaperone?)]{
 
 Like @racket[impersonate-prompt-tag], but produces a chaperoned value.
 The @racket[handle-proc] procedure must produce the same values or
-chaperones of the original values, and @racket[abort-proc] must produce
+chaperones of the original values, @racket[abort-proc] must produce
-the same values or chaperones of the values that it is given.
+the same values or chaperones of the values that it is given, and
+@racket[callcc-guard--proc] must produce
+the same values or chaperones of the original result values.
 
 @examples[
   (define bad-chaperone

collects/tests/racket/prompt.rktl

@@ -242,6 +242,48 @@
         imp-tag)))
   imp-tag)
 
+(let ()
+  (define abort-k
+    (call-with-continuation-prompt
+     (lambda ()
+       (call/cc (lambda (k) k)))))
+
+  (test
+   "sx"
+   call-with-continuation-prompt
+   (lambda ()
+     (+ 1 (abort-k "s")))
+   (impersonate-prompt-tag (default-continuation-prompt-tag)
+                           values
+                           values
+                           (lambda (s) (string-append s "x"))))
+
+  (test-values
+   '("st" "")
+   (lambda ()
+     (call-with-continuation-prompt
+      (lambda ()
+        (+ 1 (abort-k "s" "t")))
+      (impersonate-prompt-tag (default-continuation-prompt-tag)
+                              values
+                              values
+                              (lambda (s t) (values (string-append s t) ""))))))
+
+  (let ([v (vector 1)])
+    (test
+     #t
+     chaperone-of?
+     (call-with-continuation-prompt
+      (lambda ()
+        (+ 1 (abort-k v)))
+      (chaperone-prompt-tag (default-continuation-prompt-tag)
+                            values
+                            values
+                            (lambda (v) (chaperone-vector v 
+                                                          (lambda (x i v) v)
+                                                          (lambda (x i v) v)))))
+     v)))
+
 ;;----------------------------------------
 
 (report-errs)

src/racket/src/eval.c

@@ -1590,6 +1590,9 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
 
     scheme_continuation_application_count++;
 
+    if (prompt)
+      prompt->needs_cc_guard = 1;
+
     if (!prompt) {
       /* Invoke the continuation directly. If there's no prompt,
          then the prompt's job is taken by the pseudo-prompt

src/racket/src/fun.c

@@ -5745,6 +5745,7 @@ Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, i
   Scheme_Object *val = argv[0];
   Scheme_Object *redirects;
   Scheme_Hash_Tree *props;
+  int ppos;
 
   if (SCHEME_CHAPERONEP(val))
     val = SCHEME_CHAPERONE_VAL(val);
@@ -5757,9 +5758,19 @@ Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, i
   if (!SCHEME_PROCP(argv[2]))
     scheme_wrong_contract(name, "procedure?", 2, argc, argv);
 
-  redirects = scheme_make_pair(argv[1], argv[2]);
+  redirects = argv[2];
 
-  props = scheme_parse_chaperone_props(name, 3, argc, argv);
+  if ((argc > 3) && !SCHEME_CHAPERONEP(argv[3])) {
+    if (!SCHEME_PROCP(argv[3]))
+      scheme_wrong_contract(name, "(or/c procedure? impersonator-property?)", 3, argc, argv);
+    redirects = scheme_make_pair(redirects, argv[3]);
+    ppos = 4;
+  } else
+    ppos = 3;
+    
+  redirects = scheme_make_pair(argv[1], redirects);
+
+  props = scheme_parse_chaperone_props(name, ppos, argc, argv);
 
   px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
   px->iso.so.type = scheme_chaperone_type;
@@ -6188,7 +6199,7 @@ static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
     prompt_unwind_dw(prompt_tag);
 }
 
-static Scheme_Object **chaperone_do_control(const char *name, int is_prompt, Scheme_Object *obj,
+static Scheme_Object **chaperone_do_control(const char *name, int mode, Scheme_Object *obj,
                                             int argc, Scheme_Object **argv)
 {
   Scheme_Chaperone *px;
@@ -6204,39 +6215,51 @@ static Scheme_Object **chaperone_do_control(const char *name, int is_prompt, Sch
       px = (Scheme_Chaperone *)obj;
       obj = px->prev;
 
-      if (is_prompt)
+      if (!mode)
         proc = SCHEME_CAR(px->redirects);
-      else
+      else {
         proc = SCHEME_CDR(px->redirects);
-
+        if (mode == 1) {
-      v = _scheme_apply_multi(proc, argc, argv);
+          if (SCHEME_PAIRP(proc))
-
+            proc = SCHEME_CAR(proc);
-      if (v == SCHEME_MULTIPLE_VALUES) {
+        } else {
-        GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
+          if (SCHEME_PAIRP(proc))
-        if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
+            proc = SCHEME_CDR(proc);
-          p->values_buffer = NULL;
+          else
-        num_args = p->ku.multiple.count;
+            proc = NULL;
-        vals = p->ku.multiple.array;
+        }
-      } else {
-        num_args = 1;
-        vals = MALLOC_N(Scheme_Object *, 1);
-        vals[0] = v;
       }
 
-      /*
+      if (proc) {
-       * All kinds of proxies should return the same number of results
+        v = _scheme_apply_multi(proc, argc, argv);
-       * as the number of aborted values
-       */
-      if (num_args == 1 && num_args != argc)
-        scheme_wrong_return_arity(name, argc, 1, (Scheme_Object **)(vals[0]), "use of redirecting procedure");
-      else if (num_args != argc)
-        scheme_wrong_return_arity(name, argc, num_args, vals, "use of redirecting procedure");
 
-      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
+        if (v == SCHEME_MULTIPLE_VALUES) {
-        for (i = 0; i < argc; i++) {
+          GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
-          if (!scheme_chaperone_of(vals[i], argv[i]))
+          if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
-            scheme_wrong_chaperoned(name, "value", argv[i], vals[i]);
+            p->values_buffer = NULL;
-          argv[i] = vals[i];
+          num_args = p->ku.multiple.count;
+          vals = p->ku.multiple.array;
+        } else {
+          num_args = 1;
+          vals = MALLOC_N(Scheme_Object *, 1);
+          vals[0] = v;
+        }
+
+        /*
+         * All kinds of proxies should return the same number of results
+         * as the number of aborted values
+         */
+        if (num_args == 1 && num_args != argc)
+          scheme_wrong_return_arity(name, argc, 1, (Scheme_Object **)(vals[0]), "use of redirecting procedure");
+        else if (num_args != argc)
+          scheme_wrong_return_arity(name, argc, num_args, vals, "use of redirecting procedure");
+
+        if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
+          for (i = 0; i < argc; i++) {
+            if (!scheme_chaperone_of(vals[i], argv[i]))
+              scheme_wrong_chaperoned(name, "value", argv[i], vals[i]);
+            argv[i] = vals[i];
+          }
         }
       }
     }
@@ -6245,12 +6268,17 @@ static Scheme_Object **chaperone_do_control(const char *name, int is_prompt, Sch
 
 static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object **argv)
 {
-    return chaperone_do_control("call-with-continuation-prompt", 1, obj, argc, argv);
+    return chaperone_do_control("call-with-continuation-prompt", 0, obj, argc, argv);
 }
 
 static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int argc, Scheme_Object **argv)
 {
-    return chaperone_do_control("abort-current-continuation", 0, obj, argc, argv);
+    return chaperone_do_control("abort-current-continuation", 1, obj, argc, argv);
+}
+
+static Scheme_Object **chaperone_do_cc_guard(Scheme_Object *obj, int argc, Scheme_Object **argv)
+{
+    return chaperone_do_control("call-with-continuation-prompt", 2, obj, argc, argv);
 }
 
 static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
@@ -6265,7 +6293,8 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
   Scheme_Cont_Frame_Data cframe;
   Scheme_Dynamic_Wind *prompt_dw;
   int cc_count = scheme_cont_capture_count;
-  int is_chaperoned = 0;
+  Scheme_Object *chaperone = NULL;
+  int needs_cc_guard = 0;
 
   argc = in_argc - 3;
   if (argc <= 0) {
@@ -6288,7 +6317,7 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
     if (!SCHEME_PROMPT_TAGP(in_argv[1])) {
       if (SCHEME_NP_CHAPERONEP(in_argv[1])
           && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) {
-        is_chaperoned = 1;
+        chaperone = in_argv[1];
         prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
       } else {
         scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
@@ -6437,6 +6466,9 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
            delivered a value. */
 
         if (!v) {
+          prompt->needs_cc_guard = 0;
+          needs_cc_guard = 0; /* cancel any pending check */
+
           argc = p->cjs.num_vals;
 
           if (argc == 1) {
@@ -6445,16 +6477,16 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
           } else
             argv = (Scheme_Object **)p->cjs.val;
 
+          reset_cjs(&p->cjs);
+
           /*
            * If the prompt tag is proxied, run the intercession function
            * and call the handler on its results
            */
-          if (is_chaperoned) {
+          if (chaperone) {
-            argv = chaperone_do_prompt_handler(in_argv[1], argc, argv);
+            argv = chaperone_do_prompt_handler(chaperone, argc, argv);
           }
 
-          reset_cjs(&p->cjs);
-
           if (SAME_OBJ(handler, scheme_values_func)) {
             v = scheme_values(argc, argv);
             handler = NULL;
@@ -6499,6 +6531,9 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 
     scheme_pop_continuation_frame(&cframe);
 
+    if (prompt->needs_cc_guard)
+      needs_cc_guard = 1;
+
     if (cc_count == scheme_cont_capture_count) {
       if (!available_regular_prompt) {
         memset(prompt, 0, sizeof(Scheme_Prompt));
@@ -6526,6 +6561,23 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 
   if (handler) {
     return _scheme_tail_apply(handler, argc, argv);
+  } else if (needs_cc_guard && chaperone) {
+    if (v == SCHEME_MULTIPLE_VALUES) {
+      GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
+      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
+        p->values_buffer = NULL;
+      argc = p->ku.multiple.count;
+      argv = p->ku.multiple.array;
+    } else {
+      a[0] = v;
+      argv = a;
+      argc = 1;
+    }
+    argv = chaperone_do_cc_guard(chaperone, argc, argv);
+    if (argc == 1)
+      return argv[0];
+    else
+      return scheme_values(argc, argv);
   } else
     return v;
 }

src/racket/src/schpriv.h

@@ -1647,7 +1647,7 @@ typedef struct Scheme_Meta_Continuation {
 
 typedef struct Scheme_Prompt {
   Scheme_Object so;
-  char is_barrier;
+  char is_barrier, needs_cc_guard;
   Scheme_Object *tag;
   Scheme_Object *id;                  /* created as needed; allows direct-jump optimization for cont app */
   void *stack_boundary;               /* where to stop copying the C stack */