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

Fix arity checking for ->*.

Browse Source 
Some functions were passing when they shouldn't have, only to fail when
the function is called.

Technically not backwards compatible, but should only affect functions
that were never called.
This commit is contained in:
Vincent St-Amour 2016-03-18 12:34:26 -05:00
parent b94e77a062
commit 894873c2ff
2 changed files with 47 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-test/tests/racket/contract/arrow-star.rkt
View File

@ -716,4 +716,20 @@
(test/spec-passed
'->*-opt-optional5
'((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg))))
'((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg)))
(test/pos-blame
'->*-opt-vs-mand1
'(contract (->* (integer?) (symbol? boolean?) number?)
(lambda (x y [z #t])
x)
'pos
'neg))
(test/pos-blame
'->*-opt-vs-mand2
'(contract (->* () (symbol? boolean?) symbol?)
(lambda (y [z #t])
y)
'pos
'neg))
)

57
racket/collects/racket/contract/private/arity-checking.rkt
View File

@ -29,33 +29,36 @@
(define exra-required-args (if (ellipsis-rest-arg-ctc? ->stct-rest)
(length (*list-ctc-suffix ->stct-rest))
0))
(define expected-number-of-non-keyword-args (+ (length ->stct-doms) exra-required-args))
(define matching-arity?
(and (for/or ([a (in-list arity)])
(or (equal? expected-number-of-non-keyword-args a)
(and (arity-at-least? a)
(>= expected-number-of-non-keyword-args (arity-at-least-value a)))))
(if ->stct-rest
(let ([lst (car (reverse arity))])
(and (arity-at-least? lst)
(<= (arity-at-least-value lst) (+ exra-required-args ->stct-min-arity))))
#t)))
(unless matching-arity?
(k
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party val
'(expected:
"a procedure that accepts ~a non-keyword argument~a~a"
given: "~e"
"\n ~a")
expected-number-of-non-keyword-args
(if (= expected-number-of-non-keyword-args 1) "" "s")
(if ->stct-rest
" and arbitrarily many more"
"")
val
(arity-as-string val)))))
;; the function must be ok for *all* the arities the contract says are ok
(for/and ([base-number-of-non-keyword-args (in-range ->stct-min-arity (add1 (length ->stct-doms)))])
(define expected-number-of-non-keyword-args (+ base-number-of-non-keyword-args exra-required-args))
(define matching-arity?
(and (for/or ([a (in-list arity)])
(or (and (equal? expected-number-of-non-keyword-args a))
(and (arity-at-least? a)
(>= expected-number-of-non-keyword-args (arity-at-least-value a)))))
(if ->stct-rest
(let ([lst (car (reverse arity))])
(and (arity-at-least? lst)
(<= (arity-at-least-value lst) (+ exra-required-args ->stct-min-arity))))
#t)))
(unless matching-arity?
(k
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party val
'(expected:
"a procedure that accepts ~a non-keyword argument~a~a"
given: "~e"
"\n ~a")
expected-number-of-non-keyword-args
(if (= expected-number-of-non-keyword-args 1) "" "s")
(if ->stct-rest
" and arbitrarily many more"
"")
val
(arity-as-string val))))))
(define (should-have-supplied kwd)
(k
(λ (neg-party)