suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix test failures for new double-wrapping tests.

Browse Source 
Everything passes.
This commit is contained in:
Vincent St-Amour 2016-02-11 17:08:45 -06:00
parent 6ee45a156d
commit 0961cf9412
8 changed files with 52 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test/tests/racket/contract/arrow-d.rkt
View File

@ -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

24
pkgs/racket-test/tests/racket/contract/arrow-i.rkt
View File

@ -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

3
pkgs/racket-test/tests/racket/contract/make-contract.rkt
View File

@ -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

3
pkgs/racket-test/tests/racket/contract/make-proj-contract.rkt
View File

@ -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

18
pkgs/racket-test/tests/racket/contract/or-and.rkt
View File

@ -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

3
pkgs/racket-test/tests/racket/contract/struct-dc.rkt
View File

@ -953,7 +953,8 @@
(λ (x) (s 11 x))
'pos
'neg) 1)))
1)
1
do-not-double-wrap)
(test/spec-passed/result
'struct/dc-new42

21
pkgs/racket-test/tests/racket/contract/test-util.rkt
View File

@ -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

3
pkgs/racket-test/tests/racket/contract/vector.rkt
View File

@ -146,6 +146,7 @@
(vector 0)
'pos 'neg)
0)
1)
1
2)
)