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")))

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

@ -1,8 +1,8 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(require (lib "specs.ss" "framework") (require (lib "contract.ss")
(lib "class.ss")) (lib "class.ss"))
(SECTION 'contracts) (SECTION 'contract)
(parameterize ([error-print-width 200]) (parameterize ([error-print-width 200])
(let () (let ()
@ -522,7 +522,7 @@
'provide/contract1 'provide/contract1
'(let () '(let ()
(eval '(module contract-test-suite1 mzscheme (eval '(module contract-test-suite1 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract (x integer?)) (provide/contract (x integer?))
(define x 1))) (define x 1)))
(eval '(require contract-test-suite1)) (eval '(require contract-test-suite1))
@ -532,7 +532,7 @@
'provide/contract2 'provide/contract2
'(let () '(let ()
(eval '(module contract-test-suite2 mzscheme (eval '(module contract-test-suite2 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract))) (provide/contract)))
(eval '(require contract-test-suite2)))) (eval '(require contract-test-suite2))))
@ -540,7 +540,7 @@
'provide/contract3 'provide/contract3
'(let () '(let ()
(eval '(module contract-test-suite3 mzscheme (eval '(module contract-test-suite3 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract (x integer?)) (provide/contract (x integer?))
(define x #f))) (define x #f)))
(eval '(require contract-test-suite3)) (eval '(require contract-test-suite3))
@ -551,7 +551,7 @@
'provide/contract4 'provide/contract4
'(let () '(let ()
(eval '(module contract-test-suite4 mzscheme (eval '(module contract-test-suite4 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract (struct s ((a any?)))) (provide/contract (struct s ((a any?))))
(define-struct s (a)))) (define-struct s (a))))
(eval '(require contract-test-suite4)) (eval '(require contract-test-suite4))
@ -564,7 +564,7 @@
'provide/contract5 'provide/contract5
'(let () '(let ()
(eval '(module contract-test-suite5 mzscheme (eval '(module contract-test-suite5 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract (struct s ((a any?))) (provide/contract (struct s ((a any?)))
(struct t ((a any?)))) (struct t ((a any?))))
(define-struct s (a)) (define-struct s (a))
@ -583,7 +583,7 @@
'provide/contract6 'provide/contract6
'(let () '(let ()
(eval '(module contract-test-suite6 mzscheme (eval '(module contract-test-suite6 mzscheme
(require (lib "contracts.ss")) (require (lib "contract.ss"))
(provide/contract (struct s ((a any?)))) (provide/contract (struct s ((a any?))))
(define-struct s (a)))) (define-struct s (a))))
(eval '(require contract-test-suite6)) (eval '(require contract-test-suite6))
@ -902,6 +902,8 @@
(apply super-make-object x)) (apply super-make-object x))
1 2 3)) 1 2 3))
#|
(test/spec-passed/result (test/spec-passed/result
'object-contract1 'object-contract1
'(send '(send
@ -943,6 +945,41 @@
1) 1)
"pos") "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 (test/spec-failed
'class-contract=>1 'class-contract=>1
'(let* ([c% (contract (class-contract (public m ((>=/c 10) . -> . (>=/c 10)))) '(let* ([c% (contract (class-contract (public m ((>=/c 10) . -> . (>=/c 10))))
@ -983,21 +1020,6 @@
(is-a? (instantiate wd% ()) (class->interface wc%)))) (is-a? (instantiate wd% ()) (class->interface wc%))))
(list #t #t #t #t #t #t)) (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 (test/spec-passed
'recursive-class1 'recursive-class1
'(letrec ([cc (class-contract (public m (-> dd dd)))] '(letrec ([cc (class-contract (public m (-> dd dd)))]
@ -1016,27 +1038,6 @@
(send (make-object c%) m c%)) (send (make-object c%) m c%))
"c-neg") "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")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; ;; ;;
;; Flat Contract Tests ;; ;; Flat Contract Tests ;;