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

some progress on the contract test suite

Browse Source 
svn: r7850
This commit is contained in:
Robby Findler 2007-11-28 04:38:23 +00:00
parent ba448d3f4b
commit 47a4b69e5d
3 changed files with 130 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mzlib/private/contract-ds.ss
View File

@ -95,12 +95,12 @@ it around flattened out.
(values)))) (values))))
(list)) (list))
(define-syntax name (list-immutable #'struct:-name (define-syntax name (list #'struct:-name
#'struct-maker #'struct-maker
#'predicate #'predicate
(reverse (list-immutable #'selectors ...)) (reverse (list #'selectors ...))
(list-immutable #,@(map (λ (x) #f) (syntax->list #'(selectors ...)))) (list #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
#t)) #t))
(define (evaluate-attrs stct contract/info) (define (evaluate-attrs stct contract/info)
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes (when (wrap-parent-get stct 0) ;; test to make sure this even has attributes

193
collects/mzlib/private/contract.ss
View File

@ -821,10 +821,8 @@ improve method arity mismatch contract violation error messages?
false/c false/c
printable/c printable/c
symbols one-of/c symbols one-of/c
listof list-immutableof listof cons/c list/c
vectorof vector-immutableof vector/c vector-immutable/c vectorof vector-immutableof vector/c vector-immutable/c
cons-immutable/c cons/c list-immutable/c list/c
listof-unsafe cons-unsafe/c list-unsafe/c
box-immutable/c box/c box-immutable/c box/c
promise/c promise/c
struct/c struct/c
@ -1532,68 +1530,45 @@ improve method arity mismatch contract violation error messages?
(build-compound-type-name 'not/c (proc/ctc->ctc f)) (build-compound-type-name 'not/c (proc/ctc->ctc f))
(λ (x) (not (test-proc/flat-contract f x))))) (λ (x) (not (test-proc/flat-contract f x)))))
(define (listof p)
(unless (flat-contract/predicate? p)
(error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
(build-flat-contract
(build-compound-type-name 'listof (proc/ctc->ctc p))
(λ (v)
(and (list? v)
(andmap (λ (ele) (test-proc/flat-contract p ele))
v)))))
(define-syntax (*-immutableof stx) (define-syntax (*-immutableof stx)
(syntax-case stx () (syntax-case stx ()
[(_ predicate? fill type-name name) [(_ predicate? fill testmap type-name name)
(identifier? (syntax predicate?)) (identifier? (syntax predicate?))
(syntax (syntax
(let ([fill-name fill]) (let ([fill-name fill])
(λ (input) (λ (input)
(let* ([ctc (coerce-contract 'name input)] (let ([ctc (coerce-contract 'name input)])
[proj (contract-proc ctc)]) (if (flat-contract? ctc)
(make-proj-contract (let ([content-pred? (flat-contract-predicate ctc)])
(build-compound-type-name 'name ctc) (flat-contract
(λ (pos-blame neg-blame src-info orig-str) (lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([p-app (proj pos-blame neg-blame src-info orig-str)]) (let ([proj (contract-proc ctc)])
(λ (val) (make-proj-contract
(unless (predicate? val) (build-compound-type-name 'name ctc)
(raise-contract-error (λ (pos-blame neg-blame src-info orig-str)
val (let ([p-app (proj pos-blame neg-blame src-info orig-str)])
src-info (λ (val)
pos-blame (unless (predicate? val)
orig-str (raise-contract-error
"expected <~a>, given: ~e" val
'type-name src-info
val)) pos-blame
(fill-name p-app val)))) orig-str
predicate?)))))])) "expected <~a>, given: ~e"
'type-name
val))
(fill-name p-app val))))
predicate?)))))))]))
(define (map-immutable f lst) (define listof
(let loop ([lst lst]) (*-immutableof list? map andmap list listf))
(cond
[(pair? lst)
(cons (f (car lst))
(loop (cdr lst)))]
[(null? lst) null])))
(define (immutable-list? val)
(let loop ([v val])
(or (and (pair? v)
(immutable? v)
(loop (cdr v)))
(null? v))))
(define list-immutableof
(*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
(define listof-unsafe
(*-immutableof list? map list listof-unsafe))
(define (immutable-vector? val) (and (immutable? val) (vector? val))) (define (immutable-vector? val) (and (immutable? val) (vector? val)))
(define vector-immutableof (define vector-immutableof
(*-immutableof immutable-vector? (*-immutableof immutable-vector?
(λ (f v) (apply vector-immutable (map f (vector->list v)))) (λ (f v) (apply vector-immutable (map f (vector->list v))))
(λ (f v) (andmap f (vector->list v)))
immutable-vector immutable-vector
vector-immutableof)) vector-immutableof))
@ -1636,17 +1611,6 @@ improve method arity mismatch contract violation error messages?
(and (box? x) (and (box? x)
(test-proc/flat-contract pred (unbox x)))))) (test-proc/flat-contract pred (unbox x))))))
(define (cons/c hdp tlp)
(unless (and (flat-contract/predicate? hdp)
(flat-contract/predicate? tlp))
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
(build-flat-contract
(build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp))
(λ (x)
(and (pair? x)
(test-proc/flat-contract hdp (car x))
(test-proc/flat-contract tlp (cdr x))))))
;; ;;
;; cons/c opter ;; cons/c opter
;; ;;
@ -1730,28 +1694,35 @@ improve method arity mismatch contract violation error messages?
[selector-names selectors] ...) [selector-names selectors] ...)
(λ (params ...) (λ (params ...)
(let ([ctc-x (coerce-contract 'name params)] ...) (let ([ctc-x (coerce-contract 'name params)] ...)
(let ([procs (contract-proc ctc-x)] ...) (if (and (flat-contract? ctc-x) ...)
(make-proj-contract (let ([p-apps (flat-contract-predicate ctc-x)] ...)
(build-compound-type-name 'name (proc/ctc->ctc params) ...) (flat-contract
(λ (pos-blame neg-blame src-info orig-str) (lambda (x)
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...) (and (predicate?-name x)
(λ (v) (p-apps (selector-names x))
(if #,(if test-immutable? ...))))
#'(and (predicate?-name v) (let ([procs (contract-proc ctc-x)] ...)
(immutable? v)) (make-proj-contract
#'(predicate?-name v)) (build-compound-type-name 'name (proc/ctc->ctc params) ...)
(constructor-name (p-apps (selector-names v)) ...) (λ (pos-blame neg-blame src-info orig-str)
(raise-contract-error (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
v (λ (v)
src-info (if #,(if test-immutable?
pos-blame #'(and (predicate?-name v)
orig-str (immutable? v))
#,(if test-immutable? #'(predicate?-name v))
"expected immutable <~a>, given: ~e" (constructor-name (p-apps (selector-names v)) ...)
"expected <~a>, given: ~e") (raise-contract-error
'type-name v
v))))) src-info
#f)))))))] pos-blame
orig-str
#,(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")
'type-name
v)))))
#f))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name) [(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax-object->datum (syntax arb?))) (eq? #t (syntax-object->datum (syntax arb?)))
(syntax (syntax
@ -1788,8 +1759,7 @@ improve method arity mismatch contract violation error messages?
v))))) v)))))
#f))))))])) #f))))))]))
(define cons-immutable/c (*-immutable/c pair? cons (#f car cdr) immutable-cons cons-immutable/c)) (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define cons-unsafe/c (*-immutable/c pair? cons (#f car cdr) cons cons-unsafe/c #f))
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
(define vector-immutable/c (*-immutable/c vector? (define vector-immutable/c (*-immutable/c vector?
vector-immutable vector-immutable
@ -1799,16 +1769,16 @@ improve method arity mismatch contract violation error messages?
vector-immutable/c)) vector-immutable/c))
;; ;;
;; cons-immutable/c opter ;; cons/c opter
;; ;;
(define/opter (cons-immutable/c opt/i opt/info stx) (define/opter (cons/c opt/i opt/info stx)
(define (opt/cons-immutable-ctc hdp tlp) (define (opt/cons-ctc hdp tlp)
(let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd)
(opt/i opt/info hdp)] (opt/i opt/info hdp)]
[(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl)
(opt/i opt/info tlp)]) (opt/i opt/info tlp)])
(with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) (with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
(syntax (and (immutable? val) (pair? val)))))) (syntax (pair? val)))))
(values (values
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
@ -1842,43 +1812,10 @@ improve method arity mismatch contract violation error messages?
#f #f
(append stronger-ribs-hd stronger-ribs-tl))))) (append stronger-ribs-hd stronger-ribs-tl)))))
(syntax-case stx (cons-immutable/c) (syntax-case stx (cons/c)
[(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)])) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
(define (list/c . args) (define (list/c . args)
(unless (andmap flat-contract/predicate? args)
(error 'list/c "expected flat contracts, got: ~a"
(let loop ([args args])
(cond
[(null? args) ""]
[(null? (cdr args)) (format "~e" (car args))]
[else (string-append
(format "~e " (car args))
(loop (cdr args)))]))))
(let loop ([args args])
(cond
[(null? args) (flat-contract null?)]
[else (cons/c (car args) (loop (cdr args)))])))
(define (list-immutable/c . args)
(unless (andmap (λ (x) (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1))))
args)
(error 'list/c "expected contracts or procedures of arity 1, got: ~a"
(let loop ([args args])
(cond
[(null? args) ""]
[(null? (cdr args)) (format "~e" (car args))]
[else (string-append
(format "~e " (car args))
(loop (cdr args)))]))))
(let loop ([args args])
(cond
[(null? args) (flat-contract null?)]
[else (cons-immutable/c (car args) (loop (cdr args)))])))
(define (list-unsafe/c . args)
(unless (andmap (λ (x) (or (contract? x) (unless (andmap (λ (x) (or (contract? x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x 1)))) (procedure-arity-includes? x 1))))
@ -1893,8 +1830,8 @@ improve method arity mismatch contract violation error messages?
(loop (cdr args)))])))) (loop (cdr args)))]))))
(let loop ([args args]) (let loop ([args args])
(cond (cond
[(null? args) (flat-contract null?)] [(null? args) (flat-contract null?)]
[else (cons-unsafe/c (car args) (loop (cdr args)))]))) [else (cons/c (car args) (loop (cdr args)))])))
(define (syntax/c ctc-in) (define (syntax/c ctc-in)
(let ([ctc (coerce-contract 'syntax/c ctc-in)]) (let ([ctc (coerce-contract 'syntax/c ctc-in)])

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

@ -2791,7 +2791,7 @@
(test/pos-blame (test/pos-blame
'immutable1 'immutable1
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) '(let ([ct (contract (listof (boolean? . -> . boolean?))
#f #f
'pos 'pos
'neg)]) 'neg)])
@ -2799,7 +2799,7 @@
(test/pos-blame (test/pos-blame
'immutable2 'immutable2
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) '(let ([ct (contract (listof (boolean? . -> . boolean?))
(list (lambda (x) x)) (list (lambda (x) x))
'pos 'pos
'neg)]) 'neg)])
@ -2807,24 +2807,24 @@
(test/neg-blame (test/neg-blame
'immutable3 'immutable3
'(let ([ct (contract (list-immutableof (number? . -> . boolean?)) '(let ([ct (contract (listof (number? . -> . boolean?))
(list-immutable (lambda (x) 1)) (list (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((car ct) #f))) ((car ct) #f)))
(test/pos-blame (test/pos-blame
'immutable4 'immutable4
'(let ([ct (contract (list-immutableof (number? . -> . boolean?)) '(let ([ct (contract (listof (number? . -> . boolean?))
(list-immutable (lambda (x) 1)) (list (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((car ct) 1))) ((car ct) 1)))
(test/spec-passed (test/spec-passed
'immutable5 'immutable5
'(let ([ct (contract (list-immutableof (number? . -> . boolean?)) '(let ([ct (contract (listof (number? . -> . boolean?))
(list-immutable (lambda (x) #t)) (list (lambda (x) #t))
'pos 'pos
'neg)]) 'neg)])
((car ct) 1))) ((car ct) 1)))
@ -2832,119 +2832,96 @@
(test/pos-blame (test/pos-blame
'immutable6 'immutable6
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) '(contract (cons/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
#f #f
'pos 'pos
'neg)) 'neg))
(test/pos-blame
'immutable7
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
(cons (lambda (x) x) (lambda (x) x))
'pos
'neg))
(test/neg-blame (test/neg-blame
'immutable8 'immutable8
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1)) (cons (lambda (x) 1) (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((car ct) #f))) ((car ct) #f)))
(test/neg-blame (test/neg-blame
'immutable9 'immutable9
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1)) (cons (lambda (x) 1) (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((cdr ct) #f))) ((cdr ct) #f)))
(test/pos-blame (test/pos-blame
'immutable10 'immutable10
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1)) (cons (lambda (x) 1) (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((car ct) 1))) ((car ct) 1)))
(test/pos-blame (test/pos-blame
'immutable11 'immutable11
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1)) (cons (lambda (x) 1) (lambda (x) 1))
'pos 'pos
'neg)]) 'neg)])
((cdr ct) 1))) ((cdr ct) 1)))
(test/spec-passed (test/spec-passed
'immutable12 'immutable12
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) #t) (lambda (x) #t)) (cons (lambda (x) #t) (lambda (x) #t))
'pos 'pos
'neg)]) 'neg)])
((car ct) 1))) ((car ct) 1)))
(test/spec-passed (test/spec-passed
'immutable13 'immutable13
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ct (contract (cons/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) #t) (lambda (x) #t)) (cons (lambda (x) #t) (lambda (x) #t))
'pos 'pos
'neg)]) 'neg)])
((cdr ct) 1))) ((cdr ct) 1)))
(test/spec-passed/result (test/spec-passed/result
'immutable14 'immutable14
'(contract (cons-immutable/c number? boolean?) '(contract (cons/c number? boolean?)
(cons-immutable 1 #t) (cons 1 #t)
'pos 'pos
'neg) 'neg)
(cons-immutable 1 #t)) (cons 1 #t))
(test/pos-blame (test/pos-blame
'immutable15 'immutable15
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
#f #f
'pos 'pos
'neg)) 'neg))
(test/pos-blame
'immutable16
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t) (lambda (x) #t))
'pos
'neg))
(test/pos-blame (test/pos-blame
'immutable17 'immutable17
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t)) (list (lambda (x) #t))
'pos 'pos
'neg)) 'neg))
(test/pos-blame (test/pos-blame
'immutable18 'immutable18
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) (list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))
'pos 'pos
'neg)) 'neg))
(test/spec-passed (test/spec-passed
'immutable19 'immutable19
'(let ([ctc (contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) '(let ([ctc (contract (list/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t) (lambda (x) #t)) (list (lambda (x) #t) (lambda (x) #t))
'pos 'pos
'neg)]) 'neg)])
(for-each (lambda (x) (x 1)) ctc))) (for-each (lambda (x) (x 1)) ctc)))
(test/spec-passed/result
'immutable20
'(let ([ctc (contract (list-immutable/c number?)
(list-immutable 1)
'pos
'neg)])
(immutable? ctc))
#t)
(test/pos-blame (test/pos-blame
'vector-immutable1 'vector-immutable1
'(contract (vector-immutableof (boolean? . -> . boolean?)) '(contract (vector-immutableof (boolean? . -> . boolean?))
@ -3090,191 +3067,6 @@
'neg)) 'neg))
#t) #t)
(test/pos-blame
'unsafe1
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
#f
'pos
'neg)])
((car ct) 1)))
(test/neg-blame
'unsafe2
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
(list (lambda (x) x))
'pos
'neg)])
((car ct) 1)))
(test/spec-passed
'unsafe2b
'(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?))
(list (lambda (x) x))
'pos
'neg)])
((car ct) #t)))
(test/neg-blame
'unsafe3
'(let ([ct (contract (listof-unsafe (number? . -> . boolean?))
(list (lambda (x) 1))
'pos
'neg)])
((car ct) #f)))
(test/pos-blame
'unsafe4
'(let ([ct (contract (list-unsafe/c (number? . -> . boolean?))
(list (lambda (x) 1))
'pos
'neg)])
((car ct) 1)))
(test/spec-passed
'unsafe5
'(let ([ct (contract (listof-unsafe (number? . -> . boolean?))
(list (lambda (x) #t))
'pos
'neg)])
((car ct) 1)))
(test/pos-blame
'unsafe6
'(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
#f
'pos
'neg))
(test/spec-passed
'unsafe7
'(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
(cons (lambda (x) x) (lambda (x) x))
'pos
'neg))
(test/neg-blame
'unsafe8
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((car ct) #f)))
(test/neg-blame
'unsafe9
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((cdr ct) #f)))
(test/pos-blame
'unsafe10
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((car ct) 1)))
(test/pos-blame
'unsafe11
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((cdr ct) 1)))
(test/spec-passed
'unsafe12
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
((car ct) 1)))
(test/spec-passed
'unsafe13
'(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
((cdr ct) 1)))
(test/spec-passed/result
'unsafe14
'(contract (cons-unsafe/c number? boolean?)
(cons 1 #t)
'pos
'neg)
(cons-immutable 1 #t))
(test/pos-blame
'unsafe15
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
#f
'pos
'neg))
(test/spec-passed
'unsafe16
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t) (lambda (x) #t))
'pos
'neg))
(test/pos-blame
'unsafe17
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t))
'pos
'neg))
(test/pos-blame
'unsafe18
'(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))
'pos
'neg))
(test/spec-passed
'unsafe19
'(let ([ctc (contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
(for-each (lambda (x) (x 1)) ctc)))
(test/spec-passed/result
'unsafe20
'(let ([ctc (contract (list-unsafe/c number?)
(list 1)
'pos
'neg)])
(immutable? ctc))
#f)
(test/spec-passed/result
'unsafe21
'(let* ([orig-list (list 1 2 3)]
[ctc (contract (listof-unsafe number?)
orig-list
'pos
'neg)])
(eq? orig-list ctc))
#f)
(test/spec-passed/result
'listof-no-copy
'(let* ([orig-list (list 1 2 3)]
[ctc (contract (listof number?)
orig-list
'pos
'neg)])
(eq? orig-list ctc))
#t)
(test/pos-blame (test/pos-blame
'promise/c1 'promise/c1
'(force (contract (promise/c boolean?) '(force (contract (promise/c boolean?)
@ -4385,10 +4177,10 @@ so that propagation occurs.
(test-name '(listof boolean?) (listof boolean?)) (test-name '(listof boolean?) (listof boolean?))
(test-name '(listof any/c) (listof any/c)) (test-name '(listof any/c) (listof any/c))
(test-name '(list-immutableof boolean?) (list-immutableof boolean?)) (test-name '(listof boolean?) (listof boolean?))
(test-name '(list-immutableof any/c) (list-immutableof any/c)) (test-name '(listof any/c) (listof any/c))
(test-name '(list-immutableof boolean?) (list-immutableof boolean?)) (test-name '(listof boolean?) (listof boolean?))
(test-name '(list-immutableof (-> boolean? boolean?)) (list-immutableof (-> boolean? boolean?))) (test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?)))
(test-name '(vectorof boolean?) (vectorof boolean?)) (test-name '(vectorof boolean?) (vectorof boolean?))
(test-name '(vectorof any/c) (vectorof any/c)) (test-name '(vectorof any/c) (vectorof any/c))
@ -4401,19 +4193,19 @@ so that propagation occurs.
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?))) (test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?))) (test-name '(cons/c boolean? (cons/c integer? null?)) (list/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?))) (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?))) (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c boolean? integer?) (cons-immutable/c boolean? (flat-contract integer?))) (test-name '(cons/c boolean? integer?) (cons/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable/c (-> boolean? boolean?) integer?)) (test-name '(cons/c (-> boolean? boolean?) integer?) (cons/c (-> boolean? boolean?) integer?))
(test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?)) (test-name '(cons/c boolean? (cons/c integer? null?))
(list-immutable/c boolean? (flat-contract integer?))) (list/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?)) (test-name '(cons/c boolean? (cons/c integer? null?))
(list-immutable/c boolean? (flat-contract integer?))) (list/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c boolean? (cons-immutable/c integer? null?)) (test-name '(cons/c boolean? (cons/c integer? null?))
(list-immutable/c boolean? (flat-contract integer?))) (list/c boolean? (flat-contract integer?)))
(test-name '(cons-immutable/c (-> boolean? boolean?) (cons-immutable/c integer? null?)) (test-name '(cons/c (-> boolean? boolean?) (cons/c integer? null?))
(list-immutable/c (-> boolean? boolean?) integer?)) (list/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer?) (parameter/c integer?)) (test-name '(parameter/c integer?) (parameter/c integer?))
@ -4639,9 +4431,9 @@ so that propagation occurs.
(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) x))
(ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x)) (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x))
(ctest #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1)) (ctest #t contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (list-immutableof integer?) (list 1)) (ctest #f contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (list-immutableof integer?) #f) (ctest #f contract-first-order-passes? (listof integer?) #f)
(ctest #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1))) (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?) 'x)
@ -4717,11 +4509,11 @@ so that propagation occurs.
(ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) (ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x))
(ctest #t contract-first-order-passes? (ctest #t contract-first-order-passes?
(cons-immutable/c boolean? (-> integer? integer?)) (cons/c boolean? (-> integer? integer?))
(list*-immutable #t (λ (x) x))) (list* #t (λ (x) x)))
(ctest #t contract-first-order-passes? (ctest #t contract-first-order-passes?
(cons-immutable/c boolean? (-> integer? integer?)) (cons/c boolean? (-> integer? integer?))
(list*-immutable 1 2)) (list* 1 2))
(ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1)
@ -4912,7 +4704,7 @@ so that propagation occurs.
(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 mzscheme
(require 'contract-test-suite6b) (require 'contract-test-suite6b)
(require (lib "contract.ss")) (require (lib "contract.ss"))
@ -4973,7 +4765,7 @@ so that propagation occurs.
(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 mzscheme
(require (lib "struct.ss") (require (lib "struct.ss")
pc10-m) 'pc10-m)
(print-struct #t) (print-struct #t)
(copy-struct s (copy-struct s
(make-s 1 2) (make-s 1 2)
@ -5166,7 +4958,7 @@ so that propagation occurs.
(provide/contract [f integer?]) (provide/contract [f integer?])
(define f 1))) (define f 1)))
(eval '(module provide/contract21b mzscheme (eval '(module provide/contract21b mzscheme
(require-for-syntax provide/contract21a) (require-for-syntax 'provide/contract21a)
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
f f f f
#'1))))) #'1)))))
@ -5179,7 +4971,7 @@ so that propagation occurs.
(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 mzscheme
(require-for-syntax provide/contract22a) (require-for-syntax 'provide/contract22a)
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
make-bound-identifier-mapping) make-bound-identifier-mapping)