Prototype implementation of control proxies

collects/tests/racket/prompt.rktl

@@ -158,6 +158,39 @@
     (reset (loop 50000)))
   (test (void) overflow-prompt-go))
 
+;; ----------------------------------------
+;; control proxies
+
+(define imp-tag
+  (impersonate-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x) (* x 2))
+   (lambda (x) (+ x 1))))
+
+(define cha-tag
+  (chaperone-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x) (if (number? x) x (error "fail")))
+   (lambda (x) x)))
+
+(define bad-tag
+  (chaperone-prompt-tag
+   (make-continuation-prompt-tag)
+   (lambda (x) 42)
+   (lambda (x) x)))
+
+(define (do-test tag v)
+  (call-with-continuation-prompt
+    (lambda ()
+      (abort-current-continuation tag v))
+    tag
+    (lambda (x) x)))
+
+(test 12 do-test imp-tag 5)
+(test 5 do-test cha-tag 5)
+(err/rt-test (do-test cha-tag "bad") exn:fail?)
+(err/rt-test (do-test bad-tag 5) exn:fail?)
+
 ;;----------------------------------------
 
 (report-errs)

src/racket/include/scheme.h

@@ -450,6 +450,8 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
 #define SCHEME_MUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
 #define SCHEME_IMMUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
 
+#define SCHEME_PROMPT_TAGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
+
 #define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
 #define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
 #define SCHEME_HASHTRP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_tree_type)

src/racket/src/fun.c

@@ -139,6 +139,8 @@ static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[]);
 static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[]);
 static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[]);
 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[]);
+static Scheme_Object *impersonate_prompt_tag (int argc, Scheme_Object *argv[]);
+static Scheme_Object *chaperone_prompt_tag (int argc, Scheme_Object *argv[]);
 static Scheme_Object *call_with_sema (int argc, Scheme_Object *argv[]);
 static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
 static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]);
@@ -369,6 +371,16 @@ scheme_init_fun (Scheme_Env *env)
 						      "continuation-prompt-tag?",
 						      1, 1, 1),
                              env);
+  scheme_add_global_constant("impersonate-prompt-tag",
+                             scheme_make_prim_w_arity(impersonate_prompt_tag,
+						      "impersonate-prompt-tag",
+						      3, -1),
+                             env);
+  scheme_add_global_constant("chaperone-prompt-tag",
+                             scheme_make_prim_w_arity(chaperone_prompt_tag,
+						      "chaperone-prompt-tag",
+						      3, -1),
+                             env);
 
   scheme_add_global_constant("call-with-semaphore",
 			     scheme_make_prim_w_arity2(call_with_sema,
@@ -5542,11 +5554,53 @@ static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[])
 
 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[])
 {
-  return (SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))
+  return (SCHEME_CHAPERONE_PROMPT_TAGP(argv[0])
           ? scheme_true
           : scheme_false);
 }
 
+Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
+{
+  Scheme_Chaperone *px;
+  Scheme_Object *val = argv[0];
+  Scheme_Object *redirects;
+  Scheme_Hash_Tree *props;
+
+  if (SCHEME_CHAPERONEP(val))
+    val = SCHEME_CHAPERONE_VAL(val);
+
+  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);
+
+  redirects = scheme_make_pair(argv[1], argv[2]);
+
+  props = scheme_parse_chaperone_props(name, 3, argc, argv);
+
+  px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
+  px->iso.so.type = scheme_chaperone_type;
+  px->val = val;
+  px->prev = argv[0];
+  px->props = props;
+  px->redirects = redirects;
+
+  if (is_impersonator)
+    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
+
+  return (Scheme_Object *)px;
+}
+
+static Scheme_Object *chaperone_prompt_tag(int argc, Scheme_Object **argv)
+{
+  return do_chaperone_prompt_tag("chaperone-prompt-tag", 0, argc, argv);
+}
+
+static Scheme_Object *impersonate_prompt_tag(int argc, Scheme_Object **argv)
+{
+  return do_chaperone_prompt_tag("impersonate-prompt-tag", 1, argc, argv);
+}
+
 Scheme_Overflow *scheme_get_thread_end_overflow(void)
 {
   Scheme_Overflow *overflow;
@@ -5951,6 +6005,39 @@ 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[])
+{
+  Scheme_Chaperone *px;
+  Scheme_Object *a[1];
+  Scheme_Object *v;
+  Scheme_Object **vals;
+
+  vals = MALLOC_N(Scheme_Object *, argc);
+
+  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];
+        v =  _scheme_apply(SCHEME_CAR(px->redirects), 1, a);
+        vals[i] = v;
+      }
+
+      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]);
+        }
+      }
+    }
+  }
+}
+
 static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
 {
   Scheme_Object *v;
@@ -5963,6 +6050,7 @@ 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;
 
   argc = in_argc - 3;
   if (argc <= 0) {
@@ -5981,10 +6069,16 @@ 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) {
-    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) {
+    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;
+        prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
+      }
+      else
         scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
                           1, in_argc, in_argv);
-    }
+    } else
       prompt_tag = in_argv[1];
   } else
     prompt_tag = scheme_default_prompt_tag;
@@ -6134,6 +6228,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
           } else
             argv = (Scheme_Object **)p->cjs.val;
 
+          if (is_chaperoned) {
+            argv = chaperone_do_prompt_handler(in_argv[1], argc, argv);
+          }
+
           reset_cjs(&p->cjs);
 
           if (SAME_OBJ(handler, scheme_values_func)) {
@@ -6369,17 +6467,61 @@ 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;
+  int is_chaperoned = 0;
 
-  prompt_tag = argv[0];
+  if (!SCHEME_PROMPT_TAGP(argv[0])) {
-  if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
+    if (SCHEME_NP_CHAPERONEP(argv[0])
+        && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) {
+        is_chaperoned = 1;
+        prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
+    }
+    else
       scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
                         0, argc, argv);
-  }
+  } else
+    prompt_tag = argv[0];
 
   prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
   if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
@@ -6395,7 +6537,12 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
 
   if (argc == 2) {
     p->cjs.num_vals = 1;
+    if (!is_chaperoned)
       p->cjs.val = argv[1];
+    else {
+      val = chaperone_do_abort_one(argv[0], argv[1]);
+      p->cjs.val = val;
+    }
   } else {
     Scheme_Object **vals;
     int i;
@@ -6404,7 +6551,12 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
       vals[i-1] = argv[i];
     }
     p->cjs.num_vals = argc - 1;
+    if (!is_chaperoned)
       p->cjs.val = (Scheme_Object *)vals;
+    else {
+      val = chaperone_do_abort(argv[0], argc - 1, vals);
+      p->cjs.val = val;
+    }
   }
   p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
   p->cjs.alt_full_continuation = NULL;

src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1058
+#define EXPECTED_PRIM_COUNT 1060
 #define EXPECTED_UNSAFE_COUNT 79
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_FUTURES_COUNT 13

src/racket/src/schpriv.h

@@ -883,6 +883,8 @@ typedef struct Scheme_Chaperone {
                                        || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj))))
 #define SCHEME_CHAPERONE_BUCKTP(obj) (SCHEME_BUCKTP(obj) \
                                       || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj))))
+#define SCHEME_CHAPERONE_PROMPT_TAGP(obj) (SCHEME_PROMPT_TAGP(obj) \
+                                           || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(obj))))
 
 Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
 void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.0.10"
+#define MZSCHEME_VERSION "5.3.0.11"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 10
+#define MZSCHEME_VERSION_W 11
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)