Support multiple values for control proxy functions

collects/racket/contract/private/misc.rkt

@@ -946,19 +946,31 @@
 (define/final-prop none/c (make-none/c 'none/c))
 
 ;; prompt/c
-(define/subexpression-pos-prop (prompt/c ctc-arg)
+(define/subexpression-pos-prop (prompt/c . ctc-args)
-  (define ctc (coerce-contract 'prompt/c ctc-arg))
+  (define ctcs
-  (cond [(chaperone-contract? ctc) (chaperone-prompt/c ctc)]
+    (map (λ (ctc-arg)
-        [else (impersonator-prompt/c ctc)]))
+           (coerce-contract 'prompt/c ctc-arg))
+         ctc-args))
+  (cond [(andmap chaperone-contract? ctcs) (chaperone-prompt/c ctcs)]
+        [else (impersonator-prompt/c ctcs)]))
 
 (define (prompt/c-name ctc)
-  (build-compound-type-name 'prompt/c (base-prompt/c-ctc ctc)))
+  (apply build-compound-type-name
+         (cons 'prompt/c (base-prompt/c-ctcs ctc))))
 
 (define ((prompt/c-proj proxy) ctc)
-  (define ho-proj (contract-projection (base-prompt/c-ctc ctc)))
+  (define ho-projs (map contract-projection (base-prompt/c-ctcs ctc)))
   (λ (blame)
-    (define proj1 (ho-proj blame))
+    (define proj1
-    (define proj2 (ho-proj (blame-swap blame)))
+      (λ vs
+        (define vs2 (for/list ([proj ho-projs] [v vs])
+                      ((proj blame) v)))
+        (apply values vs2)))
+    (define proj2
+      (λ vs
+        (define vs2 (for/list ([proj ho-projs] [v vs])
+                      ((proj (blame-swap blame)) v)))
+        (apply values vs2)))
     (λ (val)
       (unless (contract-first-order-passes? ctc val)
         (raise-blame-error
@@ -973,10 +985,11 @@
 
 (define (prompt/c-stronger? this that)
   (and (base-prompt/c? that)
-       (contract-stronger? (base-prompt/c-ctc this)
+       (andmap (λ (this that) (contract-stronger? this that))
-                           (base-prompt/c-ctc that))))
+               (base-prompt/c-ctcs this)
+               (base-prompt/c-ctcs that))))
 
-(define-struct base-prompt/c (ctc))
+(define-struct base-prompt/c (ctcs))
 
 (define-struct (chaperone-prompt/c base-prompt/c) ()
   #:property prop:chaperone-contract

collects/tests/racket/contract-test.rktl

@@ -4144,6 +4144,28 @@
         (λ (pt) (abort-current-continuation pt (λ (v) (+ v 1))))))
    "B")
 
+  (test/neg-blame
+   'prompt/c-ho-6
+   '(let ([pt (contract (prompt/c string? number?)
+                        (make-continuation-prompt-tag)
+                        'pos
+                        'neg)])
+      (call-with-continuation-prompt
+        (λ () (abort-current-continuation pt 3 "bad"))
+        pt
+        (λ (x y) (values x y)))))
+
+  (test/spec-passed
+   'prompt/c-ho-7
+   '(let ([pt (contract (prompt/c string? number?)
+                        (make-continuation-prompt-tag)
+                        'pos
+                        'neg)])
+      (call-with-continuation-prompt
+        (λ () (abort-current-continuation pt "good" 5))
+        pt
+        (λ (x y) (values x y)))))
+
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;;  make-contract

collects/tests/racket/prompt.rktl

@@ -167,6 +167,24 @@
    (lambda (x) (* x 2))
    (lambda (x) (+ x 1))))
 
+(define imp-tag-2
+  (impersonate-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x y) (values (* x 2) (* y 2)))
+   (lambda (x y) (values (+ x 1) (+ y 1)))))
+
+(define imp-tag-3
+  (impersonate-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x y) (values (* x 2) (* y 2)))
+   (lambda (x y) x)))
+
+(define imp-tag-4
+  (impersonate-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x y) (values x x x))
+   (lambda (x y) (values x y))))
+
 (define cha-tag
   (chaperone-prompt-tag
    (make-continuation-prompt-tag)
@@ -179,15 +197,20 @@
    (lambda (x) 42)
    (lambda (x) x)))
 
-(define (do-test tag v)
+(define (do-test tag . rst)
   (call-with-continuation-prompt
     (lambda ()
-      (abort-current-continuation tag v))
+      (apply abort-current-continuation
+             (cons tag rst)))
     tag
-    (lambda (x) x)))
+    (lambda x x)))
 
-(test 12 do-test imp-tag 5)
+(test '(12) do-test imp-tag 5)
-(test 5 do-test cha-tag 5)
+(test '(12 14) do-test imp-tag-2 5 6)
+(err/rt-test (do-test imp-tag-2 5) exn:fail?)
+(err/rt-test (do-test imp-tag-3 10 11) exn:fail?)
+(err/rt-test (do-test imp-tag-4 10 11) exn:fail?)
+(test '(7) do-test cha-tag 7)
 (err/rt-test (do-test cha-tag "bad") exn:fail?)
 (err/rt-test (do-test bad-tag 5) exn:fail?)
 

src/racket/src/fun.c

@@ -5571,8 +5571,11 @@ Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, i
 
   if (!SCHEME_PROMPT_TAGP(val))
     scheme_wrong_contract(name, "prompt-tag?", 0, argc, argv);
-  scheme_check_proc_arity(name, 1, 1, argc, argv);
+
-  scheme_check_proc_arity(name, 1, 1, argc, argv);
+  if (!SCHEME_PROCP(argv[1]))
+    scheme_wrong_contract(name, "procedure?", 1, argc, argv);
+  if (!SCHEME_PROCP(argv[2]))
+    scheme_wrong_contract(name, "procedure?", 2, argc, argv);
 
   redirects = scheme_make_pair(argv[1], argv[2]);
 
@@ -6005,39 +6008,71 @@ static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
     prompt_unwind_dw(prompt_tag);
 }
 
-static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object *argv[])
+static Scheme_Object **chaperone_do_control(const char *name, int is_prompt, Scheme_Object *obj,
+                                            int argc, Scheme_Object **argv)
 {
   Scheme_Chaperone *px;
-  Scheme_Object *a[1];
-  Scheme_Object *v;
   Scheme_Object **vals;
-
+  Scheme_Object *v;
-  vals = MALLOC_N(Scheme_Object *, argc);
+  Scheme_Object *proc;
+  int i, num_args;
 
   while (1) {
-    int i;
     if (SCHEME_PROMPT_TAGP(obj)) {
       return vals;
     } else {
       px = (Scheme_Chaperone *)obj;
-
       obj = px->prev;
-      for (i = 0; i < argc; i++) {
+
-        a[0] = argv[i];
+      if (is_prompt)
-        v =  _scheme_apply(SCHEME_CAR(px->redirects), 1, a);
+        proc = SCHEME_CAR(px->redirects);
-        vals[i] = v;
+      else
+        proc = SCHEME_CDR(px->redirects);
+
+      v = _scheme_apply_multi(proc, argc, argv);
+
+      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;
+        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, vals[0], "application of proxy function");
+      else if (num_args != argc)
+        scheme_wrong_return_arity(name, argc, num_args, vals, "application of proxy function");
+
       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("call-with-continuation-prompt", "value", argv[i], vals[i]);
+            scheme_wrong_chaperoned(name, "value", argv[i], vals[i]);
+          argv[i] = vals[i];
         }
       }
     }
   }
 }
 
+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);
+}
+
+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);
+}
+
 static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 {
   Scheme_Object *v;
@@ -6069,6 +6104,9 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 
   scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
   if (in_argc > 1) {
+    /*
+     * Check if the prompt tag is proxied
+     */
     if (!SCHEME_PROMPT_TAGP(in_argv[1])) {
       if (SCHEME_NP_CHAPERONEP(in_argv[1])
           && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) {
@@ -6228,6 +6266,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
           } else
             argv = (Scheme_Object **)p->cjs.val;
 
+          /*
+           * If the prompt tag is proxied, run the intercession function
+           * and call the handler on its results
+           */
           if (is_chaperoned) {
             argv = chaperone_do_prompt_handler(in_argv[1], argc, argv);
           }
@@ -6467,51 +6509,19 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
   return value;
 }
 
-static Scheme_Object *chaperone_do_abort_one(Scheme_Object *obj, Scheme_Object *v)
-{
-  Scheme_Chaperone *px;
-  Scheme_Object *a[1];
-
-  while (1) {
-    if (SCHEME_PROMPT_TAGP(obj)) {
-      return v;
-    } else {
-      px = (Scheme_Chaperone *)obj;
-
-      obj = px->prev;
-      a[0] = v;
-      v = _scheme_apply(SCHEME_CDR(px->redirects), 1, a);
-
-      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
-        if (!scheme_chaperone_of(v, a[0]))
-          scheme_wrong_chaperoned("abort-current-continuation", "value", a[0], v);
-    }
-  }
-}
-
-static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int num_args, Scheme_Object *args[])
-{
-  Scheme_Object **vals;
-  Scheme_Object *v;
-  int i;
-  vals = MALLOC_N(Scheme_Object *, num_args);
-  for (i = 0; i < num_args; i++) {
-    v = chaperone_do_abort_one(obj, args[i]);
-    vals[i] = v;
-  }
-
-  return vals;
-}
-
 static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
 {
   Scheme_Object *prompt_tag;
   Scheme_Prompt *prompt;
   Scheme_Thread *p = scheme_current_thread;
-  Scheme_Object *val;
+  Scheme_Object *a[1];
+  Scheme_Object **vals;
   int is_chaperoned = 0;
 
   if (!SCHEME_PROMPT_TAGP(argv[0])) {
+    /*
+     * Check if the prompt tag is proxied
+     */
     if (SCHEME_NP_CHAPERONEP(argv[0])
         && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) {
         is_chaperoned = 1;
@@ -6537,14 +6547,19 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
 
   if (argc == 2) {
     p->cjs.num_vals = 1;
+    /*
+     * If the prompt tag isn't proxied, continue with the aborted value.
+     * Otherwise, run the intercession function and then continue with its
+     * new results.
+     */
     if (!is_chaperoned)
       p->cjs.val = argv[1];
     else {
-      val = chaperone_do_abort_one(argv[0], argv[1]);
+      a[0] = argv[1];
-      p->cjs.val = val;
+      vals = chaperone_do_abort(argv[0], 1, a);
+      p->cjs.val = (Scheme_Object *)vals[0];
     }
   } else {
-    Scheme_Object **vals;
     int i;
     vals = MALLOC_N(Scheme_Object *, argc - 1);
     for (i = argc; i-- > 1; ) {
@@ -6552,10 +6567,10 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
     }
     p->cjs.num_vals = argc - 1;
     if (!is_chaperoned)
-      p->cjs.val = (Scheme_Object *)vals;
+      p->cjs.val = (Scheme_Object **)vals;
     else {
-      val = chaperone_do_abort(argv[0], argc - 1, vals);
+      vals = chaperone_do_abort(argv[0], argc - 1, vals);
-      p->cjs.val = val;
+      p->cjs.val = (Scheme_Object **)vals;
     }
   }
   p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;