From 5609e972b267e4959e20c6799d18a5cedcbd9985 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 29 Apr 2014 22:57:43 -0700 Subject: [PATCH] Make cset-meet take more than two arguments. original commit: c7645170e36f5431d81595d2115010fd62071c9f --- .../typed-racket/infer/constraints.rkt | 45 ++++++++++--------- .../typed-racket/infer/infer-unit.rkt | 40 ++++++++--------- .../typed-racket/infer/signatures.rkt | 2 +- 3 files changed, 42 insertions(+), 45 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/constraints.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/constraints.rkt index 44c11ca2..09ecbd58 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/constraints.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/constraints.rkt @@ -58,35 +58,36 @@ (unless (or var (eq? X X*)) (int-err "Non-matching vars in c-meet: ~a ~a" X X*)) (let ([S (join S S*)] [T (meet T T*)]) - (and (subtype S T) + (and (subtype S T) (make-c S (or var X) T)))])) - + ;; compute the meet of two constraint sets ;; returns #f for failure -(define (cset-meet x y) - (match* (x y) - [((struct cset (maps1)) (struct cset (maps2))) - (define maps (for*/list ([(map1 dmap1) (in-pairs (remove-duplicates maps1))] - [(map2 dmap2) (in-pairs (remove-duplicates maps2))] - [v (in-value (% cons - (hash-union/fail map1 map2 #:combine c-meet) - (dmap-meet dmap1 dmap2)))] - #:when v) - v)) - (cond [(null? maps) - #f] - [else (make-cset maps)])] - [(_ _) (int-err "Got non-cset: ~a ~a" x y)])) +(define cset-meet + (case-lambda + [() (empty-cset null null)] + [(x) x] + [(x y) + (match* (x y) + [((struct cset (maps1)) (struct cset (maps2))) + (define maps (for*/list ([(map1 dmap1) (in-pairs (remove-duplicates maps1))] + [(map2 dmap2) (in-pairs (remove-duplicates maps2))] + [v (in-value (% cons + (hash-union/fail map1 map2 #:combine c-meet) + (dmap-meet dmap1 dmap2)))] + #:when v) + v)) + (cond [(null? maps) + #f] + [else (make-cset maps)])])] + [(x . ys) + (for/fold ([x x]) ([y (in-list ys)]) + (% cset-meet x y))])) ;; combines a list of csets using cset-meet individually ;; returns #f for failure (define (cset-meet* args) - (for/fold ([c (make-cset (list (cons - (make-immutable-hash null) - (make-dmap (make-immutable-hash null)))))]) - ([a (in-list args)] - #:break (not c)) - (cset-meet a c))) + (apply cset-meet args)) ;; produces a cset of all of the maps in all of the given csets ;; FIXME: should this call `remove-duplicates`? diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt index 2b06d778..3559578e 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -206,11 +206,11 @@ ;; the simplest case - no rests, drests, keywords [((arr: ss s #f #f '()) (arr: ts t #f #f '())) - (% cset-meet* (% list - ;; contravariant - (cgen/list V X Y ts ss) - ;; covariant - (cg s t)))] + (% cset-meet + ;; contravariant + (cgen/list V X Y ts ss) + ;; covariant + (cg s t))] ;; just a rest arg, no drest, no keywords [((arr: ss s s-rest #f '()) (arr: ts t t-rest #f '())) @@ -227,7 +227,7 @@ ;; no rest arg on the left, or wrong number = fail [else #f])] [ret-mapping (cg s t)]) - (% cset-meet* (% list arg-mapping ret-mapping)))] + (% cset-meet arg-mapping ret-mapping))] ;; dotted on the left, nothing on the right [((arr: ss s #f (cons dty dbound) '()) (arr: ts t #f #f '())) @@ -265,8 +265,7 @@ (let* ([arg-mapping (cgen/list V X Y ts ss)] [darg-mapping (cgen V X Y t-dty s-dty)] [ret-mapping (cg s t)]) - (% cset-meet* - (% list arg-mapping darg-mapping ret-mapping)))] + (% cset-meet arg-mapping darg-mapping ret-mapping))] ;; bounds are different [((arr: ss s #f (cons s-dty (? (λ (db) (memq db Y)) dbound)) '()) (arr: ts t #f (cons t-dty dbound*) '())) @@ -276,8 +275,7 @@ ;; just add dbound as something that can be constrained [darg-mapping (% move-dotted-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-dty) dbound)] [ret-mapping (cg s t)]) - (% cset-meet* - (% list arg-mapping darg-mapping ret-mapping)))] + (% cset-meet arg-mapping darg-mapping ret-mapping))] [((arr: ss s #f (cons s-dty dbound) '()) (arr: ts t #f (cons t-dty (? (λ (db) (memq db Y)) dbound*)) '())) #:return-unless (= (length ss) (length ts)) #f @@ -286,8 +284,7 @@ [darg-mapping (% move-dotted-rest-to-dmap (cgen V (cons dbound* X) Y t-dty s-dty) dbound*)] [ret-mapping (cg s t)]) - (% cset-meet* - (% list arg-mapping darg-mapping ret-mapping)))] + (% cset-meet arg-mapping darg-mapping ret-mapping))] ;; * <: ... [((arr: ss s s-rest #f '()) (arr: ts t #f (cons t-dty dbound) '())) @@ -299,7 +296,7 @@ [darg-mapping (% move-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-rest) dbound)] [ret-mapping (cg s t)]) - (% cset-meet* (% list arg-mapping darg-mapping ret-mapping))) + (% cset-meet arg-mapping darg-mapping ret-mapping)) ;; the hard case (let* ([vars (var-store-take dbound t-dty (- (length ss) (length ts)))] [new-tys (for/list ([var (in-list vars)]) @@ -329,7 +326,7 @@ (move-rest-to-dmap rest-mapping dbound #:exact #t))] [ret-mapping (cg s t)]) - (% cset-meet* (% list arg-mapping darg-mapping ret-mapping)))] + (% cset-meet arg-mapping darg-mapping ret-mapping))] [else #f])] [(_ _) #f])) @@ -387,10 +384,9 @@ ;; check each element [((Result: s f-s o-s) (Result: t f-t o-t)) - (% cset-meet* (% list - (cg s t) - (cgen/filter-set V X Y f-s f-t) - (cgen/object V X Y o-s o-t)))] + (% cset-meet (cg s t) + (cgen/filter-set V X Y f-s f-t) + (cgen/object V X Y o-s o-t))] ;; values are covariant [((Values: ss) (Values: ts)) @@ -531,7 +527,7 @@ ;; To check that mutable pair is a sequence we check that the cdr is ;; both an mutable list and a sequence [((MPair: t1 t2) (Sequence: (list t*))) - (% cset-meet* (% list (cg t1 t*) (cg t2 T) (cg t2 (Un (-val null) (make-MPairTop)))))] + (% cset-meet (cg t1 t*) (cg t2 T) (cg t2 (Un (-val null) (make-MPairTop))))] [((List: ts) (Sequence: (list t*))) (% cset-meet* (for/list/fail ([t (in-list ts)]) (cg t t*)))] @@ -651,7 +647,7 @@ [((Box: e) (Box: e*)) (% cset-meet (cg e e*) (cg e* e))] [((MPair: s t) (MPair: s* t*)) - (% cset-meet* (% list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] + (% cset-meet (cg s s*) (cg s* s) (cg t t*) (cg t* t))] [((Channel: e) (Channel: e*)) (% cset-meet (cg e e*) (cg e* e))] [((ThreadCell: e) (ThreadCell: e*)) @@ -659,7 +655,7 @@ [((Continuation-Mark-Keyof: e) (Continuation-Mark-Keyof: e*)) (% cset-meet (cg e e*) (cg e* e))] [((Prompt-Tagof: s t) (Prompt-Tagof: s* t*)) - (% cset-meet* (% list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] + (% cset-meet (cg s s*) (cg s* s) (cg t t*) (cg t* t))] [((Promise: e) (Promise: e*)) (cg e e*)] [((Ephemeron: e) (Ephemeron: e*)) @@ -694,7 +690,7 @@ ;; we assume all HTs are mutable at the moment [((Hashtable: s1 s2) (Hashtable: t1 t2)) ;; for mutable hash tables, both are invariant - (% cset-meet* (% list (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2)))] + (% cset-meet (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2))] ;; syntax is covariant [((Syntax: s1) (Syntax: s2)) (cg s1 s2)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt index 86168f8c..8319a9f7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt @@ -14,7 +14,7 @@ [cond-contracted var-demote (Type/c (listof symbol?) . -> . Type/c)])) (define-signature constraints^ - ([cond-contracted cset-meet (cset? cset? . -> . (or/c #f cset?))] + ([cond-contracted cset-meet ((cset? cset?) #:rest (listof cset?) . ->* . (or/c #f cset?))] [cond-contracted cset-meet* ((listof cset?) . -> . (or/c #f cset?))] no-constraint [cond-contracted empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)]