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

fixed bug from the mailing list

Browse Source 
svn: r9830
This commit is contained in:
Robby Findler 2008-05-14 11:46:49 +00:00
parent 3379ac44f5
commit 9f69672740
2 changed files with 46 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/scheme/private/contract-arrow.ss
View File

@ -1181,7 +1181,8 @@ v4 todo:
(λ (ctc)
(let* ([to-proj (λ (c) ((proj-get c) c))]
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
[rng-ctcs (map to-proj (get-case->-rng-ctcs ctc))]
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
(and rngs (map to-proj (get-case->-rng-ctcs ctc))))]
[rst-ctcs (case->-rst-ctcs ctc)]
[specs (case->-specs ctc)])
(λ (pos-blame neg-blame src-info orig-str)
@ -1233,7 +1234,7 @@ v4 todo:
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
(make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)
(map (λ (x) (and x (coerce-contract 'case-> x))) rst-ctcs)
(map (λ (l) (and l (map (λ (x) (coerce-contract 'case-> x)) l))) rng-ctcs)
(and rng-ctcs (map (λ (l) (and l (map (λ (x) (coerce-contract 'case-> x)) l))) rng-ctcs))
specs
wrapper))
@ -1246,7 +1247,8 @@ v4 todo:
(case->-dom-ctcs ctc)
(case->-rst-ctcs ctc))))
(define (get-case->-rng-ctcs ctc) (apply append (case->-rng-ctcs ctc)))
(define (get-case->-rng-ctcs ctc)
(apply append (map (λ (x) (or x '())) (case->-rng-ctcs ctc))))
;

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

@ -1786,9 +1786,49 @@
'neg)
1 2))
(test/spec-passed/result
'contract-case->9
'((contract (case-> (-> integer? any))
(lambda (x) 1)
'pos
'neg)
1)
1)
(test/neg-blame
'contract-case->10
'((contract (case-> (-> integer? any))
(lambda (x) 1)
'pos
'neg)
#f))
(test/pos-blame
'contract-case->11
'(contract (case-> (-> integer? any) (-> integer? integer? any))
(lambda (x) 1)
'pos
'neg))
(test/neg-blame
'contract-case->12
'((contract (case-> (-> integer? any) (-> integer? integer? any))
(case-lambda [(x) 1] [(x y) 1])
'pos
'neg)
#f))
(test/spec-passed/result
'contract-case->11
'contract-case->13
'((contract (case-> (-> integer? any) (-> integer? integer? any))
(case-lambda [(x) 1] [(x y) 1])
'pos
'neg)
1)
1)
(test/spec-passed/result
'contract-case->14
'(let ([f
(contract (case-> (-> char?) (-> integer? boolean?) (-> symbol? input-port? string?))
(case-lambda