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 (test/spec-passed
'predicate/c10 'predicate/c10
'((contract (-> any/c boolean?) (λ (x) #t) 'pos 'neg) 12)) '((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 ;; this test ensures that no contract wrappers
;; are created for struct predicates ;; are created for struct predicates

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

@ -1290,17 +1290,21 @@
f)) f))
(cond (cond
[(struct-predicate-procedure? f) #f] [(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) (λ (arg)
(values (rng-checker f blame neg-party) arg))] (values (rng-checker f blame neg-party) arg))]
[(procedure-arity-includes? f 1) [(procedure-arity-includes? f 1)
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . other) (λ (kwds kwd-args . other)
(unless (null? kwds) (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)) (unless (= 1 (length other))
(arrow:raise-wrong-number-of-args-error blame f (length other) 1 1 1)) (arrow:raise-wrong-number-of-args-error #:missing-party neg-party
(values (rng-checker f blame neg-party) '() (car other))))])))) 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 -predicate/c (mk-any/c->boolean-contract predicate/c))
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->)) (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)])) basic-checker-name)]))
(define (raise-wrong-number-of-args-error (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) args-len max-arity min-method-arity max-method-arity)
(define arity-string (define arity-string
(if max-arity (if max-arity
@ -462,11 +462,13 @@
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)]) (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")))) (format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(raise-blame-error (blame-swap blame) val (raise-blame-error (blame-swap blame) val
#:missing-party missing-party
'(received: "~a argument~a" expected: "~a") '(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string)) 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 (raise-blame-error (blame-swap blame) val
#:missing-party missing-party
(list 'expected: (list 'expected:
"no keywords" "no keywords"
'given: 'given: