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

added this, bound in ->r and ->pp contracts, when used in object-contract

Browse Source 
svn: r1841

original commit: 12c7c0b6c65158b8685d7fd87f16e504b6de3de0
This commit is contained in:
Robby Findler 2006-01-16 18:42:11 +00:00
parent 91da1bd212
commit dac5388cd0
1 changed files with 123 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2355,6 +2355,48 @@
'pos
'neg)
m))
(test/neg-blame
'object-contract-->r/this-1
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new)))
'pos
'neg)
m
2))
(test/spec-passed
'object-contract-->r/this-2
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new)))
'pos
'neg)
m
1))
(test/neg-blame
'object-contract-->r/this-3
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
rest-var any/c
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new)))
'pos
'neg)
m
2))
(test/spec-passed
'object-contract-->r/this-4
'(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))])
rest-var any/c
any)))
(new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new)))
'pos
'neg)
m
1))
(test/spec-passed
'object-contract-->pp1
@ -2416,6 +2458,86 @@
'neg)
m))
(test/neg-blame
'object-contract-->pp/this-1
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 2]) (define/public m (lambda () (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/pos-blame
'object-contract-->pp/this-2
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda () (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/spec-passed
'object-contract-->pp/this-3
'(send (contract (object-contract (m (->pp ()
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda () (set! f 2))) (super-new)))
'pos
'neg)
m))
(test/neg-blame
'object-contract-->pp/this-4
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 2]) (define/public m (lambda args (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/pos-blame
'object-contract-->pp/this-5
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda args (set! f 3))) (super-new)))
'pos
'neg)
m))
(test/spec-passed
'object-contract-->pp/this-6
'(send (contract (object-contract (m (->pp-rest ()
rest-id
any/c
(= 1 (get-field f this))
any/c
result-x
(= 2 (get-field f this)))))
(new (class object% (field [f 1]) (define/public m (lambda args (set! f 2))) (super-new)))
'pos
'neg)
m))
(test/spec-passed/result
'object-contract-drop-method1
'(send (contract (object-contract (m (-> integer? integer?)))
@ -3135,7 +3257,7 @@
[(x y) y]))
(provide/contract (contract-inferred-name-test6 (opt-> (number?) (number?) number?)))))
(eval '(require contract-test-suite-inferred-name1))
(eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly.
(eval '(test 'contract-inferred-name-test2 object-name contract-inferred-name-test2))
(eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3))
(eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4))