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

added parameter/c

Browse Source 
svn: r6770
This commit is contained in:
Robby Findler 2007-06-29 16:44:18 +00:00
parent 1a27b9a1a9
commit 2dfd35e5c7
2 changed files with 62 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -825,7 +825,8 @@ improve method arity mismatch contract violation error messages?
syntax/c
check-between/c
check-unary-between/c)
check-unary-between/c
parameter/c)
(define-syntax (flat-rec-contract stx)
(syntax-case stx ()
@ -1976,4 +1977,44 @@ improve method arity mismatch contract violation error messages?
(and (predicate-id val)
(ctc-pred-x (selector-id val)) ...))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])))
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
(define (parameter/c x)
(make-parameter/c (coerce-contract 'parameter/c x)))
(define-struct/prop parameter/c (ctc)
((proj-prop (λ (ctc)
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
[partial-pos-contract (c-proc neg-blame pos-blame src-info orig-str)])
(λ (val)
(cond
[(parameter? val)
(make-derived-parameter
val
#;partial-pos-contract
partial-neg-contract)]
[else
(raise-contract-error val src-info pos-blame orig-str
"expected a parameter")])))))))
(name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))))
(first-order-prop
(λ (ctc)
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (x)
(and (parameter? x)
(tst (x)))))))
(stronger-prop
(λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....)
(and (parameter/c? that)
(contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this)))))))
)

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

@ -1538,6 +1538,19 @@
1)
x)
(reverse '(1 3 4 2)))
(test/neg-blame
'parameter/c1
'((contract (parameter/c integer?)
(make-parameter 1)
'pos 'neg)
#f))
(test/pos-blame
'parameter/c1
'((contract (parameter/c integer?)
(make-parameter 'not-an-int)
'pos 'neg)))
(test/spec-passed
'define/contract1
@ -4398,6 +4411,8 @@ so that propagation occurs.
(test-name '(cons-immutable/c (-> boolean? boolean?) (cons-immutable/c integer? null?))
(list-immutable/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer?) (parameter/c integer?))
(test-name '(box/c boolean?) (box/c boolean?))
(test-name '(box/c boolean?) (box/c (flat-contract boolean?)))
(test-name 'the-name (flat-rec-contract the-name))
@ -4509,6 +4524,10 @@ so that propagation occurs.
(ctest #t contract-stronger? number? number?)
(ctest #f contract-stronger? boolean? number?)
(ctest #t contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5)))
(ctest #f contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4)))
(ctest #f contract-stronger? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5)))
(ctest #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z))
(ctest #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y))