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

fix predicate/c bugs

Browse Source
This commit is contained in:
Robby Findler 2015-10-29 13:33:28 -05:00
parent 3f20803679
commit aa46d1bc10
3 changed files with 21 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -377,6 +377,15 @@
(test/spec-passed
'predicate/c10
'((contract (-> any/c boolean?) (λ (x) #t) 'pos 'neg) 12))
(test/spec-passed
'predicate/c11
'((contract (-> any/c boolean?) (λ x #t) 'pos 'neg) 12))
(test/neg-blame
'predicate/c12
'((contract (-> any/c boolean?) (λ (x #:y [y 1]) #t) 'pos 'neg) 12 #:y 1))
(test/pos-blame
'predicate/c13
'(contract (-> any/c boolean?) (λ (x #:y y) #t) 'pos 'neg))
;; this test ensures that no contract wrappers
;; are created for struct predicates

12
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -1290,17 +1290,21 @@
f))
(cond
[(struct-predicate-procedure? f) #f]
[(equal? (procedure-arity f) 1)
[(and (equal? (procedure-arity f) 1)
(let-values ([(required mandatory) (procedure-keywords f)])
(and (null? required)
(null? mandatory))))
(λ (arg)
(values (rng-checker f blame neg-party) arg))]
[(procedure-arity-includes? f 1)
(make-keyword-procedure
(λ (kwds kwd-args . other)
(unless (null? kwds)
(arrow:raise-no-keywords-arg blame f kwds))
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
(unless (= 1 (length other))
(arrow:raise-wrong-number-of-args-error blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) '() (car other))))]))))
(arrow:raise-wrong-number-of-args-error #:missing-party neg-party
blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) (car other))))]))))
(define -predicate/c (mk-any/c->boolean-contract predicate/c))
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->))

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

@ -449,7 +449,7 @@
basic-checker-name)]))
(define (raise-wrong-number-of-args-error
blame val
blame #:missing-party [missing-party #f] val
args-len max-arity min-method-arity max-method-arity)
(define arity-string
(if max-arity
@ -462,11 +462,13 @@
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)])
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(raise-blame-error (blame-swap blame) val
#:missing-party missing-party
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(define (raise-no-keywords-arg blame val given-kwds)
(define (raise-no-keywords-arg blame #:missing-party [missing-party #f] val given-kwds)
(raise-blame-error (blame-swap blame) val
#:missing-party missing-party
(list 'expected:
"no keywords"
'given: