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

Merge var-promote and var-demote.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-15 09:25:57 -07:00
parent ee4e07f5eb
commit cadc2dcb8f
1 changed files with 24 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -21,66 +21,39 @@
[(Values: (list (Result: _ lf _) ...)) lf] [(Values: (list (Result: _ lf _) ...)) lf]
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf])) [(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
(define (var-promote T V) (define-values (var-promote var-demote)
(define (vp t) (var-promote t V)) (let ()
(define (inv t) (if (V-in? V t) Univ t)) (define (var-change V T change)
(type-case (#:Type vp #:Filter (sub-f vp)) T (define (co t) (var-change V t change))
[#:F name (if (memq name V) Univ T)] (define (contra t) (var-change V t (not change)))
(define (inv t)
(if (V-in? V t)
(if change Univ -Bottom)
t))
(type-case (#:Type co #:Filter (sub-f co)) T
[#:F name (if (memq name V) (if change Univ -Bottom) T)]
[#:Vector t (make-Vector (inv t))] [#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))] [#:Box t (make-Box (inv t))]
[#:Channel t (make-Channel (inv t))] [#:Channel t (make-Channel (inv t))]
[#:ThreadCell t (make-ThreadCell (inv t))] [#:ThreadCell t (make-ThreadCell (inv t))]
[#:Hashtable k v (make-Hashtable (inv k) (inv v))] [#:Hashtable k v (make-Hashtable (inv k) (inv v))]
[#:Param in out [#:Param in out (make-Param (contra in) (co out))]
(make-Param (var-demote in V)
(vp out))]
[#:arr dom rng rest drest kws [#:arr dom rng rest drest kws
(cond (cond
[(apply V-in? V (get-filters rng)) [(apply V-in? V (get-filters rng))
(make-top-arr)] (make-top-arr)]
[(and drest (memq (cdr drest) V)) [(and drest (memq (cdr drest) V))
(make-arr (for/list ([d (in-list dom)]) (var-demote d V)) (make-arr (map contra dom)
(vp rng) (co rng)
(var-demote (car drest) V) (contra (car drest))
#f #f
(for/list ([k (in-list kws)]) (var-demote k V)))] (map contra kws))]
[else [else
(make-arr (for/list ([d (in-list dom)]) (var-demote d V)) (make-arr (map contra dom)
(vp rng) (co rng)
(and rest (var-demote rest V)) (and rest (contra rest))
(and drest (and drest (cons (contra (car drest)) (cdr drest)))
(cons (var-demote (car drest) V) (map contra kws))])]))
(cdr drest))) (values
(for/list ([k (in-list kws)]) (var-demote k V)))])])) (lambda (T V) (var-change V T #t))
(lambda (T V) (var-change V T #f)))))
(define (var-demote T V)
(define (vd t) (var-demote t V))
(define (inv t) (if (V-in? V t) (Un) t))
(type-case (#:Type vd #:Filter (sub-f vd)) T
[#: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))]
[#:ThreadCell t (make-ThreadCell (inv t))]
[#:Hashtable k v (make-Hashtable (inv k) (inv v))]
[#:Param in out
(make-Param (var-promote in V)
(vd out))]
[#:arr dom rng rest drest kws
(cond
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (for/list ([d (in-list dom)]) (var-promote d V))
(vd rng)
(var-promote (car drest) V)
#f
(for/list ([k (in-list kws)]) (var-promote k V)))]
[else
(make-arr (for/list ([d (in-list dom)]) (var-promote d V))
(vd rng)
(and rest (var-promote rest V))
(and drest
(cons (var-promote (car drest) V)
(cdr drest)))
(for/list ([k (in-list kws)]) (var-promote k V)))])]))