From e08ead165abe744ef4a6d47f5ef3bfed973747d1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Jan 2007 02:54:16 +0000 Subject: [PATCH] merged the opt/c changes back into the trunk (finally!) svn: r5481 original commit: 4ad8fdadeaf56e8e373a947f6d2d0f451d959233 --- collects/mzlib/contract.ss | 12 +- collects/tests/mzscheme/contract-test.ss | 1607 +++++++++++----------- 2 files changed, 793 insertions(+), 826 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 15c228c..59a2687 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -9,14 +9,10 @@ "private/contract-basic-opters.ss") (provide - ;; opt is not ready yet - #;(all-from "private/contract-opt.ss") - #;(all-from-except "private/contract-opt-guts.ss" - make-opt-contract - orig-ctc-prop - orig-ctc-pred? - orig-ctc-get) - (all-from "private/contract-ds.ss") + opt/c ;(all-from "private/contract-opt.ss") + (all-from-except "private/contract-ds.ss" + lazy-depth-to-look) + (all-from-except "private/contract-arrow.ss" check-procedure) (all-from-except "private/contract-guts.ss" diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index a26e36f..172b770 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1,93 +1,141 @@ (load-relative "loadtest.ss") -(require (lib "contract.ss") - (lib "class.ss") - (lib "etc.ss")) - (Section 'contract) (parameterize ([error-print-width 200]) (let () + + (define contract-namespace + (let ([n (make-namespace)]) + (parameterize ([current-namespace n]) + (eval '(require-for-template mzscheme)) + (eval '(require-for-syntax mzscheme)) + (eval '(require (lib "contract.ss") + (lib "class.ss") + (lib "etc.ss")))) + n)) + + (define (contract-eval x) + (parameterize ([current-namespace contract-namespace]) + (eval x))) + + (define-syntax (ctest stx) + (syntax-case stx () + [(_ a ...) + (syntax (contract-eval `(,test a ...)))])) + + (define (contract-error-test exp exn-ok?) + (test #t + 'contract-error-test + (contract-eval `(with-handlers ((exn? (λ (x) (and (,exn-ok? x) #t)))) ,exp)))) + ;; test/spec-passed : symbol sexp -> void ;; tests a passing specification (define (test/spec-passed name expression) (printf "testing: ~s\n" name) - (test (void) - (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) - (list expression '(void)))) + (contract-eval + `(,test + (void) + (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) + (list ',expression '(void)))) + (let/ec k + (contract-eval + `(,test (void) + (let ([for-each-eval (lambda (l) (for-each (λ (x) (eval x)) l))]) + for-each-eval) + (list ',(rewrite expression k) '(void)))))) (define (test/spec-passed/result name expression result) (printf "testing: ~s\n" name) - (test result + (contract-eval `(,test ',result eval ',expression)) + (let/ec k + (contract-eval + `(,test + ',result eval - expression)) + ',(rewrite expression k))))) + + ;; rewrites `contract' to use opt/c. If there is a module definition in there, we skip that test. + (define (rewrite exp k) + (let loop ([exp exp]) + (cond + [(null? exp) null] + [(list? exp) + (case (car exp) + [(contract) `(contract (opt/c ,(loop (cadr exp))) ,@(map loop (cddr exp)))] + [(module) (k #f)] + [else (map loop exp)])] + [(pair? exp) (cons (loop (car exp)) + (loop (cdr exp)))] + [else exp]))) (define (test/spec-failed name expression blame) - (cond - [(equal? blame "pos") - (test/pos-blame name expression)] - [(equal? blame "neg") - (test/neg-blame name expression)] - [else - (let () - (define (has-proper-blame? msg) - (equal? - blame - (cond - [(regexp-match #rx"^([^ ]*) broke" msg) => cadr] - [else (format "no blame in error message: \"~a\"" msg)]))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) + (let () + (define (has-proper-blame? msg) + (equal? + blame + (cond + [(regexp-match #rx"(^| )([^ ]*) broke" msg) + => + (λ (x) (caddr x))] + [else (format "no blame in error message: \"~a\"" msg)]))) + (printf "testing: ~s\n" name) + (contract-eval + `(,thunk-error-test + (lambda () ,expression) + (datum->syntax-object #'here ',expression) (lambda (exn) (and (exn? exn) - (has-proper-blame? (exn-message exn))))))])) + (,has-proper-blame? (exn-message exn)))))) + (let/ec k + (let ([rewritten (rewrite expression k)]) + (contract-eval + `(,thunk-error-test + (lambda () ,rewritten) + (datum->syntax-object #'here ',rewritten) + (lambda (exn) + (and (exn? exn) + (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) - (define (has-pos-blame? exn) - (and (exn? exn) - (and (regexp-match #rx"pos broke" (exn-message exn))))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) - has-pos-blame?)) - - (define (test/neg-blame name expression) - (define (has-neg-blame? exn) - (and (exn? exn) - (and (regexp-match #rx"neg broke" (exn-message exn))))) - (printf "testing: ~s\n" name) - (thunk-error-test - (lambda () (eval expression)) - (datum->syntax-object #'here expression) - has-neg-blame?)) + (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/well-formed stx) - (test (void) - (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) - stx)) + (contract-eval + `(,test (void) + (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void) + ,stx))) (define (test/no-error sexp) - (test (void) - eval - `(begin ,sexp (void)))) + (contract-eval + `(,test (void) + eval + '(begin ,sexp (void))))) (define (test-flat-contract contract pass fail) - (let ([name (if (pair? contract) - (car contract) - contract)]) - (test #t flat-contract? (eval contract)) - (test/spec-failed (format "~a fail" name) - `(contract ,contract ',fail 'pos 'neg) - "pos") - (test/spec-passed/result - (format "~a pass" name) - `(contract ,contract ',pass 'pos 'neg) - pass))) + (define (run-three-tests contract) + (let ([name (if (pair? contract) + (car contract) + contract)]) + (contract-eval `(,test #t flat-contract? ,contract)) + (test/spec-failed (format "~a fail" name) + `(contract ,contract ',fail 'pos 'neg) + "pos") + (test/spec-passed/result + (format "~a pass" name) + `(contract ,contract ',pass 'pos 'neg) + pass))) + (run-three-tests contract) + (let/ec k (run-three-tests (rewrite contract k)))) - (define (test-name name contract) - (test name contract-name contract)) + (define-syntax (test-name stx) + (syntax-case stx () + [(_ name contract) + #'(do-name-test 'name 'contract)])) + + (define (do-name-test name contract-exp) + (printf "~s\n" (list 'do-name-test name contract-exp)) + (contract-eval `(,test ,name contract-name ,contract-exp)) + (contract-eval `(,test ,name contract-name (opt/c ,contract-exp)))) (test/spec-passed 'contract-flat1 @@ -1406,59 +1454,62 @@ 'or/c14 '(contract (or/c not) #f 'pos 'neg)) - (test 1 - 'or/c-not-error-early - (begin (or/c (-> integer? integer?) (-> boolean? boolean?)) - 1)) - (error-test #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) - (λ (x) x) - 'pos - 'neg) - exn:fail?) + (test/spec-passed/result + 'or/c-not-error-early + '(begin (or/c (-> integer? integer?) (-> boolean? boolean?)) + 1) + 1) - (test - '(1 2) + (contract-error-test + #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) + (λ (x) x) + 'pos + 'neg) + exn:fail?) + + (test/spec-passed/result 'or/c-ordering - (let ([x '()]) - (contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - '(2) - 'or/c-ordering2 - (let ([x '()]) - (contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - '(1 2) - 'and/c-ordering - (let ([x '()]) - (contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) - 'anything - 'pos - 'neg) - x)) - - (test - (reverse '(1 3 4 2)) - 'ho-and/c-ordering - (let ([x '()]) - ((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t) - (lambda (y) (set! x (cons 2 x)) #t)) - (-> (lambda (y) (set! x (cons 3 x)) #t) - (lambda (y) (set! x (cons 4 x)) #t))) - (λ (x) x) + '(let ([x '()]) + (contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything 'pos 'neg) - 1) - x)) + x) + '(1 2)) + + (test/spec-passed/result + 'or/c-ordering2 + '(let ([x '()]) + (contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(2)) + + (test/spec-passed/result + 'and/c-ordering + '(let ([x '()]) + (contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(1 2)) + + (test/spec-passed/result + 'ho-and/c-ordering + '(let ([x '()]) + ((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t) + (lambda (y) (set! x (cons 2 x)) #t)) + (-> (lambda (y) (set! x (cons 3 x)) #t) + (lambda (y) (set! x (cons 4 x)) #t))) + (λ (x) x) + 'pos + 'neg) + 1) + x) + (reverse '(1 3 4 2))) (test/spec-passed 'define/contract1 @@ -2609,65 +2660,70 @@ ;; test error message has right format ;; - (test "procedure m method: expects 1 argument, given 2: 1 2" - 'wrong-method-arity-error-message - (with-handlers ([exn:fail? exn-message]) - (send (contract (object-contract [m (integer? . -> . integer?)]) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg) - m - 1 - 2))) + (test/spec-passed/result + 'wrong-method-arity-error-message + '(with-handlers ([exn:fail? exn-message]) + (send (contract (object-contract [m (integer? . -> . integer?)]) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg) + m + 1 + 2)) + "procedure m method: expects 1 argument, given 2: 1 2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; tests object utilities to be sure wrappers work right ;; - (let* ([o1 (new object%)] - [o2 (contract (object-contract) o1 'pos 'neg)]) - (test #t object=? o1 o1) - (test #f object=? o1 (new object%)) - (test #t object=? o1 o2) - (test #t object=? o2 o1) - (test #f object=? (new object%) o2)) + (let* ([o1 (contract-eval '(new object%))] + [o2 (contract-eval `(contract (object-contract) ,o1 'pos 'neg))]) + (test #t (contract-eval 'object=?) o1 o1) + (test #f (contract-eval 'object=?) o1 (contract-eval '(new object%))) + (test #t (contract-eval 'object=?) o1 o2) + (test #t (contract-eval 'object=?) o2 o1) + (test #f (contract-eval 'object=?) (contract-eval '(new object%)) o2)) - (test #t method-in-interface? 'm - (object-interface - (contract - (object-contract (m (integer? . -> . integer?))) - (new (class object% (define/public (m x) x) (super-new))) - 'pos - 'neg))) + (ctest #t + method-in-interface? + 'm + (object-interface + (contract + (object-contract (m (integer? . -> . integer?))) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg))) - (let* ([i<%> (interface ())] - [c% (class* object% (i<%>) (super-new))] - [o (new c%)]) - (test #t is-a? o i<%>) - (test #t is-a? o c%) - (test #t is-a? (contract (object-contract) o 'pos 'neg) i<%>) - (test #t is-a? (contract (object-contract) o 'pos 'neg) c%)) + (let* ([i<%> (contract-eval '(interface ()))] + [c% (contract-eval `(class* object% (,i<%>) (super-new)))] + [o (contract-eval `(new ,c%))]) + (test #t (contract-eval 'is-a?) o i<%>) + (test #t (contract-eval 'is-a?) o c%) + (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) + (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) (let ([c% (parameterize ([current-inspector (make-inspector)]) - (class object% (super-new)))]) + (contract-eval '(class object% (super-new))))]) (test (list c% #f) 'object-info - (call-with-values - (lambda () (object-info (contract (object-contract) (new c%) 'pos 'neg))) - list))) + (contract-eval + `(call-with-values + (lambda () (object-info (contract (object-contract) (new ,c%) 'pos 'neg))) + list)))) ;; object->vector tests (let* ([obj (parameterize ([current-inspector (make-inspector)]) - (new (class object% (field [x 1] [y 2]) (super-new))))] - [vec (object->vector obj)]) + (contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))] + [vec (contract-eval `(object->vector ,obj))]) (test vec - object->vector - (contract (object-contract (field x integer?) (field y integer?)) - obj - 'pos - 'neg))) + (contract-eval 'object->vector) + (contract-eval + `(contract (object-contract (field x integer?) (field y integer?)) + ,obj + 'pos + 'neg)))) ; ; @@ -3096,9 +3152,9 @@ (test/spec-passed 'recursive-contract1 - (letrec ([ctc (-> integer? (recursive-contract ctc))]) - (letrec ([f (λ (x) f)]) - ((((contract ctc f 'pos 'neg) 1) 2) 3)))) + '(letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) f)]) + ((((contract ctc f 'pos 'neg) 1) 2) 3)))) (test/neg-blame 'recursive-contract2 @@ -3129,453 +3185,372 @@ ;; define-contract-struct tests ;; + (contract-eval '(define-contract-struct couple (hd tl))) (test/pos-blame 'd-c-s1 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c any/c any/c) 1 'pos 'neg))) - + '(begin + (eval '(module m mzscheme + (require (lib "contract.ss")) + (define-contract-struct couple (hd tl)) + (contract (couple/c any/c any/c) 1 'pos 'neg))) + (eval '(require m)))) (test/spec-passed 'd-c-s2 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg))) + '(contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) (test/spec-passed 'd-c-s3 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s4 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) (test/spec-passed 'd-c-s5 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg))) + (test/pos-blame 'd-c-s6 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/c number? - number?) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c number? + number?) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s7 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/c number? number?) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c number? number?) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s8 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd any/c] [tl any/c]) - 1 - 'pos 'neg))) + '(contract (couple/dc [hd any/c] [tl any/c]) + 1 + 'pos 'neg)) (test/pos-blame 'd-c-s9 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd () any/c] [tl () any/c]) - 1 - 'pos 'neg))) + '(contract (couple/dc [hd () any/c] [tl () any/c]) + 1 + 'pos 'neg)) (test/spec-passed 'd-c-s10 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd any/c] [tl any/c]) (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd any/c] [tl any/c]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s11 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd () any/c] [tl () any/c]) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd () any/c] [tl () any/c]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s12 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg))) + '(contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg)) (test/spec-passed 'd-c-s13 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) (test/spec-passed 'd-c-s14 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg))) (test/pos-blame 'd-c-s15 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) (test/pos-blame 'd-c-s16 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple #f 2) - 'pos 'neg)))) + '(couple-tl + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple #f 2) + 'pos 'neg))) (test/spec-passed 'd-c-s17 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 1 2) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 1 2) + 'pos 'neg))) (test/pos-blame 'd-c-s18 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl (hd) (>=/c hd)]) - (make-couple 2 1) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl (hd) (>=/c hd)]) + (make-couple 2 1) + 'pos 'neg))) (test/spec-passed 'd-c-s19 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (couple-tl - (contract (couple/dc [hd number?] - [tl (hd) - (let ([hd1 hd]) - (couple/dc [hd (>=/c hd1)] - [tl (hd) (>=/c hd)]))]) - (make-couple 1 (make-couple 2 3)) - 'pos 'neg))))) + '(couple-tl + (couple-tl + (contract (couple/dc [hd number?] + [tl (hd) + (let ([hd1 hd]) + (couple/dc [hd (>=/c hd1)] + [tl (hd) (>=/c hd)]))]) + (make-couple 1 (make-couple 2 3)) + 'pos 'neg)))) (test/pos-blame 'd-c-s20 - '(let () - (define-contract-struct couple (hd tl)) - (couple-tl - (couple-tl - (contract (couple/dc [hd number?] - [tl (hd) - (let ([hd1 hd]) - (couple/dc [hd (>=/c hd1)] - [tl (hd) (>=/c hd1)]))]) - (make-couple 1 (make-couple 2 0)) - 'pos 'neg))))) + '(couple-tl + (couple-tl + (contract (couple/dc [hd number?] + [tl (hd) + (let ([hd1 hd]) + (couple/dc [hd (>=/c hd1)] + [tl (hd) (>=/c hd1)]))]) + (make-couple 1 (make-couple 2 0)) + 'pos 'neg)))) (test/spec-passed 'd-c-s21 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg))) (test/spec-passed 'd-c-s22 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s23 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s24 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s25 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd number?] - [tl number?]) - (contract (couple/dc [hd (>=/c 0)] - [tl (>=/c 0)]) - (make-couple -1 2) - 'pos 'neg) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd number?] + [tl number?]) + (contract (couple/dc [hd (>=/c 0)] + [tl (>=/c 0)]) + (make-couple -1 2) + 'pos 'neg) + 'pos 'neg) + 'pos 'neg))) (test/pos-blame 'd-c-s26 - '(let () - (define-contract-struct couple (hd tl)) - (couple-hd - (contract (couple/dc [hd (>=/c 10)] - [tl (>=/c 10)]) - (contract (couple/dc [hd positive?] - [tl positive?]) - (contract (couple/dc [hd number?] - [tl number?]) - (make-couple 1 2) - 'pos 'neg) - 'pos 'neg) - 'pos 'neg)))) + '(couple-hd + (contract (couple/dc [hd (>=/c 10)] + [tl (>=/c 10)]) + (contract (couple/dc [hd positive?] + [tl positive?]) + (contract (couple/dc [hd number?] + [tl number?]) + (make-couple 1 2) + 'pos 'neg) + 'pos 'neg) + 'pos 'neg))) ;; test caching (test/spec-passed 'd-c-s27 - '(let () - (define-contract-struct couple (hd tl)) - (let ([ctc (couple/c any/c any/c)]) - (couple-hd (contract ctc (contract ctc (make-couple 1 2) 'pos 'neg) 'pos 'neg))))) + '(let ([ctc (couple/c any/c any/c)]) + (couple-hd (contract ctc (contract ctc (make-couple 1 2) 'pos 'neg) 'pos 'neg)))) ;; make sure lazy really is lazy (test/spec-passed 'd-c-s28 - '(let () - (define-contract-struct couple (hd tl)) - (contract (couple/c number? number?) - (make-couple #f #f) - 'pos 'neg))) + '(contract (couple/c number? number?) + (make-couple #f #f) + 'pos 'neg)) (test/spec-passed 'd-c-s29 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-hd - (contract (couple/c (couple/c number? number?) - (couple/c number? number?)) - (make-couple (make-couple #f #f) - (make-couple #f #f)) - 'pos 'neg)))) + '(couple-hd + (contract (couple/c (couple/c number? number?) + (couple/c number? number?)) + (make-couple (make-couple #f #f) + (make-couple #f #f)) + 'pos 'neg))) (test/spec-passed 'd-c-s30 - '(let () - (define-contract-struct couple (hd tl)) - - (couple-tl - (contract (couple/c (couple/c number? number?) - (couple/c number? number?)) - (make-couple (make-couple #f #f) - (make-couple #f #f)) - 'pos 'neg)))) + '(couple-tl + (contract (couple/c (couple/c number? number?) + (couple/c number? number?)) + (make-couple (make-couple #f #f) + (make-couple #f #f)) + 'pos 'neg))) ;; make sure second accesses work (test/spec-passed/result 'd-c-s31 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)]) - (list (couple-hd v) (couple-hd v)))) + '(let ([v (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)]) + (list (couple-hd v) (couple-hd v))) (list 1 1)) (test/pos-blame 'd-c-s32 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? boolean?) - (make-couple 1 2) - 'pos 'neg)]) - (with-handlers ([void void]) (couple-hd v)) - (couple-hd v)))) + '(let ([v (contract (couple/c number? boolean?) + (make-couple 1 2) + 'pos 'neg)]) + (with-handlers ([void void]) (couple-hd v)) + (couple-hd v))) (test/pos-blame 'd-c-s33 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c number? number?) - (make-couple 1 2) - 'pos 'neg)]) - (couple-hd v) - (couple-hd v) - (couple-hd - (contract (couple/c boolean? boolean?) - v - 'pos 'neg))))) - + '(let ([v (contract (couple/c number? number?) + (make-couple 1 2) + 'pos 'neg)]) + (couple-hd v) + (couple-hd v) + (couple-hd + (contract (couple/c boolean? boolean?) + v + 'pos 'neg)))) + + (contract-eval '(define-contract-struct single (a))) ;; a related test to the above: (test/spec-passed/result 'd-c-s34 - '(let () - (define-contract-struct s (a) (make-inspector)) - (let ([v (contract (s/c number?) (make-s 1) 'pos 'neg)]) - (s-a v) - (let ([v3 (contract (s/c number?) v 'pos 'neg)]) - (s-a v3)))) + '(let ([v (contract (single/c number?) (make-single 1) 'pos 'neg)]) + (single-a v) + (let ([v3 (contract (single/c number?) v 'pos 'neg)]) + (single-a v3))) 1) ;; make sure the caching doesn't break the semantics (test/pos-blame 'd-c-s35 - '(let () - (define-contract-struct couple (hd tl)) - (let ([v (contract (couple/c any/c - (couple/c any/c - (couple/c any/c - number?))) - (make-couple 1 - (make-couple 2 - (make-couple 3 - #f))) - 'pos 'neg)]) - (let* ([x (couple-tl v)] - [y (couple-tl x)]) - (couple-hd (couple-tl x)))))) + '(let ([v (contract (couple/c any/c + (couple/c any/c + (couple/c any/c + number?))) + (make-couple 1 + (make-couple 2 + (make-couple 3 + #f))) + 'pos 'neg)]) + (let* ([x (couple-tl v)] + [y (couple-tl x)]) + (couple-hd (couple-tl x))))) (test/spec-passed/result 'd-c-s36 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 1 2)] - [y (make-couple 1 2)] - [c1 (couple/dc [hd any/c] - [tl (hd) any/c])] - [c2 (couple/c any/c any/c)]) - (couple-hd (contract c1 x 'pos 'neg)) - (couple-hd (contract c2 x 'pos 'neg)) - (couple-hd (contract c2 y 'pos 'neg)) - (couple-hd (contract c1 y 'pos 'neg)))) + '(let ([x (make-couple 1 2)] + [y (make-couple 1 2)] + [c1 (couple/dc [hd any/c] + [tl (hd) any/c])] + [c2 (couple/c any/c any/c)]) + (couple-hd (contract c1 x 'pos 'neg)) + (couple-hd (contract c2 x 'pos 'neg)) + (couple-hd (contract c2 y 'pos 'neg)) + (couple-hd (contract c1 y 'pos 'neg))) 1) ;; make sure that define-contract-struct contracts can go at the top level (test/spec-passed 'd-c-s37 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(require (lib "contract.ss"))) - (eval '(define-contract-struct couple (hd tl))) - (eval '(contract-stronger? - (couple/dc [hd any/c] - [tl (hd) any/c]) - (couple/dc [hd any/c] - [tl (hd) any/c]))))) + '(contract-stronger? + (couple/dc [hd any/c] + [tl (hd) any/c]) + (couple/dc [hd any/c] + [tl (hd) any/c]))) ;; test functions inside structs (test/spec-passed/result 'd-c-s38 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) x) (lambda (x) x))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) 1))) + '(let ([x (make-couple (lambda (x) x) (lambda (x) x))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) 1)) 1) (test/neg-blame 'd-c-s39 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) x) (lambda (x) x))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) #f)))) + '(let ([x (make-couple (lambda (x) x) (lambda (x) x))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) #f))) (test/pos-blame 'd-c-s40 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple (lambda (x) #f) (lambda (x) #f))] - [c (couple/dc [hd (-> integer? integer?)] - [tl (hd) any/c])]) - ((couple-hd (contract c x 'pos 'neg)) 1)))) + '(let ([x (make-couple (lambda (x) #f) (lambda (x) #f))] + [c (couple/dc [hd (-> integer? integer?)] + [tl (hd) any/c])]) + ((couple-hd (contract c x 'pos 'neg)) 1))) (test/spec-passed/result 'd-c-s41 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) x))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) 6))) + '(let ([x (make-couple 5 (lambda (x) x))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) 6)) 6) (test/pos-blame 'd-c-s42 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) -10))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) 6)))) + '(let ([x (make-couple 5 (lambda (x) -10))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) 6))) (test/neg-blame 'd-c-s42 - '(let () - (define-contract-struct couple (hd tl)) - (let ([x (make-couple 5 (lambda (x) -10))] - [c (couple/dc [hd number?] - [tl (hd) (-> (>=/c hd) (>=/c hd))])]) - ((couple-tl (contract c x 'pos 'neg)) -11)))) + '(let ([x (make-couple 5 (lambda (x) -10))] + [c (couple/dc [hd number?] + [tl (hd) (-> (>=/c hd) (>=/c hd))])]) + ((couple-tl (contract c x 'pos 'neg)) -11))) + ;; NOT YET RELEASED @@ -3654,7 +3629,7 @@ (test/pos-blame 'd-c-s/attr-4 `(,node-r (,node-r (,node-r ,t))))) - + ;; NOT YET RELEASED #| @@ -3664,16 +3639,13 @@ so that propagation occurs. |# - ;; test the predicate - (let () - (define-contract-struct couple (hd tl)) - (test #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) - (test #t couple? (make-couple 1 2)) - (test #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg)) - (test #f couple? 1) - (test #f couple? #f)) + (ctest #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) + (ctest #t couple? (make-couple 1 2)) + (ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg)) + (ctest #f couple? 1) + (ctest #f couple? #f) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3681,18 +3653,18 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (test #t flat-contract? (or/c)) - (test #t flat-contract? (or/c integer? (lambda (x) (> x 0)))) - (test #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?))) - (test #t flat-contract? (or/c integer? boolean?)) + (ctest #t flat-contract? (or/c)) + (ctest #t flat-contract? (or/c integer? (lambda (x) (> x 0)))) + (ctest #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?))) + (ctest #t flat-contract? (or/c integer? boolean?)) (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t) (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t) - (test #t flat-contract? (and/c)) - (test #t flat-contract? (and/c number? integer?)) - (test #t flat-contract? (and/c (flat-contract number?) + (ctest #t flat-contract? (and/c)) + (ctest #t flat-contract? (and/c number? integer?)) + (ctest #t flat-contract? (and/c (flat-contract number?) (flat-contract integer?))) - (test #t flat-contract? (let () + (ctest #t flat-contract? (let () (define-struct s (a b)) (struct/c s any/c any/c))) @@ -3719,25 +3691,29 @@ so that propagation occurs. (test-flat-contract '(one-of/c (expt 2 65)) (expt 2 65) 12) (test-flat-contract '(one-of/c #:x #:z) #:x #:y) - (let ([c% (class object% (super-new))]) - (test-flat-contract (subclass?/c c%) c% object%) - (test-flat-contract (subclass?/c c%) (class c%) (class object%))) + (let ([c% (contract-eval '(class object% (super-new)))]) + (test-flat-contract `(subclass?/c ,c%) c% (contract-eval `object%)) + (test-flat-contract `(subclass?/c ,c%) (contract-eval `(class ,c%)) (contract-eval `(class object%)))) - (let ([i<%> (interface ())]) - (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) object%) - (test-flat-contract `(implementation?/c ,i<%>) (class* object% (i<%>) (super-new)) #f)) + (let ([i<%> (contract-eval '(interface ()))]) + (test-flat-contract `(implementation?/c ,i<%>) + (contract-eval `(class* object% (,i<%>) (super-new))) + (contract-eval 'object%)) + (test-flat-contract `(implementation?/c ,i<%>) + (contract-eval `(class* object% (,i<%>) (super-new))) + #f)) - (let ([i<%> (interface ())] - [c% (class object% (super-new))]) - (test-flat-contract `(is-a?/c ,i<%>) (new (class* object% (i<%>) (super-new))) (new object%)) - (test-flat-contract `(is-a?/c ,c%) (new c%) (new object%))) + (let ([i<%> (contract-eval '(interface ()))] + [c% (contract-eval '(class object% (super-new)))]) + (test-flat-contract `(is-a?/c ,i<%>) + (contract-eval `(new (class* object% (,i<%>) (super-new)))) + (contract-eval '(new object%))) + (test-flat-contract `(is-a?/c ,c%) + (contract-eval `(new ,c%)) + (contract-eval '(new object%)))) (test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t)) (test-flat-contract '(listof any/c) (list #t #f) 3) - ;(test-flat-contract '(list-immutableof boolean?) (list-immutable #t #f) (list-immutable #f 3 #t)) - ;(test-flat-contract '(list-immutableof any/c) (list-immutable #t #f) 3) - ;(test-flat-contract '(list-immutableof boolean?) (list-immutable) (list)) - ;(test-flat-contract '(list-immutableof (-> boolean? boolean?)) (list-immutable (lambda (x) x)) (list (lambda (x) x))) (test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t)) (test-flat-contract '(vectorof any/c) (vector #t #f) 3) @@ -3750,16 +3726,12 @@ so that propagation occurs. (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) (list 1 #f)) (test-flat-contract '(list/c boolean? (flat-contract integer?)) (list #t 1) #f) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons-immutable 1 #f)) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) #f) - ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons #t 1)) - ;(test-flat-contract '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable (lambda (x) x) 1) #f) - - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list-immutable 1 #f)) - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) #f) - ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list #t 1)) - ;(test-flat-contract '(list-immutable/c (-> boolean? boolean?) integer?) (list-immutable (lambda (x) x) 1) #f) - + (contract-eval '(define (a-predicate-that-wont-be-optimized x) (boolean? x))) + (test-flat-contract '(cons/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (cons #t 1) (cons 1 #f)) + (test-flat-contract '(cons/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (cons #t 1) #f) + (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) (list 1 #f)) + (test-flat-contract '(list/c a-predicate-that-wont-be-optimized (flat-contract integer?)) (list #t 1) #f) + (test-flat-contract '(box/c boolean?) (box #f) (box 1)) (test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f) @@ -3769,9 +3741,14 @@ so that propagation occurs. even1) '(1 2 3 4) '(1 2 3)) - (syntax-test #'(flat-murec-contract ([(x) y]) x)) ;; malformed binder - (syntax-test #'(flat-murec-contract ([x y]))) ;; missing body - + (test #t 'malformed-binder + (with-handlers ((exn? exn:fail:syntax?)) + (contract-eval '(flat-murec-contract ([(x) y]) x)) + 'no-err)) + (test #t 'missing-body + (with-handlers ((exn? exn:fail:syntax?)) + (contract-eval '(flat-murec-contract ([x y]))) + 'no-err)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3779,19 +3756,19 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (test/well-formed #'(case-> (-> integer? integer?))) - (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? integer?))) - (test/well-formed #'(case-> (-> integer? integer?) (-> integer? integer? any))) - (test/well-formed #'(case-> (-> integer? any) (-> integer? integer? any))) + (test/well-formed '(case-> (-> integer? integer?))) + (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? integer?))) + (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? any))) + (test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))) - (test/well-formed #'(case-> (->d (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d (lambda x any/c)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?))) - (test/well-formed #'(case-> (->* (any/c any/c) any/c any) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?))) + (test/well-formed '(case-> (->* (any/c any/c) any/c any) (-> integer? integer?))) - (test/well-formed #'(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?))) - (test/well-formed #'(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?))) + (test/well-formed '(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3799,7 +3776,7 @@ so that propagation occurs. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (eval + (contract-eval '(module contract-test-suite-inferred-name1 mzscheme (require (lib "contract.ss")) (define contract-inferred-name-test-contract (-> integer? any)) @@ -3832,15 +3809,15 @@ so that propagation occurs. (define contract-inferred-name-test7 (case-lambda [(x) (values x x)] [(x y) (values y y)])) (provide/contract (contract-inferred-name-test7 (opt->* (number?) (number?) (number? number?)))))) - (eval '(require contract-test-suite-inferred-name1)) + (contract-eval '(require contract-test-suite-inferred-name1)) ;; (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-test2b object-name contract-inferred-name-test2b)) - (eval '(test 'contract-inferred-name-test3 object-name contract-inferred-name-test3)) - (eval '(test 'contract-inferred-name-test4 object-name contract-inferred-name-test4)) - (eval '(test 'contract-inferred-name-test5 object-name contract-inferred-name-test5)) - (eval '(test 'contract-inferred-name-test6 object-name contract-inferred-name-test6)) - (eval '(test 'contract-inferred-name-test7 object-name contract-inferred-name-test7)) + (test 'contract-inferred-name-test2 object-name (contract-eval 'contract-inferred-name-test2)) + (test 'contract-inferred-name-test2b object-name (contract-eval 'contract-inferred-name-test2b)) + (test 'contract-inferred-name-test3 object-name (contract-eval 'contract-inferred-name-test3)) + (test 'contract-inferred-name-test4 object-name (contract-eval 'contract-inferred-name-test4)) + (test 'contract-inferred-name-test5 object-name (contract-eval 'contract-inferred-name-test5)) + (test 'contract-inferred-name-test6 object-name (contract-eval 'contract-inferred-name-test6)) + (test 'contract-inferred-name-test7 object-name (contract-eval 'contract-inferred-name-test7)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -3930,16 +3907,20 @@ so that propagation occurs. (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c)) (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3)) - (let ([c% (class object% (super-new))]) - (test-name '(subclass?/c class:c%) (subclass?/c c%))) + (test-name '(subclass?/c class:c%) + (let ([c% (class object% (super-new))]) (subclass?/c c%))) - (let ([i<%> (interface ())]) - (test-name '(implementation?/c interface:i<%>) (implementation?/c i<%>))) + (test-name '(implementation?/c interface:i<%>) + (let ([i<%> (interface ())]) + (implementation?/c i<%>))) - (let ([i<%> (interface ())] - [c% (class object% (super-new))]) - (test-name '(is-a?/c interface:i<%>) (is-a?/c i<%>)) - (test-name '(is-a?/c class:c%) (is-a?/c c%))) + (test-name '(is-a?/c interface:i<%>) + (let ([i<%> (interface ())]) + (is-a?/c i<%>))) + (test-name '(is-a?/c class:c%) + (let ([i<%> (interface ())] + [c% (class object% (super-new))]) + (is-a?/c c%))) (test-name '(listof boolean?) (listof boolean?)) (test-name '(listof any/c) (listof any/c)) @@ -4026,18 +4007,12 @@ so that propagation occurs. (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x))) (test-name '(couple/c any/c any/c) - (let () - (define-contract-struct couple (hd tl)) - (couple/c any/c any/c))) + (couple/c any/c any/c)) (test-name '(couple/c any/c any/c) - (let () - (define-contract-struct couple (hd tl)) - (couple/dc [hd any/c] [tl any/c]))) + (couple/dc [hd any/c] [tl any/c])) (test-name '(couple/dc [hd any/c] [tl ...]) - (let () - (define-contract-struct couple (hd tl)) - (couple/dc [hd any/c] [tl (hd) any/c]))) - + (couple/dc [hd any/c] [tl (hd) any/c])) + ;; NOT YET RELEASED #; (test-name '(pr/dc [x integer?] @@ -4063,276 +4038,274 @@ so that propagation occurs. ;; stronger tests ;; - (test #t contract-stronger? any/c any/c) - (test #t contract-stronger? (between/c 1 3) (between/c 0 4)) - (test #f contract-stronger? (between/c 0 4) (between/c 1 3)) - (test #t contract-stronger? (>=/c 3) (>=/c 2)) - (test #f contract-stronger? (>=/c 2) (>=/c 3)) - (test #f contract-stronger? (<=/c 3) (<=/c 2)) - (test #t contract-stronger? (<=/c 2) (<=/c 3)) - (test #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) - (test #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) - (let ([f (λ (x) (recursive-contract (<=/c x)))]) - (test #t contract-stronger? (f 1) (f 1))) - (test #t contract-stronger? (-> integer? integer?) (-> integer? integer?)) - (test #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?)) - (test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3))) - (test #f contract-stronger? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3))) - (test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2))) - (test #f contract-stronger? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3))) - (test #f contract-stronger? (-> (>=/c 2)) (-> (>=/c 3) (>=/c 3))) - (test #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) - (test #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) - (test #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) - (test #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?)) - (test #t contract-stronger? (or/c null? (-> integer? integer?)) (or/c null? (-> integer? integer?))) - (test #f contract-stronger? (or/c null? (-> boolean? boolean?)) (or/c null? (-> integer? integer?))) + (ctest #t contract-stronger? any/c any/c) + (ctest #t contract-stronger? (between/c 1 3) (between/c 0 4)) + (ctest #f contract-stronger? (between/c 0 4) (between/c 1 3)) + (ctest #t contract-stronger? (>=/c 3) (>=/c 2)) + (ctest #f contract-stronger? (>=/c 2) (>=/c 3)) + (ctest #f contract-stronger? (<=/c 3) (<=/c 2)) + (ctest #t contract-stronger? (<=/c 2) (<=/c 3)) + (ctest #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) + (ctest #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) + (let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))]) + (test #t (contract-eval 'contract-stronger?) (contract-eval `(,f 1)) (contract-eval `(,f 1)))) + (ctest #t contract-stronger? (-> integer? integer?) (-> integer? integer?)) + (ctest #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?)) + (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3))) + (ctest #f contract-stronger? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3))) + (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2))) + (ctest #f contract-stronger? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3))) + (ctest #f contract-stronger? (-> (>=/c 2)) (-> (>=/c 3) (>=/c 3))) + (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) + (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) + (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) + (ctest #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?)) + (ctest #t contract-stronger? (or/c null? (-> integer? integer?)) (or/c null? (-> integer? integer?))) + (ctest #f contract-stronger? (or/c null? (-> boolean? boolean?)) (or/c null? (-> integer? integer?))) - (test #t contract-stronger? number? number?) - (test #f contract-stronger? boolean? number?) + (ctest #t contract-stronger? number? number?) + (ctest #f contract-stronger? boolean? number?) - (test #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z)) - (test #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y)) - (test #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y)) - (test #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) - (test #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) + (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z)) + (ctest #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y)) + (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y)) + (ctest #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) + (ctest #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) - (test #t contract-stronger? + (ctest #t contract-stronger? (or/c (-> (>=/c 3) (>=/c 3)) (-> string?)) (or/c (-> (>=/c 4) (>=/c 3)) (-> string?))) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?)) (or/c (-> string?) (-> any/c integer?))) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> any/c integer?)) (or/c (-> string?) (-> integer? integer?))) - (test #t contract-stronger? + (ctest #t contract-stronger? (or/c (-> string?) (-> integer? integer?) integer? boolean?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer? char?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer?) (or/c (-> string?) (-> integer? integer?) integer? boolean?)) - (test #f contract-stronger? + (ctest #f contract-stronger? (or/c (-> string?) (-> integer? integer?) integer?) (or/c (-> integer? integer?) integer?)) - - (let () - (define-contract-struct couple (hd tl)) - (define (non-zero? x) (not (zero? x))) - (define list-of-numbers - (or/c null? - (couple/c number? - (recursive-contract list-of-numbers)))) - (define (short-list/less-than n) - (or/c null? - (couple/c (<=/c n) - (or/c null? - (couple/c (<=/c n) - any/c))))) - (define (short-sorted-list/less-than n) - (or/c null? - (couple/dc - [hd (<=/c n)] - [tl (hd) (or/c null? - (couple/c (<=/c hd) - any/c))]))) - - (define (sorted-list/less-than n) - (or/c null? - (couple/dc - [hd (<=/c n)] - [tl (hd) (sorted-list/less-than hd)]))) - - ;; for some reason, the `n' makes it harder to optimize. without it, this test isn't as good a test - (define (closure-comparison-test n) - (couple/dc - [hd any/c] - [tl (hd) any/c])) - - (test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c)) - (test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5))) - (test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3))) - (test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1))) - (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])]) - (test #t contract-stronger? ctc ctc)) - (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])]) - (test #t contract-stronger? ctc ctc)) - (test #t contract-stronger? list-of-numbers list-of-numbers) - (test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5)) - (test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4)) - (test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5)) - (test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) - (test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) - (test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) - (test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5))) - + + (contract-eval + `(let () + (define (non-zero? x) (not (zero? x))) + (define list-of-numbers + (or/c null? + (couple/c number? + (recursive-contract list-of-numbers)))) + (define (short-list/less-than n) + (or/c null? + (couple/c (<=/c n) + (or/c null? + (couple/c (<=/c n) + any/c))))) + (define (short-sorted-list/less-than n) + (or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (or/c null? + (couple/c (<=/c hd) + any/c))]))) + + (define (sorted-list/less-than n) + (or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (sorted-list/less-than hd)]))) + + ;; for some reason, the `n' makes it harder to optimize. without it, this test isn't as good a test + (define (closure-comparison-test n) + (couple/dc + [hd any/c] + [tl (hd) any/c])) + + (,test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c)) + (,test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5))) + (,test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3))) + (,test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1))) + (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])]) + (,test #t contract-stronger? ctc ctc)) + (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])]) + (,test #t contract-stronger? ctc ctc)) + (,test #t contract-stronger? list-of-numbers list-of-numbers) + (,test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5)) + (,test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4)) + (,test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5)) + (,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) + (,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) + (,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) + (,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; first-order tests ;; - (test #t contract-first-order-passes? (flat-contract integer?) 1) - (test #f contract-first-order-passes? (flat-contract integer?) 'x) - (test #t contract-first-order-passes? (flat-contract boolean?) #t) - (test #f contract-first-order-passes? (flat-contract boolean?) 'x) - (test #t contract-first-order-passes? any/c 1) - (test #t contract-first-order-passes? any/c #t) - (test #t contract-first-order-passes? (-> integer? integer?) (λ (x) #t)) - (test #f contract-first-order-passes? (-> integer? integer?) (λ (x y) #t)) - (test #f contract-first-order-passes? (-> integer? integer?) 'x) - (test #t contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y) #t)) - (test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x) #t)) - (test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y z) #t)) + (ctest #t contract-first-order-passes? (flat-contract integer?) 1) + (ctest #f contract-first-order-passes? (flat-contract integer?) 'x) + (ctest #t contract-first-order-passes? (flat-contract boolean?) #t) + (ctest #f contract-first-order-passes? (flat-contract boolean?) 'x) + (ctest #t contract-first-order-passes? any/c 1) + (ctest #t contract-first-order-passes? any/c #t) + (ctest #t contract-first-order-passes? (-> integer? integer?) (λ (x) #t)) + (ctest #f contract-first-order-passes? (-> integer? integer?) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (-> integer? integer?) 'x) + (ctest #t contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x) #t)) + (ctest #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y z) #t)) - (test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x . y) #f)) - (test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x y . z) #f)) - (test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x) #f)) - (test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ x #f)) + (ctest #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x . y) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x y . z) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x) #f)) + (ctest #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ x #f)) - (test #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x)) - (test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x)) - (test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x)) + (ctest #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x)) + (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x)) + (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x)) - (test #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1)) - (test #f contract-first-order-passes? (list-immutableof integer?) (list 1)) - (test #f contract-first-order-passes? (list-immutableof integer?) #f) + (ctest #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1)) + (ctest #f contract-first-order-passes? (list-immutableof integer?) (list 1)) + (ctest #f contract-first-order-passes? (list-immutableof integer?) #f) - (test #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) - (test #f contract-first-order-passes? (vector-immutableof integer?) 'x) - (test #f contract-first-order-passes? (vector-immutableof integer?) '()) + (ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) + (ctest #f contract-first-order-passes? (vector-immutableof integer?) 'x) + (ctest #f contract-first-order-passes? (vector-immutableof integer?) '()) - (test #t contract-first-order-passes? (promise/c integer?) (delay 1)) - (test #f contract-first-order-passes? (promise/c integer?) 1) + (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1)) + (ctest #f contract-first-order-passes? (promise/c integer?) 1) - (test #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t)) - (test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t)) - (test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t)) + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t)) + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t)) + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y . z) z)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (y . z) z)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ z z)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y z . w) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (->d* (integer? boolean?) any/c (lambda (x y . z) char?)) (λ (x y) 1)) - (test #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1)) - (test #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1)) - (test #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1)) - (test #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1)) + (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1)) + (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1)) + (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1)) + (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1)) - (test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1)) - (test #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1)) - (test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1)) + (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1)) + (ctest #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1)) + (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ () 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ (x) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (λ (x y) 1)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (case->) 1) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case->) (case-lambda)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [(x) x] [(x y) x])) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [() 1] [(x) x] [(x y) x])) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (case-> (-> integer? integer?) (-> integer? integer? integer?)) (case-lambda [() 1] [(x) x] [(x y) x] [(x y z) x])) - (test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values) - (test #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) + (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x)) + (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values) + (ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (cons-immutable/c boolean? (-> integer? integer?)) (list*-immutable #t (λ (x) x))) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (cons-immutable/c boolean? (-> integer? integer?)) (list*-immutable 1 2)) - (test #f contract-first-order-passes? (flat-rec-contract the-name) 1) + (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) + + (ctest #t contract-first-order-passes? + (object-contract (m (-> integer? integer?))) + (new object%)) + (ctest #t contract-first-order-passes? + (object-contract (m (-> integer? integer?))) + 1) + + (ctest #t contract-first-order-passes? + (couple/c any/c any/c) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/c any/c any/c) + 2) + + (ctest #t contract-first-order-passes? + (couple/dc [hd any/c] [tl any/c]) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/dc [hd any/c] [tl any/c]) + 1) + + (ctest #t contract-first-order-passes? + (couple/dc [hd any/c] [tl (hd) any/c]) + (make-couple 1 2)) + + (ctest #f contract-first-order-passes? + (couple/dc [hd any/c] [tl (hd) any/c]) + 1) - (test #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - (new object%)) - (test #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - 1) + (ctest #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t) + (ctest #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x)) + (ctest #f contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x) - (let () - (define-contract-struct couple (hd tl)) - (test #t contract-first-order-passes? - (couple/c any/c any/c) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/c any/c any/c) - 2) - - (test #t contract-first-order-passes? - (couple/dc [hd any/c] [tl any/c]) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/dc [hd any/c] [tl any/c]) - 1) - - (test #t contract-first-order-passes? - (couple/dc [hd any/c] [tl (hd) any/c]) - (make-couple 1 2)) - - (test #f contract-first-order-passes? - (couple/dc [hd any/c] [tl (hd) any/c]) - 1)) - - (test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t) - (test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x)) - (test #f contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x) - - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ (x) x)) - (test #t contract-first-order-passes? + (ctest #t contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ (x y) x)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) (λ () x)) - (test #f contract-first-order-passes? + (ctest #f contract-first-order-passes? (or/c (-> integer? integer? integer?) (-> integer? integer?)) 1) @@ -4348,7 +4321,7 @@ so that propagation occurs. (or/c boolean? (-> (>=/c 5) (>=/c 5)))) - (test 1 + (ctest 1 length (let ([f (contract (-> integer? any) (lambda (x) @@ -4359,7 +4332,7 @@ so that propagation occurs. (with-continuation-mark 'x 'x (f 1)))) - (test 2 + (ctest 2 length (let ([f (contract (-> integer? list?) (lambda (x) @@ -4380,9 +4353,9 @@ so that propagation occurs. 'provide/contract1 '(let () (eval '(module contract-test-suite1 mzscheme - (require (lib "contract.ss")) - (define x 1) - (provide/contract (x integer?)))) + (require (lib "contract.ss")) + (define x 1) + (provide/contract (x integer?)))) (eval '(require contract-test-suite1)) (eval 'x))) @@ -4390,8 +4363,8 @@ so that propagation occurs. 'provide/contract2 '(let () (eval '(module contract-test-suite2 mzscheme - (require (lib "contract.ss")) - (provide/contract))) + (require (lib "contract.ss")) + (provide/contract))) (eval '(require contract-test-suite2)))) (test/spec-failed @@ -4407,7 +4380,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract4 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite4 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4420,7 +4393,7 @@ so that propagation occurs. (test/spec-passed/result 'provide/contract4-b - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite4-b mzscheme (require (lib "contract.ss")) (define-struct s (a b)) @@ -4438,7 +4411,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract5 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite5 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4457,17 +4430,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract6 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module contract-test-suite6 mzscheme - (require (lib "contract.ss")) - (define-struct s (a)) - (provide/contract (struct s ((a any/c)))))) - (eval '(require contract-test-suite6)) - (eval '(define-struct (t s) ())))) - - (test/spec-passed - 'provide/contract6 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite6 mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4477,7 +4440,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract6b - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite6b mzscheme (require (lib "contract.ss")) (define-struct s_ (a)) @@ -4495,7 +4458,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract7 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite7 mzscheme (require (lib "contract.ss")) (define-struct s (a b)) @@ -4513,7 +4476,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract8 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite8 mzscheme (require (lib "contract.ss")) (define-struct i-s (contents)) @@ -4525,7 +4488,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract9 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module contract-test-suite9 mzscheme (require (lib "contract.ss")) (define the-internal-name 1) @@ -4536,71 +4499,71 @@ so that propagation occurs. (test/spec-passed 'provide/contract10 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc10-m mzscheme (require (lib "contract.ss")) (define-struct s (a b) (make-inspector)) (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module n mzscheme + (eval '(module pc10-n mzscheme (require (lib "struct.ss") - m) + pc10-m) (print-struct #t) (copy-struct s (make-s 1 2) [s-a 3]))) - (eval '(require n)))) + (eval '(require pc10-n)))) (test/spec-passed 'provide/contract11 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc11-m mzscheme (require (lib "contract.ss")) (define x 1) (provide/contract [rename x y integer?] [rename x z integer?]))) - (eval '(module n mzscheme - (require m) + (eval '(module pc11-n mzscheme + (require pc11-m) (+ y z))) - (eval '(require n)))) + (eval '(require pc11-n)))) ;; this test is broken, not sure why #| (test/spec-failed - 'provide/contract11 + 'provide/contract11b '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + (eval '(module pc11b-m mzscheme (require (lib "contract.ss")) (define-struct s (a b) (make-inspector)) (provide/contract (struct s ((a number?) (b number?)))))) - (eval '(module n mzscheme + (eval '(module pc11b-n mzscheme (require (lib "struct.ss") m) (print-struct #t) (copy-struct s (make-s 1 2) [s-a #f]))) - (eval '(require n))) + (eval '(require pc11b-n))) 'n) |# (test/spec-passed 'provide/contract12 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module m mzscheme + '(begin + (eval '(module pc12-m mzscheme (require (lib "contract.ss")) (define-struct (exn2 exn) ()) (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) - (eval '(require m)))) + (eval '(require pc12-m)))) (test/spec-passed/result 'provide/contract13 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module common-msg-structs mzscheme + '(begin + (eval '(module pc13-common-msg-structs mzscheme (require (lib "contract.ss" "mzlib")) (define-struct register (name type) (make-inspector)) (provide/contract (struct register ([name any/c] [type any/c]))))) - (eval '(require common-msg-structs)) + (eval '(require pc13-common-msg-structs)) (eval '(require (lib "plt-match.ss"))) (eval '(match (make-register 1 2) [(struct register (name type)) @@ -4609,8 +4572,8 @@ so that propagation occurs. (test/spec-passed 'provide/contract14 - '(parameterize ([current-namespace (make-namespace)]) - (eval '(module test1 mzscheme + '(begin + (eval '(module pc14-test1 mzscheme (require (lib "contract.ss")) (define-struct type (flags)) @@ -4623,16 +4586,16 @@ so that propagation occurs. (struct (type:ptr type) ([flags (listof string?)] [type type?]))))) - (eval '(module test2 mzscheme + (eval '(module pc14-test2 mzscheme (require (lib "plt-match.ss")) - (require test1) + (require pc14-test1) (match (make-type:ptr '() (make-type '())) [(struct type:ptr (flags type)) #f]))) - (eval '(require test2)))) + (eval '(require pc14-test2)))) ;; make sure unbound identifier exception is raised. - (error-test - #'(parameterize ([current-namespace (make-namespace)]) + (contract-error-test + #'(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (provide/contract [i any/c])))) @@ -4642,7 +4605,7 @@ so that propagation occurs. ;; this test is bogus, because provide/contract'd variables can be set!'d. (test/pos-blame 'provide/contract15 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (define i #f) @@ -4652,7 +4615,7 @@ so that propagation occurs. ;; this is really a positive violation, but name the module `neg' just for an addl test (test/neg-blame 'provide/contract16 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module neg mzscheme (require (lib "contract.ss")) (define i #f) @@ -4664,7 +4627,7 @@ so that propagation occurs. #; (test/neg-blame 'provide/contract17 - '(parameterize ([current-namespace (make-namespace)]) + '(begin (eval '(module pos mzscheme (require (lib "contract.ss")) (define-struct s (a)) @@ -4675,55 +4638,63 @@ so that propagation occurs. (make-t #f))) (eval '(require neg)))) + (test/spec-passed + 'provide/contract18 + '(begin + (eval '(module pc18-pos mzscheme + (require (lib "contract.ss")) + (define-struct s ()) + (provide/contract [struct s ()]))) + (eval '(require pc18-pos)) + (eval '(make-s)))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce1-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable1 'five) (provide/contract [the-defined-variable1 number?]))) - (eval '(require bug))) + (eval '(require pce1-bug))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable1" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce2-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable2 values) (provide/contract [the-defined-variable2 (-> number? any)]))) - (eval '(require bug)) + (eval '(require pce2-bug)) (eval '(the-defined-variable2 #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable2" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce3-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable3 (λ (x) #f)) (provide/contract [the-defined-variable3 (-> any/c number?)]))) - (eval '(require bug)) + (eval '(require pce3-bug)) (eval '(the-defined-variable3 #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable3" (exn-message x))))) - (error-test - #'(parameterize ([current-namespace (make-namespace)]) - (eval '(module bug mzscheme + (contract-error-test + #'(begin + (eval '(module pce4-bug mzscheme (require (lib "contract.ss")) (define the-defined-variable4 (λ (x) #f)) (provide/contract [the-defined-variable4 (-> any/c number?)]))) - (eval '(require bug)) + (eval '(require pce4-bug)) (eval '((if #t the-defined-variable4) #f))) (λ (x) (and (exn? x) (regexp-match #rx"on the-defined-variable4" (exn-message x))))) - + (report-errs) )) -(report-errs)