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

converted the contract test suite to use scheme/base and fixed bugs along the way

Browse Source 
svn: r8032

original commit: 116241eee537922a4fc01ddbad0d100b40e4ebb0
This commit is contained in:
Robby Findler 2007-12-16 22:45:52 +00:00
parent f0aa868ce8
commit 34c28b9080
3 changed files with 246 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/scheme/private/contract-arr-checks.ss
View File

@ -51,12 +51,17 @@
(define (check->* f arity-count) (define (check->* f arity-count)
(unless (procedure? f) (unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-arity-includes? f arity-count) (unless (and (procedure-arity-includes? f arity-count)
(no-mandatory-keywords? f))
(error 'object-contract (error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count arity-count
f))) f)))
(define (no-mandatory-keywords? f)
(let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory)))
(define (check->*/more f arity-count) (define (check->*/more f arity-count)
(unless (procedure? f) (unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
@ -86,19 +91,21 @@
(define (check-procedure val dom-length src-info blame orig-str) (define (check-procedure val dom-length src-info blame orig-str)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-arity-includes? val dom-length)) (and (procedure-arity-includes? val dom-length)
(no-mandatory-keywords? val)))
(raise-contract-error (raise-contract-error
val val
src-info src-info
blame blame
orig-str orig-str
"expected a procedure that accepts ~a arguments, given: ~e" "expected a procedure that accepts ~a arguments without any keywords, given: ~e"
dom-length dom-length
val))) val)))
(define ((check-procedure? arity) val) (define ((check-procedure? arity) val)
(and (procedure? val) (and (procedure? val)
(procedure-arity-includes? val arity))) (procedure-arity-includes? val arity)
(no-mandatory-keywords? val)))
(define ((check-procedure/more? arity) val) (define ((check-procedure/more? arity) val)
(and (procedure? val) (and (procedure? val)

289
collects/scheme/private/contract-arrow.ss
View File

@ -1,6 +1,15 @@
#lang scheme/base #lang scheme/base
(require (lib "etc.ss")
"contract-guts.ss" #|
add mandatory keywords to ->, ->* ->d ->d*
Add both optional and mandatory keywords to opt-> and friends.
(Update opt-> so that it doesn't use case-lambda anymore.)
|#
(require "contract-guts.ss"
"contract-arr-checks.ss" "contract-arr-checks.ss"
"contract-opt.ss") "contract-opt.ss")
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
@ -90,7 +99,8 @@
(procedure-accepts-and-more? x l))) (procedure-accepts-and-more? x l)))
(λ (x) (λ (x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x l))))))) (procedure-arity-includes? x l)
(no-mandatory-keywords? x)))))))
(stronger-prop (stronger-prop
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
@ -124,144 +134,143 @@
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))])) (apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define-syntax-set (-> ->*) (define-for-syntax (->-helper stx)
(define (->/proc stx) (syntax-case* stx (-> any values) module-or-top-identifier=?
(let-values ([(stx _1 _2) (->/proc/main stx)]) [(-> doms ... any)
stx)) (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (ignored))
(syntax (doms ...))
(syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...)))
#t))]
[(-> doms ... (values rngs ...))
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc ...))
(syntax (doms ...))
(syntax (rngs ...))
(syntax ((args ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[(_ doms ... rng)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc))
(syntax (doms ...))
(syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
#f))]))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs]
[inner-lambda
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body)))]
[use-any? use-any?])
(with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[len (and lst (length lst))])
(syntax
(lambda (chk dom-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
#f
(list rng-ctcs ...)
use-any?
outer-lambda))
inner-args/body
(syntax (dom-names ... rng-names ...))))))))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) (define-syntax (-> stx)
(define (->/proc/main stx) (let-values ([(stx _1 _2) (->/proc/main stx)])
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)]) stx))
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names] ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
[(rng-names ...) rng-names] (define-for-syntax (->*/proc/main stx)
[(dom-ctcs ...) dom-ctcs] (syntax-case* stx (->* any) module-or-top-identifier=?
[(rng-ctcs ...) rng-ctcs] [(->* (doms ...) any)
[inner-lambda (->/proc/main (syntax (-> doms ... any)))]
(add-name-prop [(->* (doms ...) (rngs ...))
(syntax-local-infer-name stx) (->/proc/main (syntax (-> doms ... (values rngs ...))))]
(syntax (lambda args body)))] [(->* (doms ...) rst (rngs ...))
[use-any? use-any?]) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
(with-syntax ([outer-lambda [(args ...) (generate-temporaries (syntax (doms ...)))]
(let* ([lst (syntax->list #'args)] [(rst-x) (generate-temporaries (syntax (rst)))]
[len (and lst (length lst))]) [(rest-arg) (generate-temporaries (syntax (rst)))]
(syntax [(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
(lambda (chk dom-names ... rng-names ...) [(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(lambda (val) (let ([inner-args/body
(chk val) (syntax ((args ... . rest-arg)
inner-lambda))))]) (let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (values (rng-x rng-args) ...))))])
(syntax (build--> '-> (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(list dom-ctcs ...) (add-name-prop
#f (syntax-local-infer-name stx)
(list rng-ctcs ...) (syntax (lambda args body))))])
use-any? (with-syntax ([outer-lambda
outer-lambda)) (syntax
inner-args/body (lambda (chk dom-x ... rst-x rng-x ...)
(syntax (dom-names ... rng-names ...)))))))) (lambda (val)
(chk val)
(define (->-helper stx) inner-lambda)))])
(syntax-case* stx (-> any values) module-or-top-identifier=? (values (syntax (build--> '->*
[(-> doms ... any) (list doms ...)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] rst
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] (list rngs ...)
[(ignored) (generate-temporaries (syntax (rng)))]) #f
(values (syntax (dom-ctc ...)) outer-lambda))
(syntax (ignored)) inner-args/body
(syntax (doms ...)) (syntax (dom-x ... rst-x rng-x ...)))))))]
(syntax (any/c)) [(->* (doms ...) rst any)
(syntax ((args ...) (val (dom-ctc args) ...))) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
#t))] [(args ...) (generate-temporaries (syntax (doms ...)))]
[(-> doms ... (values rngs ...)) [(rst-x) (generate-temporaries (syntax (rst)))]
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] [(rest-arg) (generate-temporaries (syntax (rst)))])
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] (let ([inner-args/body
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))] (syntax ((args ... . rest-arg)
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) (apply val (dom-x args) ... (rst-x rest-arg))))])
(values (syntax (dom-ctc ...)) (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(syntax (rng-ctc ...)) (add-name-prop
(syntax (doms ...)) (syntax-local-infer-name stx)
(syntax (rngs ...)) (syntax (lambda args body))))])
(syntax ((args ...) (with-syntax ([outer-lambda
(let-values ([(rng-x ...) (val (dom-ctc args) ...)]) (syntax
(values (rng-ctc rng-x) ...)))) (lambda (chk dom-x ... rst-x ignored)
#f))] (lambda (val)
[(_ doms ... rng) (chk val)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] inner-lambda)))])
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] (values (syntax (build--> '->*
[(rng-ctc) (generate-temporaries (syntax (rng)))]) (list doms ...)
(values (syntax (dom-ctc ...)) rst
(syntax (rng-ctc)) (list any/c)
(syntax (doms ...)) #t
(syntax (rng)) outer-lambda))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...)))) inner-args/body
#f))])) (syntax (dom-x ... rst-x)))))))]))
(define (->*/proc stx) (define-syntax (->* stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)]) (let-values ([(stx _1 _2) (->*/proc/main stx)])
stx)) stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (doms ...) any)
(->/proc/main (syntax (-> doms ... any)))]
[(->* (doms ...) (rngs ...))
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ...)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list rngs ...)
#f
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x rng-x ...)))))))]
[(->* (doms ...) rst any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list any/c)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (select/h stx err-name ctxt-stx) (define-for-syntax (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)

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

@ -426,6 +426,13 @@
'pos 'pos
'neg) 'neg)
1)) 1))
(test/pos-blame
'contract-arrow-keyword
'(contract (-> integer? integer?)
(λ (x #:y y) x)
'pos
'neg))
(test/pos-blame (test/pos-blame
'contract-d1 'contract-d1
@ -1611,7 +1618,7 @@
(test/spec-passed (test/spec-passed
'define/contract7 'define/contract7
'(let () '(let ()
(eval '(module contract-test-suite-define1 mzscheme (eval '(module contract-test-suite-define1 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define/contract x string? "a") (define/contract x string? "a")
x)) x))
@ -3218,7 +3225,7 @@
(test/spec-passed (test/spec-passed
'd-c-s-match1 'd-c-s-match1
'(begin '(begin
(eval '(module d-c-s-match1 mzscheme (eval '(module d-c-s-match1 scheme/base
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "match.ss")) (lib "match.ss"))
@ -3232,7 +3239,7 @@
(test/spec-passed/result (test/spec-passed/result
'd-c-s-match2 'd-c-s-match2
'(begin '(begin
(eval '(module d-c-s-match2 mzscheme (eval '(module d-c-s-match2 scheme/base
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "match.ss")) (lib "match.ss"))
@ -3251,7 +3258,7 @@
(test/pos-blame 'd-c-s1 (test/pos-blame 'd-c-s1
'(begin '(begin
(eval '(module d-c-s1 mzscheme (eval '(module d-c-s1 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-contract-struct couple (hd tl)) (define-contract-struct couple (hd tl))
(contract (couple/c any/c any/c) 1 'pos 'neg))) (contract (couple/c any/c any/c) 1 'pos 'neg)))
@ -4033,7 +4040,7 @@ so that propagation occurs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(contract-eval (contract-eval
'(module contract-test-suite-inferred-name1 mzscheme '(module contract-test-suite-inferred-name1 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define contract-inferred-name-test-contract (-> integer? any)) (define contract-inferred-name-test-contract (-> integer? any))
(define (contract-inferred-name-test x) #t) (define (contract-inferred-name-test x) #t)
@ -4616,7 +4623,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract1 'provide/contract1
'(let () '(let ()
(eval '(module contract-test-suite1 mzscheme (eval '(module contract-test-suite1 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define x 1) (define x 1)
(provide/contract (x integer?)))) (provide/contract (x integer?))))
@ -4626,7 +4633,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract2 'provide/contract2
'(let () '(let ()
(eval '(module contract-test-suite2 mzscheme (eval '(module contract-test-suite2 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(provide/contract))) (provide/contract)))
(eval '(require 'contract-test-suite2)))) (eval '(require 'contract-test-suite2))))
@ -4634,7 +4641,7 @@ so that propagation occurs.
(test/spec-failed (test/spec-failed
'provide/contract3 'provide/contract3
'(let () '(let ()
(eval '(module contract-test-suite3 mzscheme (eval '(module contract-test-suite3 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define x #f) (define x #f)
(provide/contract (x integer?)))) (provide/contract (x integer?))))
@ -4645,9 +4652,9 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract4 'provide/contract4
'(begin '(begin
(eval '(module contract-test-suite4 mzscheme (eval '(module contract-test-suite4 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a)) (define-struct s (a) #:mutable)
(provide/contract (struct s ((a any/c)))))) (provide/contract (struct s ((a any/c))))))
(eval '(require 'contract-test-suite4)) (eval '(require 'contract-test-suite4))
(eval '(list (make-s 1) (eval '(list (make-s 1)
@ -4655,14 +4662,26 @@ so that propagation occurs.
(s? (make-s 1)) (s? (make-s 1))
(set-s-a! (make-s 1) 2))))) (set-s-a! (make-s 1) 2)))))
(test/spec-passed/result (test/spec-passed
'provide/contract4-b 'provide/contract4-b
'(begin '(begin
(eval '(module contract-test-suite4-b mzscheme (eval '(module contract-test-suite4-b scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a b)) (define-struct s (a))
(provide/contract (struct s ((a any/c) (b any/c)))))) (provide/contract (struct s ((a any/c))))))
(eval '(require 'contract-test-suite4-b)) (eval '(require 'contract-test-suite4-b))
(eval '(list (make-s 1)
(s-a (make-s 1))
(s? (make-s 1))))))
(test/spec-passed/result
'provide/contract4-c
'(begin
(eval '(module contract-test-suite4-c scheme/base
(require (lib "contract.ss"))
(define-struct s (a b) #:mutable)
(provide/contract (struct s ((a any/c) (b any/c))))))
(eval '(require 'contract-test-suite4-c))
(eval '(let ([an-s (make-s 1 2)]) (eval '(let ([an-s (make-s 1 2)])
(list (s-a an-s) (list (s-a an-s)
(s-b an-s) (s-b an-s)
@ -4676,7 +4695,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract5 'provide/contract5
'(begin '(begin
(eval '(module contract-test-suite5 mzscheme (eval '(module contract-test-suite5 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a)) (define-struct s (a))
(define-struct t (a)) (define-struct t (a))
@ -4686,16 +4705,14 @@ so that propagation occurs.
(eval '(list (make-s 1) (eval '(list (make-s 1)
(s-a (make-s 1)) (s-a (make-s 1))
(s? (make-s 1)) (s? (make-s 1))
(set-s-a! (make-s 1) 2)
(make-t 1) (make-t 1)
(t-a (make-t 1)) (t-a (make-t 1))
(t? (make-t 1)) (t? (make-t 1))))))
(set-t-a! (make-t 1) 2)))))
(test/spec-passed (test/spec-passed
'provide/contract6 'provide/contract6
'(begin '(begin
(eval '(module contract-test-suite6 mzscheme (eval '(module contract-test-suite6 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a)) (define-struct s (a))
(provide/contract (struct s ((a any/c)))))) (provide/contract (struct s ((a any/c))))))
@ -4705,12 +4722,12 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract6b 'provide/contract6b
'(begin '(begin
(eval '(module contract-test-suite6b mzscheme (eval '(module contract-test-suite6b scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s_ (a)) (define-struct s_ (a))
(provide/contract (struct s_ ((a any/c)))))) (provide/contract (struct s_ ((a any/c))))))
(eval '(require 'contract-test-suite6b)) (eval '(require 'contract-test-suite6b))
(eval '(module contract-test-suite6b2 mzscheme (eval '(module contract-test-suite6b2 scheme/base
(require 'contract-test-suite6b) (require 'contract-test-suite6b)
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct (t_ s_) (b)) (define-struct (t_ s_) (b))
@ -4723,7 +4740,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract7 'provide/contract7
'(begin '(begin
(eval '(module contract-test-suite7 mzscheme (eval '(module contract-test-suite7 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a b)) (define-struct s (a b))
(define-struct (t s) (c d)) (define-struct (t s) (c d))
@ -4741,7 +4758,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract8 'provide/contract8
'(begin '(begin
(eval '(module contract-test-suite8 mzscheme (eval '(module contract-test-suite8 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct i-s (contents)) (define-struct i-s (contents))
(define (w-f-s? x) #t) (define (w-f-s? x) #t)
@ -4753,7 +4770,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract9 'provide/contract9
'(begin '(begin
(eval '(module contract-test-suite9 mzscheme (eval '(module contract-test-suite9 scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define the-internal-name 1) (define the-internal-name 1)
(provide/contract (rename the-internal-name the-external-name integer?)) (provide/contract (rename the-internal-name the-external-name integer?))
@ -4764,11 +4781,11 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract10 'provide/contract10
'(begin '(begin
(eval '(module pc10-m mzscheme (eval '(module pc10-m scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a b) (make-inspector)) (define-struct s (a b) #:inspector (make-inspector))
(provide/contract (struct s ((a number?) (b number?)))))) (provide/contract (struct s ((a number?) (b number?))))))
(eval '(module pc10-n mzscheme (eval '(module pc10-n scheme/base
(require (lib "struct.ss") (require (lib "struct.ss")
'pc10-m) 'pc10-m)
(print-struct #t) (print-struct #t)
@ -4780,12 +4797,12 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract11 'provide/contract11
'(begin '(begin
(eval '(module pc11-m mzscheme (eval '(module pc11-m scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define x 1) (define x 1)
(provide/contract [rename x y integer?] (provide/contract [rename x y integer?]
[rename x z integer?]))) [rename x z integer?])))
(eval '(module pc11-n mzscheme (eval '(module pc11-n scheme/base
(require 'pc11-m) (require 'pc11-m)
(+ y z))) (+ y z)))
(eval '(require 'pc11-n)))) (eval '(require 'pc11-n))))
@ -4795,11 +4812,11 @@ so that propagation occurs.
(test/spec-failed (test/spec-failed
'provide/contract11b 'provide/contract11b
'(parameterize ([current-namespace (make-namespace)]) '(parameterize ([current-namespace (make-namespace)])
(eval '(module pc11b-m mzscheme (eval '(module pc11b-m scheme/base
(require (lib "contract.ss")) (require (lib "contract.ss"))
(define-struct s (a b) (make-inspector)) (define-struct s (a b) #:inspector (make-inspector))
(provide/contract (struct s ((a number?) (b number?)))))) (provide/contract (struct s ((a number?) (b number?))))))
(eval '(module pc11b-n mzscheme (eval '(module pc11b-n scheme/base
(require (lib "struct.ss") (require (lib "struct.ss")
m) m)
(print-struct #t) (print-struct #t)
@ -4813,7 +4830,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract12 'provide/contract12
'(begin '(begin
(eval '(module pc12-m mzscheme (eval '(module pc12-m scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct (exn2 exn) ()) (define-struct (exn2 exn) ())
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
@ -4822,9 +4839,9 @@ so that propagation occurs.
(test/spec-passed/result (test/spec-passed/result
'provide/contract13 'provide/contract13
'(begin '(begin
(eval '(module pc13-common-msg-structs mzscheme (eval '(module pc13-common-msg-structs scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct register (name type) (make-inspector)) (define-struct register (name type) #:inspector (make-inspector))
(provide/contract (struct register ([name any/c] [type any/c]))))) (provide/contract (struct register ([name any/c] [type any/c])))))
(eval '(require 'pc13-common-msg-structs)) (eval '(require 'pc13-common-msg-structs))
@ -4837,7 +4854,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract14 'provide/contract14
'(begin '(begin
(eval '(module pc14-test1 mzscheme (eval '(module pc14-test1 scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct type (flags)) (define-struct type (flags))
@ -4850,7 +4867,7 @@ so that propagation occurs.
(struct (type:ptr type) (struct (type:ptr type)
([flags (listof string?)] [type type?]))))) ([flags (listof string?)] [type type?])))))
(eval '(module pc14-test2 mzscheme (eval '(module pc14-test2 scheme/base
(require (lib "plt-match.ss")) (require (lib "plt-match.ss"))
(require 'pc14-test1) (require 'pc14-test1)
(match (make-type:ptr '() (make-type '())) (match (make-type:ptr '() (make-type '()))
@ -4860,7 +4877,7 @@ so that propagation occurs.
;; make sure unbound identifier exception is raised. ;; make sure unbound identifier exception is raised.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pos mzscheme (eval '(module pos scheme/base
(require scheme/contract) (require scheme/contract)
(provide/contract [i any/c])))) (provide/contract [i any/c]))))
exn:fail:syntax?) exn:fail:syntax?)
@ -4870,7 +4887,7 @@ so that propagation occurs.
(test/spec-failed (test/spec-failed
'provide/contract15 'provide/contract15
'(begin '(begin
(eval '(module pos mzscheme (eval '(module pos scheme/base
(require scheme/contract) (require scheme/contract)
(define i #f) (define i #f)
(provide/contract [i integer?]))) (provide/contract [i integer?])))
@ -4881,7 +4898,7 @@ so that propagation occurs.
(test/spec-failed (test/spec-failed
'provide/contract16 'provide/contract16
'(begin '(begin
(eval '(module neg mzscheme (eval '(module neg scheme/base
(require scheme/contract) (require scheme/contract)
(define i #f) (define i #f)
(provide/contract [i integer?]))) (provide/contract [i integer?])))
@ -4894,11 +4911,11 @@ so that propagation occurs.
(test/neg-blame (test/neg-blame
'provide/contract17 'provide/contract17
'(begin '(begin
(eval '(module pos mzscheme (eval '(module pos scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct s (a)) (define-struct s (a))
(provide/contract [struct s ((a integer?))]))) (provide/contract [struct s ((a integer?))])))
(eval '(module neg mzscheme (eval '(module neg scheme/base
(require 'pos) (require 'pos)
(define-struct (t s) ()) (define-struct (t s) ())
(make-t #f))) (make-t #f)))
@ -4907,7 +4924,7 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract18 'provide/contract18
'(begin '(begin
(eval '(module pc18-pos mzscheme (eval '(module pc18-pos scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct s ()) (define-struct s ())
(provide/contract [struct s ()]))) (provide/contract [struct s ()])))
@ -4917,25 +4934,25 @@ so that propagation occurs.
(test/spec-passed/result (test/spec-passed/result
'provide/contract19 'provide/contract19
'(begin '(begin
(eval '(module pc19-a mzscheme (eval '(module pc19-a scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct a (x)) (define-struct a (x))
(provide/contract [struct a ([x number?])]))) (provide/contract [struct a ([x number?])])))
(eval '(module pc19-b mzscheme (eval '(module pc19-b scheme/base
(require 'pc19-a (require 'pc19-a
scheme/contract) scheme/contract)
(define-struct (b a) (y)) (define-struct (b a) (y))
(provide/contract [struct (b a) ([x number?] [y number?])]))) (provide/contract [struct (b a) ([x number?] [y number?])])))
(eval '(module pc19-c mzscheme (eval '(module pc19-c scheme/base
(require 'pc19-b (require 'pc19-b
scheme/contract) scheme/contract)
(define-struct (c b) (z)) (define-struct (c b) (z))
(provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) (provide/contract [struct (c b) ([x number?] [y number?] [z number?])])))
(eval' (module pc19-d mzscheme (eval' (module pc19-d scheme/base
(require 'pc19-a 'pc19-c) (require 'pc19-a 'pc19-c)
(define pc19-ans (a-x (make-c 1 2 3))) (define pc19-ans (a-x (make-c 1 2 3)))
(provide pc19-ans))) (provide pc19-ans)))
@ -4947,7 +4964,7 @@ so that propagation occurs.
;; test that unit & contract don't collide over the name `struct' ;; test that unit & contract don't collide over the name `struct'
(test/spec-passed (test/spec-passed
'provide/contract20 'provide/contract20
'(eval '(module tmp mzscheme '(eval '(module tmp scheme/base
(require scheme/contract (require scheme/contract
(lib "unit.ss")) (lib "unit.ss"))
@ -4960,12 +4977,13 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract21 'provide/contract21
'(begin '(begin
(eval '(module provide/contract21a mzscheme (eval '(module provide/contract21a scheme/base
(require scheme/contract) (require scheme/contract)
(provide/contract [f integer?]) (provide/contract [f integer?])
(define f 1))) (define f 1)))
(eval '(module provide/contract21b mzscheme (eval '(module provide/contract21b scheme/base
(require-for-syntax 'provide/contract21a) (require (for-syntax 'provide/contract21a)
(for-syntax scheme/base))
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
f f f f
#'1))))) #'1)))))
@ -4973,12 +4991,13 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract22 'provide/contract22
'(begin '(begin
(eval '(module provide/contract22a mzscheme (eval '(module provide/contract22a scheme/base
(require scheme/contract) (require scheme/contract)
(provide/contract [make-bound-identifier-mapping integer?]) (provide/contract [make-bound-identifier-mapping integer?])
(define make-bound-identifier-mapping 1))) (define make-bound-identifier-mapping 1)))
(eval '(module provide/contract22b mzscheme (eval '(module provide/contract22b scheme/base
(require-for-syntax 'provide/contract22a) (require (for-syntax 'provide/contract22a)
(for-syntax scheme/base))
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
make-bound-identifier-mapping) make-bound-identifier-mapping)
@ -4989,12 +5008,12 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract23 'provide/contract23
'(begin '(begin
(eval '(module provide/contract23a mzscheme (eval '(module provide/contract23a scheme/base
(require scheme/contract) (require scheme/contract)
(provide/contract [f integer?]) (provide/contract [f integer?])
(define f 3))) (define f 3)))
(eval '(module provide/contract23b mzscheme (eval '(module provide/contract23b scheme/base
(require 'provide/contract23a) (require 'provide/contract23a)
(#%expression f) (#%expression f)
f)) f))
@ -5004,21 +5023,21 @@ so that propagation occurs.
(test/spec-passed (test/spec-passed
'provide/contract24 'provide/contract24
'(begin '(begin
(eval '(module provide/contract24 mzscheme (eval '(module provide/contract24 scheme/base
(require (prefix c: scheme/contract)) (require (prefix-in c: scheme/contract))
(c:case-> (c:-> integer? integer?) (c:case-> (c:-> integer? integer?)
(c:-> integer? integer? integer?)))))) (c:-> integer? integer? integer?))))))
;; tests that contracts pick up the #%app from the context ;; tests that contracts pick up the #%app from the context
;; instead of always using the mzscheme #%app. ;; instead of always using the scheme/base #%app.
(test/spec-passed (test/spec-passed
'provide/contract25 'provide/contract25
'(begin '(begin
(eval '(module provide/contract25a mzscheme (eval '(module provide/contract25a scheme/base
(require scheme/contract) (require scheme/contract)
(provide/contract [seventeen integer?]) (provide/contract [seventeen integer?])
(define seventeen 17))) (define seventeen 17)))
(eval '(module provide/contract25b mzscheme (eval '(module provide/contract25b scheme/base
(require 'provide/contract25a) (require 'provide/contract25a)
(let-syntax ([#%app (syntax-rules () (let-syntax ([#%app (syntax-rules ()
[(#%app e ...) (list e ...)])]) [(#%app e ...) (list e ...)])])
@ -5038,7 +5057,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce1-bug mzscheme (eval '(module pce1-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define the-defined-variable1 'five) (define the-defined-variable1 'five)
(provide/contract [the-defined-variable1 number?]))) (provide/contract [the-defined-variable1 number?])))
@ -5049,7 +5068,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce2-bug mzscheme (eval '(module pce2-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define the-defined-variable2 values) (define the-defined-variable2 values)
(provide/contract [the-defined-variable2 (-> number? any)]))) (provide/contract [the-defined-variable2 (-> number? any)])))
@ -5061,7 +5080,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce3-bug mzscheme (eval '(module pce3-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define the-defined-variable3 (λ (x) #f)) (define the-defined-variable3 (λ (x) #f))
(provide/contract [the-defined-variable3 (-> any/c number?)]))) (provide/contract [the-defined-variable3 (-> any/c number?)])))
@ -5073,7 +5092,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce4-bug mzscheme (eval '(module pce4-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define the-defined-variable4 (λ (x) #f)) (define the-defined-variable4 (λ (x) #f))
(provide/contract [the-defined-variable4 (-> any/c number?)]))) (provide/contract [the-defined-variable4 (-> any/c number?)])))
@ -5085,7 +5104,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce5-bug mzscheme (eval '(module pce5-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct bad (a b)) (define-struct bad (a b))
@ -5099,7 +5118,7 @@ so that propagation occurs.
(contract-error-test (contract-error-test
#'(begin #'(begin
(eval '(module pce6-bug mzscheme (eval '(module pce6-bug scheme/base
(require scheme/contract) (require scheme/contract)
(define-struct bad-parent (a)) (define-struct bad-parent (a))