diff --git a/collects/tests/typed-scheme/succeed/ephemerons.rkt b/collects/tests/typed-scheme/succeed/ephemerons.rkt new file mode 100644 index 00000000..729ab557 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/ephemerons.rkt @@ -0,0 +1,14 @@ +#lang typed/scheme + +(define key (gensym)) + +(: eph-one (Ephemeronof Integer)) +(define eph-one (make-ephemeron key 1)) + +(ephemeron? eph-one) + +(ephemeron-value eph-one) + +(: get-number ((Ephemeronof Number) -> Number)) +(define (get-number e) + (ephemeron-value e)) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 73d77031..51c3ce68 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -495,6 +495,8 @@ (cset-meet* (list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] [((Channel: e) (Channel: e*)) (cset-meet (cg e e*) (cg e* e))] + [((Ephemeron: e) (Ephemeron: e*)) + (cg e e*)] ;; we assume all HTs are mutable at the moment [((Hashtable: s1 s2) (Hashtable: t1 t2)) ;; for mutable hash tables, both are invariant diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 5650eca9..f8417f48 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -25,6 +25,8 @@ (only-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym]) (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop + make-EphemeronTop + make-Ephemeron make-HeterogenousVector)) [raise (Univ . -> . (Un))] @@ -1027,4 +1029,11 @@ (-> -Compiled-Module-Expression (-opt (make-HeterogenousVector (list -Module-Path -Symbol Univ))))] -[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))] \ No newline at end of file +[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))] + + +;ephemerons +[make-ephemeron (-poly (k v) (-> k v (make-Ephemeron v)))] +[ephemeron? (make-pred-ty (make-EphemeronTop))] +[ephemeron-value (-poly (v) (-> (make-Ephemeron v) (Un (-val #f) v)))] + diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 161a255e..6f81bf66 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -111,6 +111,7 @@ [Pair (-poly (a b) (-pair a b))] [Boxof (-poly (a) (make-Box a))] [Channelof (-poly (a) (make-Channel a))] +[Ephemeronof (-poly (a) (make-Ephemeron a))] [Continuation-Mark-Set -Cont-Mark-Set] [False (-val #f)] [True (-val #t)] diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 37feedd2..0cfddca4 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -130,6 +130,11 @@ [#:frees (λ (f) (make-invariant (f elem)))] [#:key 'channel]) +;; elem is a Type +(dt Ephemeron ([elem Type/c]) + [#:key 'ephemeron]) + + ;; name is a Symbol (not a Name) ;; contract is used when generating contracts from types ;; predicate is used to check (at compile-time) whether a value belongs @@ -301,6 +306,7 @@ ;; the supertype of all of these values (dt BoxTop () [#:fold-rhs #:base] [#:key 'box]) (dt ChannelTop () [#:fold-rhs #:base] [#:key 'channel]) +(dt EphemeronTop () [#:fold-rhs #:base] [#:key 'ephemeron]) (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/printer.rkt b/collects/typed-scheme/types/printer.rkt index 076ffff8..e5efbfbe 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -125,6 +125,7 @@ [(StructTop: st) (fp "~a" st)] [(BoxTop:) (fp "Box")] [(ChannelTop:) (fp "Channel")] + [(EphemeronTop:) (fp "Ephemeron")] [(VectorTop:) (fp "Vector")] [(MPairTop:) (fp "MPair")] [(App: rator rands stx) @@ -171,6 +172,7 @@ [(Box: e) (fp "(Boxof ~a)" e)] [(Future: e) (fp "(Futureof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)] + [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] [(ListDots: dty dbound) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index e76654ce..2f785cdf 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -357,6 +357,10 @@ (subtype/flds* A flds flds*))] [((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?))) A0] + ;ephemerons are covariant + [((Ephemeron: s) (Ephemeron: t)) + (subtype* A0 s t)] + [((Ephemeron: _) (EphemeronTop:)) A0] [((Box: _) (BoxTop:)) A0] [((Channel: _) (ChannelTop:)) A0] [((Vector: _) (VectorTop:)) A0]