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

..

Browse Source 
original commit: 469c5955232de520b8ec1e42458d3ce960b78bcc
This commit is contained in:
Robby Findler 2003-01-28 05:05:21 +00:00
parent 896737caf8
commit 169a15dc3d
2 changed files with 49 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/contracts.ss
View File

@ -1,3 +0,0 @@
(module contracts mzscheme
(require "contract.ss")
(provide (all-from "contract.ss")))

97
collects/tests/mzscheme/contracts.ss → collects/tests/mzscheme/contract-test.ss
View File

@ -1,8 +1,8 @@
(load-relative "loadtest.ss")
(require (lib "specs.ss" "framework")
(require (lib "contract.ss")
(lib "class.ss"))
(SECTION 'contracts)
(SECTION 'contract)
(parameterize ([error-print-width 200])
(let ()
@ -522,7 +522,7 @@
'provide/contract1
'(let ()
(eval '(module contract-test-suite1 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract (x integer?))
(define x 1)))
(eval '(require contract-test-suite1))
@ -532,7 +532,7 @@
'provide/contract2
'(let ()
(eval '(module contract-test-suite2 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract)))
(eval '(require contract-test-suite2))))
@ -540,7 +540,7 @@
'provide/contract3
'(let ()
(eval '(module contract-test-suite3 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract (x integer?))
(define x #f)))
(eval '(require contract-test-suite3))
@ -551,7 +551,7 @@
'provide/contract4
'(let ()
(eval '(module contract-test-suite4 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract (struct s ((a any?))))
(define-struct s (a))))
(eval '(require contract-test-suite4))
@ -564,7 +564,7 @@
'provide/contract5
'(let ()
(eval '(module contract-test-suite5 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract (struct s ((a any?)))
(struct t ((a any?))))
(define-struct s (a))
@ -583,7 +583,7 @@
'provide/contract6
'(let ()
(eval '(module contract-test-suite6 mzscheme
(require (lib "contracts.ss"))
(require (lib "contract.ss"))
(provide/contract (struct s ((a any?))))
(define-struct s (a))))
(eval '(require contract-test-suite6))
@ -902,6 +902,8 @@
(apply super-make-object x))
1 2 3))
#|
(test/spec-passed/result
'object-contract1
'(send
@ -942,7 +944,42 @@
m
1)
"pos")
(test/spec-passed/result
'object-contract=>1
'(let* ([c% (class object% (super-instantiate ()))]
[c (make-object c%)]
[wc (contract (object-contract) c 'pos-c 'neg-c)]
[d% (class c% (super-instantiate ()))]
[d (make-object d%)]
[wd (contract (object-contract) d 'pos-d 'neg-d)])
(list (is-a? c c%)
(is-a? wc c%)
(is-a? d c%)
(is-a? wd c%)
(interface-extension? (object-interface d) (object-interface c))))
(list #t #t #t #t #t))
(test/spec-passed
'recursive-object1
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (m (-> cc cc)))]
[% (class object% (define/public (m x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m d)
(send d m c)))
(test/spec-failed
'recursive-object2
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (n (-> cc cc)))]
[% (class object% (define/public (m x) x) (define/public (n x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m c))
"c-neg")
|#
(test/spec-failed
'class-contract=>1
'(let* ([c% (contract (class-contract (public m ((>=/c 10) . -> . (>=/c 10))))
@ -982,22 +1019,7 @@
(is-a? (instantiate wd% ()) wc%)
(is-a? (instantiate wd% ()) (class->interface wc%))))
(list #t #t #t #t #t #t))
(test/spec-passed/result
'object-contract=>1
'(let* ([c% (class object% (super-instantiate ()))]
[c (make-object c%)]
[wc (contract (object-contract) c 'pos-c 'neg-c)]
[d% (class c% (super-instantiate ()))]
[d (make-object d%)]
[wd (contract (object-contract) d 'pos-d 'neg-d)])
(list (is-a? c c%)
(is-a? wc c%)
(is-a? d c%)
(is-a? wd c%)
(interface-extension? (object-interface d) (object-interface c))))
(list #t #t #t #t #t))
(test/spec-passed
'recursive-class1
'(letrec ([cc (class-contract (public m (-> dd dd)))]
@ -1014,28 +1036,7 @@
[c% (contract cc (class object% (define/public (m x) x) (super-instantiate ())) 'c-pos 'c-neg)]
[d% (contract dd (class object% (define/public (n x) x) (super-instantiate ())) 'd-pos 'd-neg)])
(send (make-object c%) m c%))
"c-neg")
(test/spec-passed
'recursive-object1
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (m (-> cc cc)))]
[% (class object% (define/public (m x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m d)
(send d m c)))
(test/spec-failed
'recursive-object2
'(letrec ([cc (object-contract (m (-> dd dd)))]
[dd (object-contract (n (-> cc cc)))]
[% (class object% (define/public (m x) x) (define/public (n x) x) (super-instantiate ()))]
[c (contract cc (make-object %) 'c-pos 'c-neg)]
[d (contract dd (make-object %) 'd-pos 'd-neg)])
(send c m c))
"c-neg")
"c-neg")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -1061,4 +1062,4 @@
))
(report-errs)
(report-errs)