Add all changes from branches/with-contract (which this branch will replace
eventually), plus a couple of fixes in contract-test.ss. svn: r12451 original commit: 3212d1171217a93eb2865a602092d5b5d842ff40
This commit is contained in:
parent
fe2ab39bbd
commit
7a657d334f
|
@ -15,6 +15,13 @@
|
|||
(require "private/contract-object.ss")
|
||||
(provide (all-from-out "private/contract-object.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; old-style define/contract
|
||||
;;
|
||||
|
||||
(require "private/contract-define.ss")
|
||||
(provide (all-from-out "private/contract-define.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
@ -22,7 +29,9 @@
|
|||
;; except the arrow contracts
|
||||
;;
|
||||
|
||||
(require scheme/private/contract
|
||||
(require (except-in scheme/private/contract
|
||||
define/contract
|
||||
with-contract)
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-opt
|
||||
|
|
|
@ -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,14 +1577,14 @@ 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
|
||||
|
@ -4643,7 +4643,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
|
||||
|
@ -4820,7 +4820,7 @@ so that propagation occurs.
|
|||
(make-s 1 2)
|
||||
[s-a #f])))
|
||||
(eval '(require 'pc11b-n)))
|
||||
'n)
|
||||
"module 'n")
|
||||
|#
|
||||
|
||||
(test/spec-passed
|
||||
|
@ -4888,7 +4888,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
|
||||
|
@ -4899,7 +4899,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
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user