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

33
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 (seq (append ss new-tys) (dotted-end s-dty dbound))]
[new-s-seq (make-arr (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 s-dty t-rest) dbound)])
(cgen V (cons dbound X) Y t-rest s-dty) 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))