From fe6cdbc35b79af72ab59e68dd33ded26e602cc2f Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 3 Apr 2014 00:00:11 -0700 Subject: [PATCH] Make tc-results: and Results: not use ... over patterns. This avoids a case where match is silently wrong. original commit: 2f032184ca98d02cdf330ac8d3f5095d37c09252 --- .../typed-racket/typecheck/check-below.rkt | 35 +++++++++++++-- .../typed-racket/typecheck/tc-expr-unit.rkt | 4 +- .../typed-racket/typecheck/tc-let-unit.rkt | 4 +- .../typed-racket/types/filter-ops.rkt | 4 +- .../typed-racket/types/tc-result.rkt | 44 ++++++++++--------- 5 files changed, 62 insertions(+), 29 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt index f69a7565..dcf6f40f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt @@ -140,16 +140,18 @@ (ret t2 (fix-filter f2 f1) (fix-object o2 o1))] ;; case where expected is like (Values a ... a) but got something else - [((tc-results: t1 f o) (tc-results: t2 f o dty dbound)) + [((tc-results: t1 f1 o1) (tc-results: t2 f2 o2 dty dbound)) (value-mismatch expected tr1) (fix-results expected)] ;; case where you have (Values a ... a) but expected something else - [((tc-results: t1 f o dty dbound) (tc-results: t2 f o)) + [((tc-results: t1 f1 o1 dty dbound) (tc-results: t2 f2 o2)) (value-mismatch expected tr1) (fix-results expected)] - [((tc-results: t1 f o dty1 dbound) (tc-results: t2 f o dty2 dbound)) + [((tc-results: t1 f1 o1 dty1 dbound) + (tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...) + (list (or (NoObject:) (Empty:)) ...) dty2 dbound)) (cond [(= (length t1) (length t2)) (unless (andmap subtype t1 t2) @@ -160,12 +162,39 @@ (value-mismatch expected tr1)]) (fix-results expected)] + [((tc-results: t1 f1 o1 dty1 dbound) (tc-results: t2 f2 o2 dty2 dbound)) + (cond + [(= (length t1) (length t2)) + (unless (andmap subtype t1 t2) + (expected-but-got (stringify t2) (stringify t1))) + (unless (subtype dty1 dty2) + (type-mismatch dty2 dty1 "mismatch in ... argument"))] + [else + (value-mismatch expected tr1)]) + (fix-results expected)] + + [((tc-results: t1 f1 o1) + (tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...) + (list (or (NoObject:) (Empty:)) ...))) + (unless (= (length t1) (length t2)) + (value-mismatch expected tr1)) + (unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s)) + (expected-but-got (stringify t2) (stringify t1))) + (fix-results expected)] + [((tc-results: t1 fs os) (tc-results: t2 fs os)) (unless (= (length t1) (length t2)) (value-mismatch expected tr1)) (unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s)) (expected-but-got (stringify t2) (stringify t1))) (fix-results expected)] + + [((tc-results: t1 f1 o1) (tc-results: t2 f2 o2)) (=> continue) + (if (= (length t1) (length t2)) + (continue) + (value-mismatch expected tr1)) + (fix-results expected)] + [((tc-any-results:) (tc-results: ts fs os)) (value-mismatch expected tr1) (fix-results expected)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index f415c894..17366f01 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -529,9 +529,9 @@ (define props (match results [(tc-any-results:) empty] - [(tc-results: _ (FilterSet: f+ f-) _) + [(tc-results: _ (list (FilterSet: f+ f-) ...) _) (map -or f+ f-)] - [(tc-results: _ (FilterSet: f+ f-) _ _ _) + [(tc-results: _ (list (FilterSet: f+ f-) ...) _ _ _) (map -or f+ f-)])) (with-lexical-env (env+ (lexical-env) props (box #t)) (add-unconditional-prop (k) (apply -and props)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 0ea58643..8338b6da 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -48,7 +48,7 @@ ([e-r (in-list expected-results)] [names (in-list namess)]) (match e-r - [(tc-results: e-ts (FilterSet: fs+ fs-) os) + [(tc-results: e-ts (list (FilterSet: fs+ fs-) ...) os) (values e-ts (apply append (for/list ([n (in-list names)] @@ -58,7 +58,7 @@ (list) (list (-imp (-not-filter (-val #f) n) f+) (-imp (-filter (-val #f) n) f-))))))] - [(tc-results: e-ts (NoFilter:) _) + [(tc-results: e-ts (list (NoFilter:) ...) _) (values e-ts null)])))) (with-cond-contract append-region ([p1 (listof Filter?)] [p2 (listof Filter?)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/filter-ops.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/filter-ops.rkt index 6fb3ca29..2def959e 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/filter-ops.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/filter-ops.rkt @@ -214,12 +214,12 @@ (match results ;; TODO add support for filters on tc-any-results [(tc-any-results:) results] - [(tc-results: ts (FilterSet: fs+ fs-) os) + [(tc-results: ts (list (FilterSet: fs+ fs-) ...) os) (ret ts (for/list ([f+ fs+] [f- fs-]) (-FS (-and prop f+) (-and prop f-))) os)] - [(tc-results: ts (FilterSet: fs+ fs-) os dty dbound) + [(tc-results: ts (list (FilterSet: fs+ fs-) ...) os dty dbound) (ret ts (for/list ([f+ fs+] [f- fs-]) (-FS (-and prop f+) (-and prop f-))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt index 97d19c3d..11ada36a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt @@ -39,33 +39,32 @@ (define-match-expander tc-result: (syntax-rules () - [(_ tp fp op) (struct tc-result (tp fp op))] - [(_ tp) (struct tc-result (tp _ _))])) + [(_ tp fp op) (tc-result tp fp op)] + [(_ tp) (tc-result tp _ _)])) + +;; expand-tc-results: (Listof tc-result) -> (Values (Listof Type) (Listof FilterSet) (Listof Object)) +(define (expand-tc-results results) + (values (map tc-result-t results) (map tc-result-f results) (map tc-result-o results))) (define-match-expander tc-results: (syntax-rules () - [(_ tp fp op) - (struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) - #f))] - [(_ tp fp op dty dbound) - (struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) - (cons dty dbound)))] [(_ tp) - (struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) - #f))])) + (tc-results (app expand-tc-results tp _ _) #f)] + [(_ tp fp op) + (tc-results (app expand-tc-results tp fp op) #f)] + [(_ tp fp op dty dbound) + (tc-results (app expand-tc-results tp fp op) (cons dty dbound))])) (define-match-expander tc-any-results: (syntax-rules () [(_) - (struct tc-any-results ())])) + (tc-any-results)])) (define-match-expander tc-result1: (syntax-rules () - [(_ tp fp op) (struct tc-results ((list (struct tc-result (tp fp op))) - #f))] - [(_ tp) (struct tc-results ((list (struct tc-result (tp _ _))) - #f))])) + [(_ tp) (tc-results: (list tp))] + [(_ tp fp op) (tc-results: (list tp) (list fp) (list op))])) (define (tc-results-ts* tc) (match tc @@ -73,14 +72,19 @@ (define-match-expander Result1: (syntax-rules () - [(_ tp) (Values: (list (Result: tp _ _)))] - [(_ tp fp op) (Values: (list (Result: tp fp op)))])) + [(_ tp) (Results: (list tp))] + [(_ tp fp op) (Results: (list tp) (list fp) (list op))])) + +;; expand-Results: (Listof Rresult) -> (Values (Listof Type) (Listof FilterSet) (Listof Object)) +(define (expand-Results results) + (values (map Result-t results) (map Result-f results) (map Result-o results))) + (define-match-expander Results: (syntax-rules () - [(_ tp) (Values: (list (Result: tp _ _) (... ...)))] - [(_ tp fp op) (Values: (list (Result: tp fp op) (... ...)))] - [(_ tp fp op dty dbound) (ValuesDots: (list (Result: tp fp op) (... ...)) dty dbound)])) + [(_ tp) (Values: (app expand-Results tp _ _))] + [(_ tp fp op) (Values: (app expand-Results tp fp op))] + [(_ tp fp op dty dbound) (ValuesDots: (app expand-Results tp fp op) dty dbound)])) ;; make-tc-result*: Type/c FilterSet/c Object? -> tc-result? ;; Smart constructor for a tc-result.