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

Fix contract name of parameter/c

Browse Source 
Made it more backwards compatible
This commit is contained in:
Asumu Takikawa 2013-01-23 18:02:52 -05:00
parent a2f33f17e9
commit 14c970b490
2 changed files with 18 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/racket/contract/private/misc.rkt
View File

@ -853,11 +853,19 @@
;; (parameter/c in/out-ctc)
;; (parameter/c in-ctc out-ctc)
(define/subexpression-pos-prop parameter/c
(λ (in-ctc [out-ctc in-ctc])
(make-parameter/c (coerce-contract 'parameter/c in-ctc)
(coerce-contract 'parameter-c out-ctc))))
(case-lambda
[(in-ctc)
(define ctc (coerce-contract 'parameter/c in-ctc))
(make-parameter/c ctc ctc #f)]
[(in-ctc out-ctc)
(make-parameter/c (coerce-contract 'parameter/c in-ctc)
(coerce-contract 'parameter-c out-ctc)
#t)]))
(define-struct parameter/c (in out)
;; in - negative contract
;; out - positive contract
;; both-supplied? - for backwards compat printing
(define-struct parameter/c (in out both-supplied?)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
@ -880,9 +888,11 @@
(raise-blame-error blame val '(expected "a parameter"))])))))
#:name
(λ (ctc) (build-compound-type-name 'parameter/c
(parameter/c-in ctc)
(parameter/c-out ctc)))
(λ (ctc) (apply build-compound-type-name
`(parameter/c ,(parameter/c-in ctc)
,@(if (parameter/c-both-supplied? ctc)
(list (parameter/c-out ctc))
(list)))))
#:first-order
(λ (ctc)
(let ([tst (contract-first-order (parameter/c-out ctc))])

2
collects/tests/racket/contract-test.rktl
View File

@ -12216,7 +12216,7 @@ so that propagation occurs.
(test-name '(list/c (-> boolean? boolean?) integer?)
(list/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer? integer?) (parameter/c integer?))
(test-name '(parameter/c integer?) (parameter/c integer?))
(test-name '(parameter/c integer? string?) (parameter/c integer? string?))
(test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?))