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

Fix dotted <: starred case.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-18 17:19:05 -07:00
parent 8a07889d08
commit 771b602303
2 changed files with 22 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -318,25 +318,24 @@
(% move-vars+rest-to-dmap new-cset dbound vars #:exact #t))] (% move-vars+rest-to-dmap new-cset dbound vars #:exact #t))]
[else #f])] [else #f])]
;; If dotted <: starred is correct, add it below. Not sure it is.
[((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)))
#:return-unless (memq dbound Y) (if (memq dbound Y)
#f
(cond [(< (length ss) (length ts)) (cond [(< (length ss) (length ts))
;; the hard case ;; the hard case
(let* ([vars (var-store-take dbound s-dty (- (length ts) (length ss)))] (let* ([vars (var-store-take dbound s-dty (- (length ts) (length ss)))]
[new-tys (for/list ([var (in-list vars)]) [new-tys (for/list ([var (in-list vars)])
(substitute (make-F var) dbound s-dty))] (substitute (make-F var) dbound s-dty))]
[new-s-seq (make-arr (append ss new-tys) (dotted-end s-dty dbound))] [new-s-seq (seq (append ss new-tys) (dotted-end s-dty dbound))]
[new-cset (cgen/seq V (append vars X) Y new-s-seq t-seq)]) [new-cset (cgen/seq V (append vars X) Y new-s-seq t-seq)])
(% move-vars+rest-to-dmap new-cset dbound vars))] (% move-vars+rest-to-dmap new-cset dbound vars))]
[else [else
;; the simple case ;; the simple case
(let* ([arg-mapping (cgen/list V X Y ss (extend ss ts t-rest))] (let* ([arg-mapping (cgen/list V X Y ss (extend ss ts t-rest))]
[darg-mapping (% move-rest-to-dmap [darg-mapping (% move-rest-to-dmap
(cgen V (cons dbound X) Y t-rest s-dty) dbound)]) (cgen V (cons dbound X) Y s-dty t-rest) dbound)])
(% cset-meet arg-mapping darg-mapping))])])) (% cset-meet arg-mapping darg-mapping))])
(cgen/seq V X Y (seq ss (uniform-end (substitute Univ dbound s-dty))) t-seq))]))
(define/cond-contract (cgen/arr V X Y s-arr t-arr) (define/cond-contract (cgen/arr V X Y s-arr t-arr)

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

@ -141,6 +141,12 @@
#:vars '(b) #:indices '(a) #:vars '(b) #:indices '(a)
#:result [(-lst* (make-ListDots (-v a) 'a) (-v b)) #:result [(-lst* (make-ListDots (-v a) 'a) (-v b))
(-lst* (-lst -String) -Symbol)]] (-lst* (-lst -String) -Symbol)]]
[infer-t (->* (list -Symbol) -String -Void)
(->... (list) ((-v a) a) -Void)
#:indices '(a)
#:result [(-lst* (make-ListDots (-v a) 'a))
(-lst* (-lst* -Bottom #:tail (-lst -Bottom)))]]
[infer-t (->* (list) -String -Void) (->... (list) (-String a) -Void)]
[infer-l (list (->... null ((-v b) b) (-v a)) (-> (-v a) -Boolean)) [infer-l (list (->... null ((-v b) b) (-v a)) (-> (-v a) -Boolean))
(list (-> -String -Symbol) (-> -Symbol -Boolean)) (list (-> -String -Symbol) (-> -Symbol -Boolean))