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

Fix infer dotted cases when there are constraints on the dbound.

Browse Source 
Closes PR 14593.
This commit is contained in:
Eric Dobson 2014-06-22 23:26:36 -07:00
parent 8fb166d67f
commit 2f7cb68aea
2 changed files with 48 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -82,13 +82,15 @@
(define (mover cset dbound vars f) (define (mover cset dbound vars f)
(map/cset (map/cset
(lambda (cmap dmap) (lambda (cmap dmap)
(when (hash-has-key? (dmap-map dmap) dbound)
(int-err "Tried to move vars to dbound that already exists"))
(% cons (% cons
(hash-remove* cmap (cons dbound vars)) (hash-remove* cmap (cons dbound vars))
(dmap-meet (dmap-meet
(singleton-dmap (singleton-dmap
dbound dbound
(f cmap)) (f cmap))
(make-dmap (hash-remove (dmap-map dmap) dbound))))) dmap)))
cset)) cset))
;; dbound : index variable ;; dbound : index variable
@ -237,7 +239,10 @@
#:return-unless (<= (length ss) (length ts)) #:return-unless (<= (length ss) (length ts))
#f #f
(define-values (vars new-tys) (generate-dbound-prefix dbound dty (- (length ts) (length ss)) #f)) (define-values (vars new-tys) (generate-dbound-prefix dbound dty (- (length ts) (length ss)) #f))
(% move-vars-to-dmap (cgen/list V (append vars X) Y (append ss new-tys) ts) dbound vars)] (define-values (ts-front ts-back) (split-at ts (length ss)))
(% cset-meet
(cgen/list V X Y ss ts-front)
(% move-vars-to-dmap (cgen/list V (append vars X) Y new-tys ts-back) dbound vars))]
;; dotted above, nothing below ;; dotted above, nothing below
[((seq ss (null-end)) [((seq ss (null-end))
(seq ts (dotted-end dty dbound))) (seq ts (dotted-end dty dbound)))
@ -246,7 +251,10 @@
#:return-unless (<= (length ts) (length ss)) #:return-unless (<= (length ts) (length ss))
#f #f
(define-values (vars new-tys) (generate-dbound-prefix dbound dty (- (length ss) (length ts)) #f)) (define-values (vars new-tys) (generate-dbound-prefix dbound dty (- (length ss) (length ts)) #f))
(% move-vars-to-dmap (cgen/list V (append vars X) Y ss (append ts new-tys)) dbound vars)] (define-values (ss-front ss-back) (split-at ss (length ts)))
(% cset-meet
(cgen/list V X Y ss-front ts)
(% move-vars-to-dmap (cgen/list V (append vars X) Y ss-back new-tys) dbound vars))]
;; same dotted bound ;; same dotted bound
[((seq ss (dotted-end s-dty dbound)) [((seq ss (dotted-end s-dty dbound))
@ -287,24 +295,33 @@
(define new-bound (gensym dbound)) (define new-bound (gensym dbound))
(define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts)) (define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts))
new-bound)) new-bound))
(% move-vars+rest-to-dmap (define-values (ss-front ss-back) (split-at ss (length ts)))
(% cset-meet (% cset-meet
(cgen/list (cons new-bound V) (append vars X) (cons new-bound Y) ss (append ts new-tys)) (cgen/list V X Y ss-front ts)
(cgen V (cons dbound X) Y s-rest t-dty)) (% move-vars+rest-to-dmap
vars dbound #:exact #t)] (% cset-meet
(cgen/list (cons new-bound V) (append vars X) (cons new-bound Y) ss-back new-tys)
(cgen V (cons dbound X) Y s-rest t-dty))
vars dbound #:exact #t))]
[((seq ss (dotted-end s-dty dbound)) [((seq ss (dotted-end s-dty dbound))
(seq ts (uniform-end t-rest))) (seq ts (uniform-end t-rest)))
(cond (cond
[(memq dbound Y) [(memq dbound Y)
(define new-bound (gensym dbound)) (define new-bound (gensym dbound))
(define length-delta (- (length ts) (length ss)))
(define-values (vars new-tys) (define-values (vars new-tys)
(generate-dbound-prefix dbound s-dty (max 0 (- (length ts) (length ss))) new-bound)) (generate-dbound-prefix dbound s-dty (max 0 length-delta) new-bound))
(% move-vars+rest-to-dmap (% cset-meet
(% cset-meet (cgen/list V X Y ss (if (positive? length-delta)
(cgen/list (cons new-bound V) (append vars X) (cons new-bound Y) (append ss new-tys) (extend ss ts t-rest)) (drop-right ts length-delta)
(cgen V (cons dbound X) Y s-dty t-rest)) (extend ss ts t-rest)))
vars dbound)] (% move-vars+rest-to-dmap
(% cset-meet
(cgen/list (cons new-bound V) (append vars X) (cons new-bound Y)
new-tys (take-right ts (max 0 length-delta)))
(cgen V (cons dbound X) Y s-dty t-rest))
vars dbound))]
[else [else
(extend-tvars (list dbound) (extend-tvars (list dbound)
(cgen/seq (cons dbound V) X Y (seq ss (uniform-end s-dty)) t-seq))])])) (cgen/seq (cons dbound V) X Y (seq ss (uniform-end s-dty)) t-seq))])]))

17
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/infer-tests.rkt
View File

@ -228,6 +228,23 @@
[infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)] [infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
[infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)] [infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
[infer-t
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
(-lst* (-> Univ Univ))
#:indices '(b) #:fail]
[infer-t
(-lst* (-> Univ Univ))
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
#:indices '(b) #:fail]
[infer-t
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
(-pair (-> -Symbol Univ) (-lst -String))
#:indices '(b) #:fail]
[infer-t
(-pair (-> -Symbol Univ) (-lst -String))
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
#:indices '(b) #:fail]
;; Currently Broken ;; Currently Broken
;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b)) ;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
[i2-t (-v a) N ('a N)] [i2-t (-v a) N ('a N)]