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

* Fix converting modules whose source is (list 'quote 'name) to "module 'name"

Browse Source 
in contract messages
 * Differentiate between define/contract functions and normal definitions
 * Fix up contract tests

svn: r11700

original commit: e83a72d6ae3b71d97817e6aab5dfd34dfa435a5f
This commit is contained in:
Stevie Strickland 2008-09-12 20:46:41 +00:00
commit 094e5a90ff
1 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -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 "pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
(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/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)
"pos")
"module pos")
(test/spec-passed/result
(format "~a pass" name)
`(contract ,contract ',pass 'pos 'neg)
@ -1577,28 +1577,28 @@ of the contract library does not change over time.
'(let ()
(define/contract i integer? #t)
i)
"i")
"definition i")
(test/spec-failed
'define/contract3
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) #t))
(i 1))
"i")
"definition i")
(test/spec-failed
'define/contract4
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) 1))
(i #f))
"top-level")
"the top level")
(test/spec-failed
'define/contract5
'(let ()
(define/contract (i x) (-> integer? integer?) 1)
(i #f))
"top-level")
"the top level")
(test/spec-passed
'define/contract6
@ -1638,7 +1638,7 @@ of the contract library does not change over time.
(+ m 1))
(b (zero? n)))
(a 5))
"a")
"function a")
(test/spec-failed
'define/contract10
@ -1650,7 +1650,7 @@ of the contract library does not change over time.
#t)
(b (add1 n)))
(a 5))
"b")
"function b")
(test/spec-passed
'define/contract11
@ -1673,7 +1673,7 @@ of the contract library does not change over time.
(-> boolean? number? number?)
(if b (f m) (f #t)))
(g #f 3))
"g")
"function g")
(test/spec-passed
'with-contract1
@ -1698,7 +1698,7 @@ of the contract library does not change over time.
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(odd? #t))
"top-level")
"the top level")
(test/spec-failed
'with-contract3
@ -1711,7 +1711,7 @@ of the contract library does not change over time.
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(odd? 4))
"odd-even")
"region odd-even")
;; Functions within the same with-contract region can call
;; each other however they want, so here we have even?
@ -4753,7 +4753,7 @@ so that propagation occurs.
(provide/contract (x integer?))))
(eval '(require 'contract-test-suite3))
(eval 'x))
"'contract-test-suite3")
"module 'contract-test-suite3")
(test/spec-passed
'provide/contract4
@ -4930,7 +4930,7 @@ so that propagation occurs.
(make-s 1 2)
[s-a #f])))
(eval '(require 'pc11b-n)))
'n)
"module 'n")
|#
(test/spec-passed
@ -4998,7 +4998,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'pos)))
"'pos")
"module 'pos")
;; this is really a positive violation, but name the module `neg' just for an addl test
(test/spec-failed
@ -5009,7 +5009,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'neg)))
"'neg")
"module 'neg")
;; this test doesn't pass yet ... waiting for support from define-struct