suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add Top types for prompt tags and mark keys

Browse Source
This commit is contained in:
Asumu Takikawa 2012-11-05 14:31:17 -05:00
parent 4b5d6e71fd
commit 41b59cb46a
5 changed files with 23 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/typed-racket/base-env/base-env.rkt
View File

@ -38,7 +38,9 @@
make-CustodianBox make-CustodianBox
make-HeterogeneousVector make-HeterogeneousVector
make-Continuation-Mark-Key make-Continuation-Mark-Key
make-Continuation-Mark-KeyTop
make-Prompt-Tag make-Prompt-Tag
make-Prompt-TagTop
make-ListDots)) make-ListDots))
;Section 9.2 ;Section 9.2
@ -2023,7 +2025,7 @@
;Section 9.4 (Continuations) ;Section 9.4 (Continuations)
[call-with-continuation-barrier (-poly (a) (-> (-> a) a))] [call-with-continuation-barrier (-poly (a) (-> (-> a) a))]
[continuation-prompt-available? (-> -Prompt-Tag B)] [continuation-prompt-available? (-> (make-Prompt-TagTop) B)]
[call-with-continuation-prompt [call-with-continuation-prompt
(-polydots (a b d c) (-polydots (a b d c)
@ -2039,33 +2041,34 @@
(cl->* (cl->*
(-> (->... '() (a a) b) (make-Prompt-Tag b c) (make-ValuesDots '() a 'a))))] (-> (->... '() (a a) b) (make-Prompt-Tag b c) (make-ValuesDots '() a 'a))))]
[make-continuation-prompt-tag (-poly (a b) (->opt [Sym] (make-Prompt-Tag a b)))] [make-continuation-prompt-tag (-poly (a b) (->opt [Sym] (make-Prompt-Tag a b)))]
[default-continuation-prompt-tag (-> (make-Prompt-Tag Univ (-> ManyUniv Univ)))] ;[default-continuation-prompt-tag (-> (make-Prompt-Tag Univ (-> ManyUniv Univ)))]
;[continuation-prompt-tag? (make-pred-ty -Prompt-Tag)] [continuation-prompt-tag? (make-pred-ty (make-Prompt-TagTop))]
[dynamic-wind (-poly (a) (-> (-> ManyUniv) (-> a) (-> ManyUniv) a))] [dynamic-wind (-poly (a) (-> (-> ManyUniv) (-> a) (-> ManyUniv) a))]
;Section 9.5 (Continuation Marks) ;Section 9.5 (Continuation Marks)
;continuation-marks needs type for continuations as other possible first argument ;continuation-marks needs type for continuations as other possible first argument
[continuation-marks (->opt (Un (-val #f) -Thread) [-Prompt-Tag] -Cont-Mark-Set)] [continuation-marks (->opt (Un (-val #f) -Thread) [(make-Prompt-TagTop)] -Cont-Mark-Set)]
[current-continuation-marks (->opt [-Prompt-Tag] -Cont-Mark-Set)] [current-continuation-marks (->opt [(make-Prompt-TagTop)] -Cont-Mark-Set)]
[continuation-mark-set->list [continuation-mark-set->list
(-poly (a) (-poly (a)
(cl->* (cl->*
(->opt -Cont-Mark-Set (make-Continuation-Mark-Key a) [-Prompt-Tag] (-lst a)) (->opt -Cont-Mark-Set (make-Continuation-Mark-Key a) [(make-Prompt-TagTop)] (-lst a))
(->opt -Cont-Mark-Set Univ [-Prompt-Tag] (-lst Univ))))] (->opt -Cont-Mark-Set Univ [(make-Prompt-TagTop)] (-lst Univ))))]
[continuation-mark-set->list* [continuation-mark-set->list*
(-poly (a b) (-poly (a b)
(cl->* (cl->*
(->opt -Cont-Mark-Set (-lst (make-Continuation-Mark-Key a)) [b -Prompt-Tag] (->opt -Cont-Mark-Set (-lst (make-Continuation-Mark-Key a)) [b (make-Prompt-TagTop)]
(-lst (-vec (Un a b)))) (-lst (-vec (Un a b))))
(->opt -Cont-Mark-Set (-lst Univ) [Univ -Prompt-Tag] (-lst (-vec Univ)))))] (->opt -Cont-Mark-Set (-lst Univ) [Univ (make-Prompt-TagTop)] (-lst (-vec Univ)))))]
[continuation-mark-set-first [continuation-mark-set-first
(-poly (a b) (-poly (a b)
(cl->* (cl->*
(-> (-opt -Cont-Mark-Set) (make-Continuation-Mark-Key a) (-opt a)) (-> (-opt -Cont-Mark-Set) (make-Continuation-Mark-Key a) (-opt a))
(->opt (-opt -Cont-Mark-Set) (make-Continuation-Mark-Key a) [b -Prompt-Tag] (->opt (-opt -Cont-Mark-Set) (make-Continuation-Mark-Key a) [b (make-Prompt-TagTop)]
(Un a b)) (Un a b))
(->opt (-opt -Cont-Mark-Set) Univ [Univ -Prompt-Tag] Univ)))] (->opt (-opt -Cont-Mark-Set) Univ [Univ (make-Prompt-TagTop)] Univ)))]
[call-with-immediate-continuation-mark (-poly (a) (->opt Univ (-> Univ a) [Univ] a))] [call-with-immediate-continuation-mark (-poly (a) (->opt Univ (-> Univ a) [Univ] a))]
[continuation-mark-key? (make-pred-ty (make-Continuation-Mark-KeyTop))]
[continuation-mark-set? (make-pred-ty -Cont-Mark-Set)] [continuation-mark-set? (make-pred-ty -Cont-Mark-Set)]
[make-continuation-mark-key (-poly (a) (->opt [-Symbol] (make-Continuation-Mark-Key a)))] [make-continuation-mark-key (-poly (a) (->opt [-Symbol] (make-Continuation-Mark-Key a)))]
[continuation-mark-set->context (-> -Cont-Mark-Set (-lst (-pair (-opt Sym) Univ)))] ;TODO add srcloc [continuation-mark-set->context (-> -Cont-Mark-Set (-lst (-pair (-opt Sym) Univ)))] ;TODO add srcloc

3
collects/typed-racket/rep/type-rep.rkt
View File

@ -323,6 +323,9 @@
(def-type MPairTop () [#:fold-rhs #:base] [#:key 'mpair]) (def-type MPairTop () [#:fold-rhs #:base] [#:key 'mpair])
(def-type StructTop ([name Struct?]) [#:key 'struct]) (def-type StructTop ([name Struct?]) [#:key 'struct])
(def-type ThreadCellTop () [#:fold-rhs #:base] [#:key 'thread-cell]) (def-type ThreadCellTop () [#:fold-rhs #:base] [#:key 'thread-cell])
(def-type Prompt-TagTop () [#:fold-rhs #:base] [#:key 'prompt-tag])
(def-type Continuation-Mark-KeyTop ()
[#:fold-rhs #:base] [#:key 'continuation-mark-key])
;; v : Racket Value ;; v : Racket Value
(def-type Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number] (def-type Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number]

1
collects/typed-racket/types/abbrev.rkt
View File

@ -144,7 +144,6 @@
(conjoin compiled-expression? (negate compiled-module-expression?)) (conjoin compiled-expression? (negate compiled-module-expression?))
#'-Compiled-Non-Module-Expression)) #'-Compiled-Non-Module-Expression))
(define -Compiled-Expression (Un -Compiled-Module-Expression -Compiled-Non-Module-Expression)) (define -Compiled-Expression (Un -Compiled-Module-Expression -Compiled-Non-Module-Expression))
(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag? continuation-prompt-tag? #'-Prompt-Tag))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set))
(define -Path (make-Base 'Path #'path? path? #'-Path)) (define -Path (make-Base 'Path #'path? path? #'-Path))
(define -OtherSystemPath (make-Base 'OtherSystemPath (define -OtherSystemPath (make-Base 'OtherSystemPath

2
collects/typed-racket/types/printer.rkt
View File

@ -226,6 +226,8 @@
[(ThreadCellTop:) (fp "ThreadCell")] [(ThreadCellTop:) (fp "ThreadCell")]
[(VectorTop:) (fp "Vector")] [(VectorTop:) (fp "Vector")]
[(MPairTop:) (fp "MPair")] [(MPairTop:) (fp "MPair")]
[(Prompt-TagTop:) (fp "Prompt-Tag")]
[(Continuation-Mark-KeyTop:) (fp "Continuation-Mark-Key")]
[(App: rator rands stx) [(App: rator rands stx)
(fp "~a" (list* rator rands))] (fp "~a" (list* rator rands))]
;; special cases for lists ;; special cases for lists

4
collects/typed-racket/types/subtype.rkt
View File

@ -421,6 +421,10 @@
(if (andmap (lambda (e0) (type-equal? e0 e*)) e) A0 (fail! s t))] (if (andmap (lambda (e0) (type-equal? e0 e*)) e) A0 (fail! s t))]
[((MPair: _ _) (MPairTop:)) A0] [((MPair: _ _) (MPairTop:)) A0]
[((Hashtable: _ _) (HashtableTop:)) A0] [((Hashtable: _ _) (HashtableTop:)) A0]
;; TODO: subtyping for two `Prompt-Tagof`s with recursive types
;; may be rejected unnecessarily
[((Prompt-Tag: _ _) (Prompt-TagTop:)) A0]
[((Continuation-Mark-Key: _) (Continuation-Mark-KeyTop:)) A0]
;; subtyping on structs follows the declared hierarchy ;; subtyping on structs follows the declared hierarchy
[((Struct: nm (? Type? parent) _ _ _ _) other) [((Struct: nm (? Type? parent) _ _ _ _) other)
;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) ;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other)