Add channel chaperones

These chaperones only protect the "put" end of the
channel and use evt chaperones to protect the "get"
end.

pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl

@@ -14,7 +14,8 @@ An @deftech{impersonator} is a wrapper for a value where the wrapper
 redirects some of the value's operations. Impersonators apply only to procedures,
 @tech{structures} for which an accessor or mutator is available,
 @tech{structure types}, @tech{hash tables}, @tech{vectors},
-@tech{box}es, and @tech{prompt tag}s. An impersonator is @racket[equal?] to the original
+@tech{box}es, @tech{channels}, and @tech{prompt tag}s.
+An impersonator is @racket[equal?] to the original
 value, but not @racket[eq?] to the original value.
 
 A @deftech{chaperone} is a kind of impersonator whose refinement of a value's
@@ -45,6 +46,7 @@ the impersonator:
             unbox set-box!
             vector-ref vector-set!
             hash-ref hash-set hash-set! hash-remove hash-remove!
+            channel-get channel-put
             call-with-continuation-prompt
             abort-current-continuation]
 
@@ -350,6 +352,32 @@ to @racket[impersonate-hash] must be odd) add impersonator properties
 or override impersonator-property values of @racket[hash].}
 
 
+@defproc[(impersonate-channel [channel channel?]
+                              [get-proc (channel? . -> . (values channel? (any/c . -> . any/c)))]
+                              [put-proc (channel? any/c . -> . any/c)]
+                              [prop impersonator-property?]
+                              [prop-val any] ... ...)
+          (and/c channel? impersonator?)]{
+
+Returns an impersonator of @racket[channel], which redirects the
+@racket[channel-get] and @racket[channel-put] operations.
+
+The @racket[get-proc] generator is called on @racket[channel-get]
+or any other operation that fetches results from the channel (such
+as a @racket[sync] on the channel). The @racket[get-proc] must return
+two values: a @tech{channel} that is an impersonator of @racket[channel], and a
+procedure that is used to check the channel's contents.
+
+The @racket[put-proc] must accept @racket[channel] and the value passed to
+@racket[channel-put]; it must produce a replacement
+value, which is used with @racket[channel-put] on the original
+@racket[channel] to send the value over the channel.
+
+Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
+to @racket[impersonate-channel] must be odd) add impersonator properties
+or override impersonator-property values of @racket[channel].}
+
+
 @defproc[(impersonate-prompt-tag [prompt-tag continuation-prompt-tag?]
                                  [handle-proc procedure?]
                                  [abort-proc procedure?]
@@ -648,6 +676,31 @@ Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
 to @racket[chaperone-evt] must be even) add impersonator properties
 or override impersonator-property values of @racket[evt].}
 
+
+@defproc[(chaperone-channel [channel channel?]
+                            [get-proc (channel? . -> . (values channel? (any/c . -> . any/c)))]
+                            [put-proc (channel? any/c . -> . any/c)]
+                            [prop impersonator-property?]
+                            [prop-val any] ... ...)
+          (and/c channel? chaperone?)]{
+
+Like @racket[impersonate-channel], but with restrictions on the
+@racket[get-proc] and @racket[put-proc] procedures.
+
+The @racket[get-proc] must return two values: a @tech{channel}
+that is a chaperone of @racket[channel], and a procedure that
+is used to check the channel's contents. The latter procedure
+must return the original value or a chaperone of that value.
+
+The @racket[put-proc] must produce a replacement value that is
+either the original value communicated on the channel or a
+chaperone of that value.
+
+Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
+to @racket[chaperone-channel] must be odd) add impersonator properties
+or override impersonator-property values of @racket[channel].}
+
+
 @defproc[(chaperone-prompt-tag [prompt-tag continuation-prompt-tag?]
                                [handle-proc procedure?]
                                [abort-proc procedure?]

pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl

@@ -1119,6 +1119,54 @@
   (test #t chaperone-of? (chaperone-evt an-e void) an-e)
   (test 18 (chaperone-evt an-e void) 9))
 
+;; ----------------------------------------
+;; channel chaperones
+
+(let ([ch (make-channel)])
+  (test #t chaperone-of?/impersonator ch ch))
+(test #f chaperone-of? (make-channel) (make-channel))
+(test #f impersonator-of? (make-channel) (make-channel))
+(test #t chaperone?/impersonator (chaperone-channel (make-channel) (lambda (c) (values c values)) (lambda (c v) v)))
+(test #t channel? (chaperone-channel (make-channel) (lambda (c) (values c values)) (lambda (c v) v)))
+(let ([ch (make-channel)])
+  (test #t
+        chaperone-of?/impersonator
+        (chaperone-channel ch (lambda (c) (values c values)) (lambda (c v) v))
+        ch))
+(let ([ch (make-channel)])
+  (thread (lambda () (channel-put ch 3.14)))
+  (test 3.14 channel-get (chaperone-channel ch (lambda (c) (values c values)) (lambda (c v) v))))
+(let ([ch (make-channel)])
+  (thread (lambda () (channel-put ch 3.14)))
+  (test 2.71 channel-get (impersonate-channel ch (lambda (c) (values c (lambda (x) 2.71))) (lambda (c v) v))))
+(let ([ch (make-channel)])
+  (thread (lambda () (channel-put (impersonate-channel
+                                   ch
+                                   (lambda (c) (values c values))
+                                   (lambda (c v) 2.71))
+                                  3.14)))
+  (test 2.71 channel-get ch))
+(let ([ch (make-channel)])
+  (thread (lambda () (sync (channel-put-evt (impersonate-channel
+                                             ch
+                                             (lambda (c) (values c values))
+                                             (lambda (c v) 2.71))
+                                            3.14))))
+  (test 2.71 channel-get ch))
+
+(err/rt-test (chaperone-channel ch (lambda (c) (values c values)) (lambda (v) v)))
+(err/rt-test (chaperone-channel ch (lambda () (values 0 values)) (lambda (c v) v)))
+(err/rt-test (chaperone-channel ch (lambda () (values 0 values)) (lambda (c v) v)))
+(err/rt-test (chaperone-channel ch (lambda () (values 0 values))))
+(err/rt-test (chaperone-channel ch))
+(err/rt-test (chaperone-channel 5 (lambda (c) (values c values)) (lambda (c v) v)))
+(let ([ch (make-channel)])
+  (thread (lambda () (channel-put ch 3.14)))
+  (err/rt-test (channel-get (impersonate-channel ch (lambda (c) c) (lambda (c v) v)))))
+(let ([ch (make-channel)])
+  (thread (lambda () (channel-put ch 3.14)))
+  (err/rt-test (channel-get (chaperone-channel ch (lambda (c) (values c (lambda (x) 2.71))) (lambda (c v) v)))))
+
 ;; ----------------------------------------
 
 (let ()

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1114
+#define EXPECTED_PRIM_COUNT 1116
 #define EXPECTED_UNSAFE_COUNT 100
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -1851,6 +1851,8 @@ Scheme_Object *scheme_make_sema_repost(Scheme_Object *sema);
 Scheme_Object *scheme_wrap_evt(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_poll_evt(int argc, Scheme_Object *argv[]);
 
+Scheme_Object *scheme_do_chaperone_evt(const char*, int, int, Scheme_Object *argv[]);
+
 extern Scheme_Object *scheme_always_ready_evt;
 
 void scheme_get_outof_line(Scheme_Channel_Syncer *ch_w);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.90.0.9"
+#define MZSCHEME_VERSION "5.90.0.10"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 90
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 9
+#define MZSCHEME_VERSION_W 10
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/sema.c

@@ -39,6 +39,8 @@ static Scheme_Object *make_channel(int n, Scheme_Object **p);
 static Scheme_Object *make_channel_put(int n, Scheme_Object **p);
 static Scheme_Object *channel_p(int n, Scheme_Object **p);
 static Scheme_Object *channel_put_p(int n, Scheme_Object **p);
+static Scheme_Object *chaperone_channel(int argc, Scheme_Object *argv[]);
+static Scheme_Object *impersonate_channel(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *thread_send(int n, Scheme_Object **p);
 static Scheme_Object *thread_receive(int n, Scheme_Object **p);
@@ -154,6 +156,16 @@ void scheme_init_sema(Scheme_Env *env)
                                                       "channel-put-evt?",
                                                       1, 1, 1), 
 			     env);
+  scheme_add_global_constant("chaperone-channel",
+			     scheme_make_prim_w_arity(chaperone_channel,
+                                                      "chaperone-channel",
+                                                      3, -1),
+			     env);
+  scheme_add_global_constant("impersonate-channel",
+			     scheme_make_prim_w_arity(impersonate_channel,
+                                                      "impersonate-channel",
+                                                      3, -1),
+			     env);
 
   scheme_add_global_constant("thread-send", 
 			     scheme_make_prim_w_arity(thread_send,
@@ -1042,17 +1054,62 @@ int scheme_try_channel_put(Scheme_Object *ch, Scheme_Object *v)
     return 0;
 }
 
+Scheme_Object *chaperone_put(Scheme_Object *obj, Scheme_Object *orig)
+{
+  Scheme_Chaperone *px = (Scheme_Chaperone *)obj;
+  Scheme_Object *val = orig;
+  Scheme_Object *a[2];
+  Scheme_Object *redirect;
+
+  while (1) {
+    if (SCHEME_CHANNELP(px)) {
+      return val;
+    } else if (!(SAME_TYPE(SCHEME_TYPE(px->redirects), scheme_nack_guard_evt_type))) {
+      a[0] = px->prev;
+      a[1] = val;
+      redirect = px->redirects;
+      val = _scheme_apply(redirect, 2, a);
+
+      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
+        if (!scheme_chaperone_of(val, orig))
+          scheme_wrong_chaperoned("channel-put", "result", orig, val);
+
+      px = (Scheme_Chaperone *)px->prev;
+    } else {
+      /* In this case, the `px` is actually an evt chaperone so we
+         don't want to handle it here since we're doing a "put" */
+      px = (Scheme_Chaperone *)px->prev;
+    }
+  }
+
+  return obj;
+}
+
 static Scheme_Object *make_channel_put(int argc, Scheme_Object **argv)
 {
-  if (!SCHEME_CHANNELP(argv[0]))
-    scheme_wrong_contract("channel-put-evt", "channel?", 0, argc, argv);
+  Scheme_Object *ch = argv[0];
+  Scheme_Object *val = argv[1];
+  Scheme_Object *chaperone = NULL;
 
-  return scheme_make_channel_put_evt(argv[0], argv[1]);
+  if (SCHEME_NP_CHAPERONEP(ch)
+      && SCHEME_CHANNELP(SCHEME_CHAPERONE_VAL(ch))) {
+    chaperone = ch;
+    ch = SCHEME_CHAPERONE_VAL(chaperone);
+  } else if (!SCHEME_CHANNELP(argv[0])) {
+    scheme_wrong_contract("channel-put-evt", "channel?", 0, argc, argv);
+  }
+
+  if (chaperone)
+    val = chaperone_put(chaperone, argv[1]);
+
+  return scheme_make_channel_put_evt(ch, val);
 }
 
 static Scheme_Object *channel_p(int n, Scheme_Object **p)
 {
-  return (SCHEME_CHANNELP(p[0])
+  return ((SCHEME_CHANNELP(p[0]) ||
+           (SCHEME_NP_CHAPERONEP(p[0])
+            && SCHEME_CHANNELP(SCHEME_CHAPERONE_VAL(p[0]))))
 	  ? scheme_true
 	  : scheme_false);
 }
@@ -1109,6 +1166,51 @@ int scheme_try_channel_get(Scheme_Object *ch)
   return 0;
 }
 
+/* This chaperone only protects the "put" end of the channel because
+   chaperone-evt is sufficient to protect the "get" end. Thus, it first
+   wraps the object in an evt chaperone. */
+Scheme_Object *do_chaperone_channel(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
+{
+  Scheme_Chaperone *px;
+  Scheme_Object *val = argv[0];
+  Scheme_Object *evt;
+  Scheme_Hash_Tree *props;
+
+  if (SCHEME_CHAPERONEP(val))
+    val = SCHEME_CHAPERONE_VAL(val);
+
+  if (!SCHEME_CHANNELP(val))
+    scheme_wrong_contract(name, "channel?", 0, argc, argv);
+  scheme_check_proc_arity(name, 1, 1, argc, argv);
+  scheme_check_proc_arity(name, 2, 2, argc, argv);
+
+  evt = scheme_do_chaperone_evt(name, is_impersonator, 2, argv);
+
+  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 = evt;
+  px->props = props;
+  px->redirects = argv[2];
+
+  if (is_impersonator)
+    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
+
+  return (Scheme_Object *)px;
+}
+
+static Scheme_Object *chaperone_channel(int argc, Scheme_Object **argv)
+{
+  return do_chaperone_channel("chaperone-channel", 0, argc, argv);
+}
+
+static Scheme_Object *impersonate_channel(int argc, Scheme_Object **argv)
+{
+  return do_chaperone_channel("impersonator-channel", 1, argc, argv);
+}
+
 /**********************************************************************/
 /*                           Thread mbox                              */
 /**********************************************************************/

racket/src/racket/src/struct.c

@@ -3450,7 +3450,7 @@ static Scheme_Object *impersonator_guard_proc(void *data, int argc, Scheme_Objec
   return do_chaperone_guard_proc(1, data, argc, argv);
 }
 
-static Scheme_Object *do_chaperone_evt(const char *name, int is_impersonator, int argc, Scheme_Object *argv[])
+Scheme_Object *scheme_do_chaperone_evt(const char *name, int is_impersonator, int argc, Scheme_Object *argv[])
 {
   Scheme_Chaperone *px;
   Scheme_Object *o, *val, *a[1];
@@ -3496,7 +3496,7 @@ static Scheme_Object *do_chaperone_evt(const char *name, int is_impersonator, in
 
 static Scheme_Object *chaperone_evt(int argc, Scheme_Object *argv[])
 {
-  return do_chaperone_evt("chaperone-evt", 0, argc, argv);
+  return scheme_do_chaperone_evt("chaperone-evt", 0, argc, argv);
 }
 
 static int chaperone_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)