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/out-ctc)
;; (parameter/c in-ctc out-ctc) ;; (parameter/c in-ctc out-ctc)
(define/subexpression-pos-prop parameter/c (define/subexpression-pos-prop parameter/c
(λ (in-ctc [out-ctc in-ctc]) (case-lambda
(make-parameter/c (coerce-contract 'parameter/c in-ctc) [(in-ctc)
(coerce-contract 'parameter-c out-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 #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
@ -880,9 +888,11 @@
(raise-blame-error blame val '(expected "a parameter"))]))))) (raise-blame-error blame val '(expected "a parameter"))])))))
#:name #:name
(λ (ctc) (build-compound-type-name 'parameter/c (λ (ctc) (apply build-compound-type-name
(parameter/c-in ctc) `(parameter/c ,(parameter/c-in ctc)
(parameter/c-out ctc))) ,@(if (parameter/c-both-supplied? ctc)
(list (parameter/c-out ctc))
(list)))))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(let ([tst (contract-first-order (parameter/c-out 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?) (test-name '(list/c (-> boolean? boolean?) integer?)
(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 '(parameter/c integer? string?) (parameter/c integer? string?))
(test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?)) (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?))