From 0edcbf3f825a8a7c965b00575933612d280a9913 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 28 Dec 2013 16:14:46 -0600 Subject: [PATCH] fix bug in ->* contract combinator that would cause the optional and mandatory keyword arguments to get mixed up in certain situations --- .../tests/racket/contract/arrow-neg-party.rkt | 23 ++++++++++++++++--- .../tests/racket/contract/arrow-star.rkt | 17 ++++++++++++++ .../contract/private/arrow-higher-order.rkt | 23 +++++++++++-------- .../collects/racket/contract/private/guts.rkt | 20 ++++++++-------- 4 files changed, 61 insertions(+), 22 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt index c83c74f1dd..b34be9e078 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt @@ -16,7 +16,7 @@ #f #t)) (wrapped-extra-arg-arrow-extra-neg-party-argument (((contract-struct-val-first-projection c) blame) val)))) -#| + (test/spec-passed/result 'arity-as-string1 '(arity-as-string (let ([f (λ (x) x)]) f)) @@ -160,7 +160,7 @@ (->* () (boolean? char? integer?) any) (λ args 1)) 'neg #f #\f #xf)) - |# + (test/spec-passed '->*neg-party10 '((neg-party-fn @@ -226,4 +226,21 @@ (and/c hash? immutable?)) (λ (h #:combine [x void] #:combine/key [y void] . rest) (hash))) - 'neg (hash) 11 12))) + 'neg (hash) 11 12)) + + (test/spec-passed/result + '->*neg-party18 + '((neg-party-fn + (->* (#:user string?) + (#:database (or/c string? #f) + #:password (or/c string? (list/c 'hash string?) #f) + #:port (or/c exact-positive-integer? #f)) + any/c) + (λ (#:user user + #:database [db #f] + #:password [password #f] + #:port [port #f]) + (list user db password port))) + 'neg #:database "db" #:password "password" #:user "user") + (list "user" "db" "password" #f))) + diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt index 1f314b8fb0..4f105543bf 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-star.rkt @@ -526,6 +526,23 @@ new-statement 'pos 'neg))) + (test/spec-passed/result + 'contract-arrow-star-optional25 + '((contract + (->* (#:user string?) + (#:database (or/c string? #f) + #:password (or/c string? (list/c 'hash string?) #f) + #:port (or/c exact-positive-integer? #f)) + any/c) + (λ (#:user user + #:database [db #f] + #:password [password #f] + #:port [port #f]) + (list user db password port)) + 'pos 'neg) + #:database "db" #:password "password" #:user "user") + (list "user" "db" "password" #f)) + (test/spec-passed 'contract-arrow-star-keyword-ordering '((contract (->* (integer? #:x boolean?) (string? #:y char?) any) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 3b42387baf..de5531b4ff 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -32,8 +32,8 @@ [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]) #`(λ (blame f neg-party mandatory-dom-proj ... - rest-proj ... optional-dom-proj ... + rest-proj ... mandatory-dom-kwd-proj ... optional-dom-kwd-proj ... rng-proj ...) @@ -321,21 +321,24 @@ (kwd-proj (blame-add-context orig-blame (format "the ~a argument of" (kwd-info-kwd kwd)) #:swap? #t)))) - (define the-args (append partial-doms - (if partial-rest (list partial-rest) '()) - partial-kwds - partial-ranges)) - (define plus-one-constructor-args - (append partial-doms - (for/list ([partial-kwd (in-list partial-kwds)] + (define man-then-opt-partial-kwds + (append (for/list ([partial-kwd (in-list partial-kwds)] [kwd-info (in-list kwd-infos)] #:when (kwd-info-mandatory? kwd-info)) partial-kwd) (for/list ([partial-kwd (in-list partial-kwds)] [kwd-info (in-list kwd-infos)] #:unless (kwd-info-mandatory? kwd-info)) - partial-kwd) - partial-ranges + partial-kwd))) + + (define the-args (append partial-doms + (if partial-rest (list partial-rest) '()) + man-then-opt-partial-kwds + partial-ranges)) + (define plus-one-constructor-args + (append partial-doms + man-then-opt-partial-kwds + partial-ranges (if partial-rest (list partial-rest) '()))) (λ (val) (wrapped-extra-arg-arrow diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 9881a270d9..13b989405f 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -359,15 +359,17 @@ (define p? (predicate-contract-pred ctc)) (define name (predicate-contract-name ctc)) (λ (blame) - (λ (v) - (if (p? v) - (λ (neg-party) - v) - (λ (neg-party) - (raise-blame-error blame v #:missing-party neg-party - '(expected: "~s" given: "~e") - name - v)))))) + (let ([predicate-contract-proj + (λ (v) + (if (p? v) + (λ (neg-party) + v) + (λ (neg-party) + (raise-blame-error blame v #:missing-party neg-party + '(expected: "~s" given: "~e") + name + v))))]) + predicate-contract-proj))) #:generate (λ (ctc) (let ([generate (predicate-contract-generate ctc)]) (if (generate-ctc-fail? generate)