Added types for security operations.

original commit: 8a6770735320db21d45fc543da5781918807f66e

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)))]

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

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])

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))
+
 
 
 

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)]

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*)]