diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index d45d75d3..5b5a2d8e 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/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)))] diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-scheme/infer/promote-demote.rkt index 5d2daef8..334eecc7 100644 --- a/collects/typed-scheme/infer/promote-demote.rkt +++ b/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) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 1a92f30f..8054c0c0 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/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)] diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 84e29ede..8dbf20df 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/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)] diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index a8f395b5..c7cee8a1 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/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) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 49cf247a..a824bba0 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/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]) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 9585f9d4..a15c22c2 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/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)) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2b0d2c0b..23cee27b 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/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 diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index ccaaf720..d03769bb 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/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*))