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

fix case-> to not abuse procedure-chaperone

Browse Source 
closes PR 13697
This commit is contained in:
Robby Findler 2013-04-16 09:46:04 -05:00
parent d1e7841f84
commit a46e4c71b6
2 changed files with 16 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/racket/contract/private/arrow.rkt
View File

@ -1561,7 +1561,12 @@ v4 todo:
(this-parameter ... dom-formals ... . #,(if rst #'rst-formal '())) (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
#,(cond #,(cond
[rng [rng
(let ([rng-checkers (list #'(λ (rng-id ...) (values/drop (rng-proj-x rng-id) ...)))] (let ([rng-checkers (list #`(case-lambda
[(rng-id ...) (values/drop (rng-proj-x rng-id) ...)]
[args
(bad-number-of-results blame f
#,(length (syntax->list #'(rng-id ...)))
args)]))]
[rng-length (length (syntax->list rng))]) [rng-length (length (syntax->list rng))])
(if rst (if rst
(check-tail-contract #'(rng-proj-x ...) rng-checkers (check-tail-contract #'(rng-proj-x ...) rng-checkers

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

@ -3577,6 +3577,16 @@
(f 1) (f 1)
(f 'x (open-input-string (format "~s" "string"))))) (f 'x (open-input-string (format "~s" "string")))))
(list #\a #f "xstring")) (list #\a #f "xstring"))
(test/pos-blame
'contract-case->15
'((contract (case-> (-> real? real? real?)
(-> real? (values real? real?)))
(case-lambda
[(x y) 1]
[(x) 1])
'pos 'neg)
1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; ;; ;;