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

added unconstrained-domain->

Browse Source 
svn: r5967
This commit is contained in:
Robby Findler 2007-04-17 18:54:19 +00:00
parent 382209d3fb
commit db8cba03aa
2 changed files with 56 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mzlib/private/contract-arrow.ss
View File

@ -23,6 +23,7 @@
case->
opt->
opt->*
unconstrained-domain->
object-contract
mixin-contract
make-mixin-contract
@ -33,6 +34,31 @@
check-procedure)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
(λ (val)
(if (procedure? val)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
(define-syntax (any stx)
(raise-syntax-error 'any "Use any out of an arrow contract" stx))

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

@ -173,6 +173,9 @@
(test/no-error '(opt->* (integer?) (integer?) any))
(test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) any))
(test/no-error '(unconstrained-domain-> number?))
(test/no-error '(unconstrained-domain-> (flat-contract number?)))
(test/no-error '(listof any/c))
(test/no-error '(listof (lambda (x) #t)))
@ -1377,6 +1380,31 @@
'neg)])
(cf (lambda (x%) 'going-to-be-bad))))
(test/spec-passed
'unconstrained-domain->1
'(contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg))
(test/pos-blame
'unconstrained-domain->2
'(contract (unconstrained-domain-> number?) 1 'pos 'neg))
(test/spec-passed
'unconstrained-domain->3
'((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) 1))
(test/pos-blame
'unconstrained-domain->4
'((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) #f))
(test/spec-passed/result
'unconstrained-domain->4
'((contract (->r ([size natural-number/c]
[proc (and/c (unconstrained-domain-> number?)
(λ (p) (procedure-arity-includes? p size)))])
number?)
(λ (i f) (apply f (build-list i add1)))
'pos
'neg)
10 +)
55)
(test/pos-blame
'or/c1
'(contract (or/c false/c) #t 'pos 'neg))
@ -4054,6 +4082,8 @@ so that propagation occurs.
(test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
(case-> (-> integer? integer?) (-> integer? integer? integer?)))
(test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))
(test-name '(or/c) (or/c))
(test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))