diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index a385c577..87b3971d 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -30,6 +30,7 @@ make-BoxTop make-ChannelTop make-VectorTop make-ThreadCellTop make-Ephemeron + make-CustodianBox make-HeterogenousVector)) ;Section 9.2 @@ -1347,7 +1348,6 @@ #:cache-keys? B #f . ->key . (-lst a))))] -[object-name (Univ . -> . Univ)] ;; scheme/function @@ -1774,6 +1774,60 @@ +;Section 13.5 (Impersonators and Chaperones) +[impersonator? (Univ . -> . B)] +[chaperone? (Univ . -> . B)] +[impersonator-of? (Univ Univ . -> . B)] +[chaperone-of? (Univ Univ . -> . B)] + +[make-impersonator-property (-> Sym (-values (list -Impersonator-Property (-> Univ B) (-> Univ Univ))))] +[impersonator-property? (make-pred-ty -Impersonator-Property)] +[impersonator-property-accessor-procedure? (-> Univ B)] +[impersonator-prop:application-mark -Impersonator-Property] + +;Section 13.6 (Security Guards) +[security-guard? (make-pred-ty -Security-Guard)] +[make-security-guard + (->opt -Security-Guard + (-> Sym (-opt -Path) (-lst Sym) ManyUniv) + (-> Sym (-opt -String) (-opt -PosInt) (Un (-val 'server) (-val 'client) ManyUniv)) + [(-opt (-> Sym -Path -Path ManyUniv))] + -Security-Guard)] +[current-security-guard (-Param -Security-Guard -Security-Guard)] + +;Section 13.7 (Custodians) +[custodian? (make-pred-ty -Custodian)] +[make-custodian (->opt [-Custodian] -Custodian)] +[custodian-shutdown-all (-> -Custodian -Void)] +[current-custodian (-Param -Custodian -Custodian)] +[custodian-managed-list (-> -Custodian -Custodian (-lst Univ))] +[custodian-memory-accounting-available? (-> B)] +[custodian-require-memory (-> -Custodian -Nat -Custodian -Void)] +[custodian-limit-memory (->opt -Custodian -Nat [-Custodian] -Void)] + +[make-custodian-box (-poly (a) (-> -Custodian a (make-CustodianBox a)))] +[custodian-box? (make-pred-ty (-poly (a) (make-CustodianBox a)))] +[custodian-box-value (-poly (a) (-> (make-CustodianBox a) a))] + +;Section 13.8 (Thread Groups) +[make-thread-group (->opt [-Thread-Group] -Thread-Group)] +[thread-group? (make-pred-ty -Thread-Group)] +[current-thread-group (-Param -Thread-Group -Thread-Group)] + +;Section 13.9 (Structure Inspectors) +[inspector? (make-pred-ty -Inspector)] +[make-inspector (->opt [-Inspector] -Inspector)] +[make-sibling-inspector (->opt [-Inspector] -Inspector)] +[current-inspector (-Param -Inspector -Inspector)] + +[struct-info (-> Univ (-values (list Univ B)))] +[struct-type-info (-> Univ (-values (list Sym -Nat -Nat (-> Univ -Nat Univ) (-> Univ -Nat Univ Univ) (-lst -Nat) Univ B)))] +[struct-type-make-constructor (-> Univ Univ)] +[struct-type-make-predicate (-> Univ (-> Univ B))] +[object-name (-> Univ Univ)] + +;Section 13.9 (Code Inspectors) +[current-code-inspector (-Param -Inspector -Inspector)] [compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))] diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index a4a550fd..f77ab383 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -499,6 +499,8 @@ (cset-meet (cg e e*) (cg e* e))] [((Ephemeron: e) (Ephemeron: e*)) (cg e e*)] + [((CustodianBox: e) (CustodianBox: e*)) + (cg e e*)] [((Set: a) (Set: a*)) (cg a a*)] ;; we assume all HTs are mutable at the moment diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index b9aa0842..d2d4f735 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -140,6 +140,11 @@ (def-type Ephemeron ([elem Type/c]) [#:key 'ephemeron]) +;; elem is a Type +(def-type CustodianBox ([elem Type/c]) + [#:key 'custodian-box]) + + ;; elem is a Type (def-type Set ([elem Type/c]) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 9f1686dc..bea3571a 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -199,8 +199,6 @@ (define -PathConventionType (*Un (-val 'unix) (-val 'windows))) -(define -Struct-Type-Property - (make-Base 'Struct-Type-Property #'struct-type-property? struct-type-property? #'Struct-Type-Property)) (define -Pretty-Print-Style-Table (make-Base 'Pretty-Print-Style-Table #'pretty-print-style-table? pretty-print-style-table? #'-Pretty-Print-Style-Table)) @@ -227,8 +225,18 @@ #'internal-definition-context? internal-definition-context? #'-Internal-Definition-Context)) + (define -Subprocess (make-Base 'Subprocess #'subprocess? subprocess? #'-Subprocess)) +(define -Security-Guard + (make-Base 'Security-Guard #'security-guard? security-guard? #'-Security-Guard)) +(define -Thread-Group + (make-Base 'Thread-Group #'thread-group? thread-group? #'-Thread-Group)) +(define -Struct-Type-Property + (make-Base 'Struct-Type-Property #'struct-type-property? struct-type-property? #'Struct-Type-Property)) +(define -Impersonator-Property + (make-Base 'Impersonator-Property #'impersonator-property? impersonator-property? #'-Impersonator-Property)) + diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index ab4465cb..4bed2427 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -174,6 +174,7 @@ [(Channel: e) (fp "(Channelof ~a)" e)] [(ThreadCell: e) (fp "(ThreadCellof ~a)" e)] [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] + [(CustodianBox: e) (fp "(CustodianBoxof ~a)" e)] [(Set: e) (fp "(Setof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 35e36763..a849ef94 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -371,6 +371,8 @@ ;ephemerons are covariant [((Ephemeron: s) (Ephemeron: t)) (subtype* A0 s t)] + [((CustodianBox: s) (CustodianBox: t)) + (subtype* A0 s t)] [((Box: _) (BoxTop:)) A0] [((ThreadCell: _) (ThreadCellTop:)) A0] [((Set: t) (Set: t*)) (subtype* A0 t t*)]