Added Channel types.

original commit: ec799fb208197df8b2f4cafc0b0af3aad423871a

collects/typed-scheme/infer/infer-unit.rkt

@@ -414,6 +414,8 @@
            (cset-meet (cg e e*) (cg e* e))]
           [((Box: e) (Box: e*))
            (cset-meet (cg e e*) (cg e* e))]
+          [((Channel: e) (Channel: e*))
+           (cset-meet (cg e e*) (cg e* e))]
           [((Hashtable: s1 s2) (Hashtable: t1 t2))
            ;; for mutable hash tables, both are invariant
            (cset-meet* (list (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2)))]

collects/typed-scheme/infer/promote-demote.rkt

@@ -25,6 +25,7 @@
              [#:F name (if (memq name V) Univ T)]
              [#:Vector t (make-Vector (inv t))]
              [#:Box t (make-Box (inv t))]
+             [#:Channel t (make-Channel (inv t))]
              [#:Hashtable k v
                           (if (V-in? V v)
                               Univ
@@ -58,6 +59,7 @@
              [#:F name (if (memq name V) (Un) T)]
              [#:Vector t (make-Vector (inv t))]
              [#:Box t (make-Box (inv t))]
+             [#:Channel t (make-Channel (inv t))]
              [#:Hashtable k v
                           (if (V-in? V v)
                               (Un)

collects/typed-scheme/private/base-env.rkt

@@ -16,7 +16,7 @@
  (only-in mzscheme make-namespace)
  (only-in racket/match/runtime match:error matchable? match-equality-test)
  (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])
-             (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-VectorTop)))
+             (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop)))
 
 [raise (Univ . -> . (Un))]
 [raise-syntax-error (cl->* 
@@ -207,6 +207,12 @@
 [empty? (make-pred-ty (-val null))]
 [empty (-val null)]
 
+[make-channel (-poly (a) (-> (-channel a)))]
+[channel? (make-pred-ty (make-ChannelTop))]
+[channel-get (-poly (a) ((-channel a) . -> . a))]
+[channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))]
+[channel-put (-poly (a) ((-channel a) a . -> . -Void))]
+
 [string? (make-pred-ty -String)]
 [string (->* '() -Char -String)]
 [string-length (-String . -> . -Nat)]

collects/typed-scheme/private/base-types-new.rkt

@@ -43,6 +43,7 @@
 [Promise (-poly (a) (-Promise a))]
 [Pair (-poly (a b) (-pair a b))]
 [Boxof (-poly (a) (make-Box a))]
+[Channelof (-poly (a) (make-Channel a))]
 [Continuation-Mark-Set -Cont-Mark-Set]
 [False (-val #f)]
 [True (-val #t)]

collects/typed-scheme/private/type-contract.rkt

@@ -126,6 +126,8 @@
          #`(vectorof #,(t->c t))]
         [(Box: t)
          #`(box/c #,(t->c t))]
+        [(Channel: t)
+         #`(channel/c #,(t->c t))]
         [(Pair: t1 t2)
          #`(cons/c #,(t->c t1) #,(t->c t2))]
         [(Opaque: p? cert)

collects/typed-scheme/rep/type-rep.rkt

@@ -84,7 +84,11 @@
 
 ;; elem is a Type
 (dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
-    [#:key 'box])  
+    [#:key 'box])
+
+;; elem is a Type
+(dt Channel ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
+    [#:key 'channel])
 
 ;; name is a Symbol (not a Name)
 (dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name]
@@ -247,6 +251,7 @@
 
 ;; the supertype of all of these values
 (dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
+(dt ChannelTop () [#:fold-rhs #:base] [#:key 'channel])
 (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])
 (dt HashtableTop () [#:fold-rhs #:base] [#:key 'hash])
 (dt MPairTop () [#:fold-rhs #:base] [#:key 'mpair])

collects/typed-scheme/types/abbrev.rkt

@@ -26,6 +26,7 @@
 (define -val make-Value)
 (define -Param make-Param)
 (define -box make-Box)
+(define -channel make-Channel)
 (define -vec make-Vector)
 (define (-seq . args) (make-Sequence args))
 

collects/typed-scheme/types/printer.rkt

@@ -123,6 +123,7 @@
      (fp "~a" name)]
     [(StructTop: st) (fp "~a" st)]
     [(BoxTop:) (fp "Box")]
+    [(ChannelTop:) (fp "Channel")]
     [(VectorTop:) (fp "Vector")]
     [(MPairTop:) (fp "MPair")]
     ;; names are just the printed as the original syntax
@@ -165,6 +166,7 @@
                                (fp " ~a" i))
                              (fp ")")]
     [(Box: e) (fp "(Boxof ~a)" e)]
+    [(Channel: e) (fp "(Channelof ~a)" e)]
     [(Union: elems) (fp "~a" (cons 'U elems))]
     [(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
     [(F: nm) (fp "~a" nm)]   
@@ -195,7 +197,8 @@
                               (Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var)))))
                               (Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y)))))
                               (Vector: (F: x))
-                              (Box: (F: x))))))
+                              (Box: (F: x))
+                              (Channel: (F: x))))))
      (fp "Syntax")]
     [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)]
     ;; FIXME - this should not be used

collects/typed-scheme/types/subtype.rkt

@@ -335,6 +335,7 @@
               [((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s)))))
                A0]
               [((Box: _) (BoxTop:)) A0]
+              [((Channel: _) (ChannelTop:)) A0]
               [((Vector: _) (VectorTop:)) A0]
               [((HeterogenousVector: _) (VectorTop:)) A0]
               [((HeterogenousVector: (list e ...)) (Vector: e*))