From 0961cf9412dbb8526f870be29b0ee3b78f30a69c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 11 Feb 2016 17:08:45 -0600 Subject: [PATCH] Fix test failures for new double-wrapping tests. Everything passes. --- .../tests/racket/contract/arrow-d.rkt | 6 +++-- .../tests/racket/contract/arrow-i.rkt | 24 ++++++++++++------- .../tests/racket/contract/make-contract.rkt | 3 ++- .../racket/contract/make-proj-contract.rkt | 3 ++- .../tests/racket/contract/or-and.rkt | 18 +++++++++----- .../tests/racket/contract/struct-dc.rkt | 3 ++- .../tests/racket/contract/test-util.rkt | 21 +++++++++------- .../tests/racket/contract/vector.rkt | 3 ++- 8 files changed, 52 insertions(+), 29 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt index 778f996a87..c4ddb65b5d 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt @@ -787,7 +787,8 @@ 'pos 'neg)) x) - '(body ctc)) + '(body ctc) + '(body ctc ctc)) ; result if contract is applied twice (test/spec-passed/result '->d-underscore3 @@ -797,7 +798,8 @@ 'pos 'neg)) x) - '(ctc body)) + '(ctc body) + '(ctc ctc body)) ; result if contract is applied twice (test/spec-passed/result '->d-underscore4 diff --git a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt index 4292d35971..405068d110 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt @@ -732,7 +732,8 @@ (quote neg)) b) (unbox b)) - '(5 4 3 2 1)) + '(5 4 3 2 1) + '(5 4 5 4 3 2 1 2 1)) ; result if contract is applied twice (test/spec-passed/result '->i44 @@ -856,7 +857,8 @@ 'neg) 1) x) - '(res-check res-eval body arg-eval)) + '(res-check res-eval body arg-eval) + '(res-check res-eval res-check res-eval body arg-eval arg-eval)) ; result if contract is applied twice (test/spec-passed/result '->i49 @@ -872,7 +874,8 @@ 'neg) 1) x) - '(res-check body res-eval arg-eval)) + '(res-check body res-eval arg-eval) + '(res-check res-check body res-eval res-eval arg-eval arg-eval)) ; result if contract is applied twice (test/spec-passed/result '->i50 @@ -888,7 +891,8 @@ 'neg) 1) x) - '(res-check body res-eval arg-eval)) + '(res-check body res-eval arg-eval) + '(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice (test/spec-passed/result '->i51 @@ -904,7 +908,8 @@ 'neg) 1) x) - '(res-check body res-eval arg-eval)) + '(res-check body res-eval arg-eval) + '(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice (test/spec-passed/result '->i52 @@ -1341,7 +1346,8 @@ 'pos 'neg)) x) - '(body ctc)) + '(body ctc) + '(body ctc ctc)) ; result if contract is applied twice (test/spec-passed/result '->i-underscore3 @@ -1351,7 +1357,8 @@ 'pos 'neg)) x) - '(body ctc)) + '(body ctc) + '(body ctc ctc)) ; result if contract is applied twice (test/spec-passed/result '->i-underscore4 @@ -1378,7 +1385,8 @@ 'neg) 11) x) - '(body ctc)) + '(body ctc) + '(body ctc ctc)) ; result if contract is applied twice (test/pos-blame '->i-bad-number-of-result-values1 diff --git a/pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-contract.rkt index 04bb43c3d1..638c1813f3 100644 --- a/pkgs/racket-test/tests/racket/contract/make-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/make-contract.rkt @@ -29,7 +29,8 @@ (test/spec-passed/result 'make-contract-1 '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) - 3) + 3 + do-not-double-wrap) (test/pos-blame 'make-contract-2 diff --git a/pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt index f67d10d6d7..1caab4d544 100644 --- a/pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt @@ -32,7 +32,8 @@ (test/spec-passed/result 'make-proj-contract-1 '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) - 3) + 3 + do-not-double-wrap) (test/pos-blame 'make-proj-contract-2 diff --git a/pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-test/tests/racket/contract/or-and.rkt index 6c94591d7b..a408abaebe 100644 --- a/pkgs/racket-test/tests/racket/contract/or-and.rkt +++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt @@ -102,7 +102,8 @@ 'pos 'neg) x) - '(1 2)) + '(1 2) + '(1 2 1 2)) ; result if contract is applied twice (test/spec-passed/result 'or/c-ordering2 @@ -112,7 +113,8 @@ 'pos 'neg) x) - '(2)) + '(2) + '(2 2)) ; result if contract is applied twice (test/spec-passed 'or/c-hmm @@ -185,7 +187,8 @@ 'pos 'neg) x) - '(1 2)) + '(1 2) + '(1 2 1 2)) ; result if contract is applied twice (test/spec-passed/result 'ho-and/c-ordering @@ -199,7 +202,8 @@ 'neg) 1) (reverse x)) - '(3 1 2 4)) + '(3 1 2 4) + '(3 1 3 1 2 4 2 4)) ; result if contract is applied twice (test/spec-passed/result 'and/c-isnt @@ -339,7 +343,8 @@ 'pos 'neg) x) - '(1 2)) + '(1 2) + '(1 2 1 2)) ; result if contract is applied twice (test/spec-passed/result 'first-or/c-ordering2 @@ -349,7 +354,8 @@ 'pos 'neg) x) - '(2)) + '(2) + '(2 2)) ; result if contract is applied twice (test/spec-passed 'first-or/c-hmm diff --git a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt index bc510a082e..ca5f93fe63 100644 --- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt +++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt @@ -953,7 +953,8 @@ (λ (x) (s 11 x)) 'pos 'neg) 1))) - 1) + 1 + do-not-double-wrap) (test/spec-passed/result 'struct/dc-new42 diff --git a/pkgs/racket-test/tests/racket/contract/test-util.rkt b/pkgs/racket-test/tests/racket/contract/test-util.rkt index d03d22dd43..2f07a12c9b 100644 --- a/pkgs/racket-test/tests/racket/contract/test-util.rkt +++ b/pkgs/racket-test/tests/racket/contract/test-util.rkt @@ -24,6 +24,7 @@ rewrite-to-add-opt/c rewrite-to-double-wrap + do-not-double-wrap test-cases failures) @@ -208,21 +209,22 @@ (rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c") (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap")) -(define (test/spec-passed/result name expression result) +(define (test/spec-passed/result name expression result [double-wrapped-result result]) (parameterize ([compile-enforce-module-constants #f]) (contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression)) - (define (rewrite-test wrapper wrapper-name) + (define (rewrite-test wrapper wrapper-name [result* result]) (let/ec k (define rewrite-name (format "~a ~a" name wrapper-name)) (contract-eval #:test-case-name rewrite-name `(,test #:test-case-name ,rewrite-name - ',result + ',result* eval ',(wrapper expression k))))) (rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c") - (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap") + (unless (eq? double-wrapped-result do-not-double-wrap) + (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" double-wrapped-result)) (let ([new-expression (rewrite-out expression)]) (when new-expression @@ -335,6 +337,7 @@ ,(loop val) ,@new-parties) ,@new-parties)))) +(define do-not-double-wrap (gensym)) ; recognized by some test forms ;; blame : (or/c 'pos 'neg string?) ;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message @@ -381,15 +384,15 @@ [double-name (string->symbol (format "~a+double" (syntax-e #'name)))]) #'(begin (contract-eval #:test-case-name 'name `(,test expected 'name expression)) - (define (rewrite-test wrapper name) + (define (rewrite-test wrapper name*) (let/ec k (contract-eval - #:test-case-name name + #:test-case-name name* `(,test expected - 'opt-name + ',name* ,(wrapper 'expression k))))) - (rewrite-test 'opt-name rewrite-to-add-opt/c) - (rewrite-test 'double-name rewrite-to-double-wrap)))])) + (rewrite-test rewrite-to-add-opt/c 'opt-name) + (rewrite-test rewrite-to-double-wrap 'double-name)))])) (define (test/well-formed stx) (contract-eval diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt index 5d169532fe..e060273d86 100644 --- a/pkgs/racket-test/tests/racket/contract/vector.rkt +++ b/pkgs/racket-test/tests/racket/contract/vector.rkt @@ -146,6 +146,7 @@ (vector 0) 'pos 'neg) 0) - 1) + 1 + 2) )