Make tc-results: and Results: not use ... over patterns.

This avoids a case where match is silently wrong.
This commit is contained in:
Eric Dobson 2014-04-03 00:00:11 -07:00
parent 78fbdfec0b
commit 2f032184ca
5 changed files with 62 additions and 29 deletions

View File

@ -140,16 +140,18 @@
(ret t2 (fix-filter f2 f1) (fix-object o2 o1))] (ret t2 (fix-filter f2 f1) (fix-object o2 o1))]
;; case where expected is like (Values a ... a) but got something else ;; 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) (value-mismatch expected tr1)
(fix-results expected)] (fix-results expected)]
;; case where you have (Values a ... a) but expected something else ;; 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) (value-mismatch expected tr1)
(fix-results expected)] (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 (cond
[(= (length t1) (length t2)) [(= (length t1) (length t2))
(unless (andmap subtype t1 t2) (unless (andmap subtype t1 t2)
@ -160,12 +162,39 @@
(value-mismatch expected tr1)]) (value-mismatch expected tr1)])
(fix-results expected)] (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)) [((tc-results: t1 fs os) (tc-results: t2 fs os))
(unless (= (length t1) (length t2)) (unless (= (length t1) (length t2))
(value-mismatch expected tr1)) (value-mismatch expected tr1))
(unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s)) (unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
(expected-but-got (stringify t2) (stringify t1))) (expected-but-got (stringify t2) (stringify t1)))
(fix-results expected)] (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)) [((tc-any-results:) (tc-results: ts fs os))
(value-mismatch expected tr1) (value-mismatch expected tr1)
(fix-results expected)] (fix-results expected)]

View File

@ -529,9 +529,9 @@
(define props (define props
(match results (match results
[(tc-any-results:) empty] [(tc-any-results:) empty]
[(tc-results: _ (FilterSet: f+ f-) _) [(tc-results: _ (list (FilterSet: f+ f-) ...) _)
(map -or f+ f-)] (map -or f+ f-)]
[(tc-results: _ (FilterSet: f+ f-) _ _ _) [(tc-results: _ (list (FilterSet: f+ f-) ...) _ _ _)
(map -or f+ f-)])) (map -or f+ f-)]))
(with-lexical-env (env+ (lexical-env) props (box #t)) (with-lexical-env (env+ (lexical-env) props (box #t))
(add-unconditional-prop (k) (apply -and props)))) (add-unconditional-prop (k) (apply -and props))))

View File

@ -48,7 +48,7 @@
([e-r (in-list expected-results)] ([e-r (in-list expected-results)]
[names (in-list namess)]) [names (in-list namess)])
(match e-r (match e-r
[(tc-results: e-ts (FilterSet: fs+ fs-) os) [(tc-results: e-ts (list (FilterSet: fs+ fs-) ...) os)
(values e-ts (values e-ts
(apply append (apply append
(for/list ([n (in-list names)] (for/list ([n (in-list names)]
@ -58,7 +58,7 @@
(list) (list)
(list (-imp (-not-filter (-val #f) n) f+) (list (-imp (-not-filter (-val #f) n) f+)
(-imp (-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)])))) (values e-ts null)]))))
(with-cond-contract append-region ([p1 (listof Filter?)] (with-cond-contract append-region ([p1 (listof Filter?)]
[p2 (listof Filter?)]) [p2 (listof Filter?)])

View File

@ -214,12 +214,12 @@
(match results (match results
;; TODO add support for filters on tc-any-results ;; TODO add support for filters on tc-any-results
[(tc-any-results:) results] [(tc-any-results:) results]
[(tc-results: ts (FilterSet: fs+ fs-) os) [(tc-results: ts (list (FilterSet: fs+ fs-) ...) os)
(ret ts (ret ts
(for/list ([f+ fs+] [f- fs-]) (for/list ([f+ fs+] [f- fs-])
(-FS (-and prop f+) (-and prop f-))) (-FS (-and prop f+) (-and prop f-)))
os)] os)]
[(tc-results: ts (FilterSet: fs+ fs-) os dty dbound) [(tc-results: ts (list (FilterSet: fs+ fs-) ...) os dty dbound)
(ret ts (ret ts
(for/list ([f+ fs+] [f- fs-]) (for/list ([f+ fs+] [f- fs-])
(-FS (-and prop f+) (-and prop f-))) (-FS (-and prop f+) (-and prop f-)))

View File

@ -39,33 +39,32 @@
(define-match-expander tc-result: (define-match-expander tc-result:
(syntax-rules () (syntax-rules ()
[(_ tp fp op) (struct tc-result (tp fp op))] [(_ tp fp op) (tc-result tp fp op)]
[(_ tp) (struct tc-result (tp _ _))])) [(_ 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: (define-match-expander tc-results:
(syntax-rules () (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) [(_ tp)
(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) (tc-results (app expand-tc-results tp _ _) #f)]
#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: (define-match-expander tc-any-results:
(syntax-rules () (syntax-rules ()
[(_) [(_)
(struct tc-any-results ())])) (tc-any-results)]))
(define-match-expander tc-result1: (define-match-expander tc-result1:
(syntax-rules () (syntax-rules ()
[(_ tp fp op) (struct tc-results ((list (struct tc-result (tp fp op))) [(_ tp) (tc-results: (list tp))]
#f))] [(_ tp fp op) (tc-results: (list tp) (list fp) (list op))]))
[(_ tp) (struct tc-results ((list (struct tc-result (tp _ _)))
#f))]))
(define (tc-results-ts* tc) (define (tc-results-ts* tc)
(match tc (match tc
@ -73,14 +72,19 @@
(define-match-expander Result1: (define-match-expander Result1:
(syntax-rules () (syntax-rules ()
[(_ tp) (Values: (list (Result: tp _ _)))] [(_ tp) (Results: (list tp))]
[(_ tp fp op) (Values: (list (Result: tp fp op)))])) [(_ 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: (define-match-expander Results:
(syntax-rules () (syntax-rules ()
[(_ tp) (Values: (list (Result: tp _ _) (... ...)))] [(_ tp) (Values: (app expand-Results tp _ _))]
[(_ tp fp op) (Values: (list (Result: tp fp op) (... ...)))] [(_ tp fp op) (Values: (app expand-Results tp fp op))]
[(_ tp fp op dty dbound) (ValuesDots: (list (Result: tp fp op) (... ...)) dty dbound)])) [(_ tp fp op dty dbound) (ValuesDots: (app expand-Results tp fp op) dty dbound)]))
;; make-tc-result*: Type/c FilterSet/c Object? -> tc-result? ;; make-tc-result*: Type/c FilterSet/c Object? -> tc-result?
;; Smart constructor for a tc-result. ;; Smart constructor for a tc-result.