Revert this all the way back to where it was, I'll fix it up in a sec.
svn: r11713 original commit: 14ef34e8e38e32029783d8207a684859fba7e3c0
This commit is contained in:
Stevie Strickland
parent
44116e67e9
commit
4c6ee3623e
|
|
@ -81,7 +81,7 @@ of the contract library does not change over time.
|
|||
(equal?
|
||||
blame
|
||||
(cond
|
||||
[(regexp-match #rx"(^| )(.*) broke" msg)
|
||||
[(regexp-match #rx"(^| )([^ ]*) broke" msg)
|
||||
=>
|
||||
(λ (x) (caddr x))]
|
||||
[else (format "no blame in error message: \"~a\"" msg)])))
|
||||
|
|
@ -103,8 +103,8 @@ of the contract library does not change over time.
|
|||
(and (exn? exn)
|
||||
(,has-proper-blame? (exn-message exn))))))))))
|
||||
|
||||
(define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
|
||||
(define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
|
||||
(define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
|
||||
(define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
|
||||
|
||||
(define (test/well-formed stx)
|
||||
(contract-eval
|
||||
|
|
@ -126,7 +126,7 @@ of the contract library does not change over time.
|
|||
(contract-eval `(,test #t flat-contract? ,contract))
|
||||
(test/spec-failed (format "~a fail" name)
|
||||
`(contract ,contract ',fail 'pos 'neg)
|
||||
"module pos")
|
||||
"pos")
|
||||
(test/spec-passed/result
|
||||
(format "~a pass" name)
|
||||
`(contract ,contract ',pass 'pos 'neg)
|
||||
|
|
@ -1577,50 +1577,42 @@ of the contract library does not change over time.
|
|||
'(let ()
|
||||
(define/contract i integer? #t)
|
||||
i)
|
||||
"definition i")
|
||||
"i")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract3
|
||||
'(let ()
|
||||
(define/contract i (-> integer? integer?) (lambda (x) #t))
|
||||
(i 1))
|
||||
"definition i")
|
||||
"i")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract4
|
||||
'(let ()
|
||||
(define/contract i (-> integer? integer?) (lambda (x) 1))
|
||||
(i #f))
|
||||
"the top level")
|
||||
"<<unknown>>")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract5
|
||||
'(let ()
|
||||
(define/contract (i x) (-> integer? integer?) 1)
|
||||
(i #f))
|
||||
"the top level")
|
||||
(define/contract i (-> integer? integer?) (lambda (x) (i #t)))
|
||||
(i 1))
|
||||
"<<unknown>>")
|
||||
|
||||
(test/spec-passed
|
||||
'define/contract6
|
||||
'(let ()
|
||||
(define/contract (i x) (-> integer? integer?)
|
||||
(cond
|
||||
[(not (integer? x)) 1]
|
||||
[else (i #f)]))
|
||||
(i 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'define/contract7
|
||||
'(let ()
|
||||
(define/contract (contracted-func label t)
|
||||
(define/contract contracted-func
|
||||
(string? string? . -> . string?)
|
||||
t)
|
||||
(lambda (label t)
|
||||
t))
|
||||
(contracted-func
|
||||
"I'm a string constant with side effects"
|
||||
"ans")))
|
||||
|
||||
(test/spec-passed
|
||||
'define/contract8
|
||||
'define/contract7
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite-define1 mzscheme
|
||||
(require mzlib/contract)
|
||||
|
|
@ -1628,149 +1620,7 @@ of the contract library does not change over time.
|
|||
x))
|
||||
(eval '(require 'contract-test-suite-define1))))
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract9
|
||||
'(let ()
|
||||
(define/contract (a n)
|
||||
(-> number? number?)
|
||||
(define/contract (b m)
|
||||
(-> number? number?)
|
||||
(+ m 1))
|
||||
(b (zero? n)))
|
||||
(a 5))
|
||||
"function a")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract10
|
||||
'(let ()
|
||||
(define/contract (a n)
|
||||
(-> number? number?)
|
||||
(define/contract (b m)
|
||||
(-> number? number?)
|
||||
#t)
|
||||
(b (add1 n)))
|
||||
(a 5))
|
||||
"function b")
|
||||
|
||||
(test/spec-passed
|
||||
'define/contract11
|
||||
'(let ()
|
||||
(define/contract (f n)
|
||||
(-> number? number?)
|
||||
(+ n 1))
|
||||
(define/contract (g b m)
|
||||
(-> boolean? number? number?)
|
||||
(if b (f m) (f #t)))
|
||||
(g #t 3)))
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract12
|
||||
'(let ()
|
||||
(define/contract (f n)
|
||||
(-> number? number?)
|
||||
(+ n 1))
|
||||
(define/contract (g b m)
|
||||
(-> boolean? number? number?)
|
||||
(if b (f m) (f #t)))
|
||||
(g #f 3))
|
||||
"function g")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract13
|
||||
'(begin
|
||||
(eval '(module foo-dc13 mzscheme
|
||||
(require mzlib/contract)
|
||||
(define/contract (foo-dc13 n)
|
||||
(-> number? number?)
|
||||
(+ n 1))
|
||||
(foo-dc13 #t)))
|
||||
(eval '(require 'foo-dc13)))
|
||||
"module foo-dc13")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract14
|
||||
'(begin
|
||||
(eval '(module foo-dc14 mzscheme
|
||||
(require mzlib/contract)
|
||||
(provide foo-dc14)
|
||||
(define/contract (foo-dc14 n)
|
||||
(-> number? number?)
|
||||
(+ n 1))))
|
||||
(eval '(module bar-dc14 mzscheme
|
||||
(require 'foo-dc14)
|
||||
(foo-dc14 #t)))
|
||||
(eval '(require 'bar-dc14)))
|
||||
"module bar-dc14")
|
||||
|
||||
(test/spec-failed
|
||||
'define/contract15
|
||||
'(begin
|
||||
(eval '(module foo-dc15 mzscheme
|
||||
(require mzlib/contract)
|
||||
(provide foo-dc15)
|
||||
(define/contract (foo-dc15 n)
|
||||
(-> number? number?)
|
||||
(+ n 1))))
|
||||
(eval '(require 'foo-dc15))
|
||||
(eval '(foo-dc15 #t)))
|
||||
"the top level")
|
||||
|
||||
(test/spec-passed
|
||||
'with-contract1
|
||||
'(let ()
|
||||
(with-contract odd-even
|
||||
([odd? (-> number? boolean?)]
|
||||
[even? (-> number? boolean?)])
|
||||
(define (odd? n)
|
||||
(if (zero? n) #f (even? (sub1 n))))
|
||||
(define (even? n)
|
||||
(if (zero? n) #t (odd? (sub1 n)))))
|
||||
(odd? 5)))
|
||||
|
||||
(test/spec-failed
|
||||
'with-contract2
|
||||
'(let ()
|
||||
(with-contract odd-even
|
||||
([odd? (-> number? boolean?)]
|
||||
[even? (-> number? boolean?)])
|
||||
(define (odd? n)
|
||||
(if (zero? n) #f (even? (sub1 n))))
|
||||
(define (even? n)
|
||||
(if (zero? n) #t (odd? (sub1 n)))))
|
||||
(odd? #t))
|
||||
"the top level")
|
||||
|
||||
(test/spec-failed
|
||||
'with-contract3
|
||||
'(let ()
|
||||
(with-contract odd-even
|
||||
([odd? (-> number? boolean?)]
|
||||
[even? (-> number? boolean?)])
|
||||
(define (odd? n)
|
||||
(if (zero? n) n (even? (sub1 n))))
|
||||
(define (even? n)
|
||||
(if (zero? n) #t (odd? (sub1 n)))))
|
||||
(odd? 4))
|
||||
"region odd-even")
|
||||
|
||||
;; Functions within the same with-contract region can call
|
||||
;; each other however they want, so here we have even?
|
||||
;; call odd? with a boolean, even though its contract in
|
||||
;; the odd-even contract says it only takes numbers.
|
||||
(test/spec-passed
|
||||
'with-contract4
|
||||
'(let ()
|
||||
(with-contract odd-even
|
||||
([odd? (-> number? boolean?)]
|
||||
[even? (-> number? boolean?)])
|
||||
(define (odd? n)
|
||||
(cond
|
||||
[(not (number? n)) #f]
|
||||
[(zero? n) #f]
|
||||
[else (even? (sub1 n))]))
|
||||
(define (even? n)
|
||||
(if (zero? n) #t (odd? (zero? n)))))
|
||||
(odd? 5)))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -4793,7 +4643,7 @@ so that propagation occurs.
|
|||
(provide/contract (x integer?))))
|
||||
(eval '(require 'contract-test-suite3))
|
||||
(eval 'x))
|
||||
"module 'contract-test-suite3")
|
||||
"'contract-test-suite3")
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract4
|
||||
|
|
@ -4970,7 +4820,7 @@ so that propagation occurs.
|
|||
(make-s 1 2)
|
||||
[s-a #f])))
|
||||
(eval '(require 'pc11b-n)))
|
||||
"module 'n")
|
||||
'n)
|
||||
|#
|
||||
|
||||
(test/spec-passed
|
||||
|
|
@ -5038,7 +4888,7 @@ so that propagation occurs.
|
|||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require 'pos)))
|
||||
"module 'pos")
|
||||
"'pos")
|
||||
|
||||
;; this is really a positive violation, but name the module `neg' just for an addl test
|
||||
(test/spec-failed
|
||||
|
|
@ -5049,7 +4899,7 @@ so that propagation occurs.
|
|||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require 'neg)))
|
||||
"module 'neg")
|
||||
"'neg")
|
||||
|
||||
;; this test doesn't pass yet ... waiting for support from define-struct
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user