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

Replaced make-proj-contract with simple-contract in tests.

Browse Source 
svn: r17737
This commit is contained in:
Carl Eastlund 2010-01-19 05:31:18 +00:00
parent e94bef6938
commit 888045dcf9
1 changed files with 19 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/tests/mzscheme/contract-test.ss
View File

@ -2291,49 +2291,46 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; make-proj-contract ;; simple-contract
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(contract-eval (contract-eval
'(define proj:add1->sub1 '(define proj:add1->sub1
(make-proj-contract (simple-contract
'proj:add1->sub1 #:name 'proj:add1->sub1
(lambda (pos neg src name blame) #:projection
(lambda (blame)
(lambda (f) (lambda (f)
(unless (and (procedure? f) (procedure-arity-includes? f 1)) (unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-contract-error f src pos name (raise-blame-error blame f "expected a unary function, got: ~e" f))
"expected a unary function, got: ~e"
f))
(lambda (x) (lambda (x)
(unless (and (integer? x) (exact? x)) (unless (and (integer? x) (exact? x))
(raise-contract-error x src neg name (raise-blame-error (blame-swap blame) x
"expected an integer, got: ~e" "expected an integer, got: ~e" x))
x))
(let* ([y (f (add1 x))]) (let* ([y (f (add1 x))])
(unless (and (integer? y) (exact? y)) (unless (and (integer? y) (exact? y))
(raise-contract-error y src pos name (raise-blame-error blame y "expected an integer, got: ~e" y))
"expected an integer, got: ~e"
y))
(sub1 y))))) (sub1 y)))))
#:first-order
(lambda (f) (lambda (f)
(and (procedure? f) (procedure-arity-includes? f 1)))))) (and (procedure? f) (procedure-arity-includes? f 1))))))
(test/spec-passed/result (test/spec-passed/result
'make-proj-contract-1 'simple-contract-1
'((contract proj:add1->sub1 sqrt 'pos 'neg) 15) '((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
3) 3)
(test/pos-blame (test/pos-blame
'make-proj-contract-2 'simple-contract-2
'(contract proj:add1->sub1 'dummy 'pos 'neg)) '(contract proj:add1->sub1 'dummy 'pos 'neg))
(test/pos-blame (test/pos-blame
'make-proj-contract-3 'simple-contract-3
'((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2))
(test/neg-blame (test/neg-blame
'make-proj-contract-4 'simple-contract-4
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
; ;
@ -5263,12 +5260,12 @@
'(begin '(begin
(define proj:blame/c (define proj:blame/c
(make-proj-contract (simple-contract
'proj:blame/c #:name 'proj:blame/c
(lambda (pos neg src name blame) #:projection
(lambda (blame)
(lambda (x) (lambda (x)
(if blame 'positive 'negative))) (if blame 'positive 'negative)))))
(lambda (x) #t)))
(define call*0 'dummy) (define call*0 'dummy)
(define (call*1 x0) x0) (define (call*1 x0) x0)