From 36b3493e45aba4b30c97a4fea7ee5fc931ae64da Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 Jan 2016 15:02:10 -0600 Subject: [PATCH] Change contracts of the form (-> any/c ... any) to not be flat contracts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The issue is what happens when the actual function has other arities. For example, if the function were (λ (x [y 1]) y) then it is not okay to simply check if procedure-arity-includes? of 1 is true (what the code used to do) because then when the function is applied to 2 arguments, the call won't fail like it should. It is possible to check and reject functions that don't have exactly the right arity, but if the contract were (-> string? any), then the function would have been allowed and only when the extra argument is supplied would the error occur. So, this commit makes it so that (-> any/c any) is like (-> string? any), but with the optimization that if the procedure accepts only one argument, then no wrapper is created. This is a backwards incompatible change because it used to be the case that (flat-contract? (-> any)) returned #t and it now returns #f. --- .../tests/racket/contract/arrow.rkt | 4 ++ .../tests/racket/contract/flat-contracts.rkt | 5 -- .../tests/racket/contract/predicates.rkt | 2 - .../contract/private/arrow-higher-order.rkt | 39 +++++++++++++-- .../contract/private/arrow-val-first.rkt | 47 ------------------- .../racket/contract/private/arrow.rkt | 23 +-------- 6 files changed, 40 insertions(+), 80 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index c0de59f415..567b9233a4 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -318,6 +318,10 @@ (test/pos-blame 'contract-any/c-arrow4 '(contract (-> any/c any) (λ (x #:y y) x) 'pos 'neg)) + + (test/neg-blame + 'contract-any/c-arrow5 + '((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2)) (test/spec-passed 'contract-arrow-all-kwds2 diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 2eb2d1418f..3c538b504d 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -71,11 +71,6 @@ (test-flat-contract #rx#".x." "axq" "x") (test-flat-contract ''() '() #f) - (test-flat-contract '(-> any/c any/c any) (λ (x y) 1) (λ (x y z) 1)) - (test-flat-contract '(->* (any/c any/c) any) (λ (x y) 1) (λ (x y z) 1)) - (test-flat-contract '(->* () any) (λ () 1) (λ (x y z w) 1)) - (test-flat-contract '(->* () () any) (λ () 1) (λ (x) 1)) - (test-flat-contract '(if/c integer? even? list?) 2 3) (test-flat-contract '(if/c integer? even? list?) '() #f) diff --git a/pkgs/racket-test/tests/racket/contract/predicates.rkt b/pkgs/racket-test/tests/racket/contract/predicates.rkt index 031d9baaf6..733affcb5b 100644 --- a/pkgs/racket-test/tests/racket/contract/predicates.rkt +++ b/pkgs/racket-test/tests/racket/contract/predicates.rkt @@ -15,8 +15,6 @@ (ctest #t flat-contract? (first-or/c (flat-contract integer?) (flat-contract boolean?))) (ctest #t flat-contract? (first-or/c integer? boolean?)) - (ctest #t flat-contract? (-> any/c any/c any)) - (ctest #t flat-contract? (and/c)) (ctest #t flat-contract? (and/c number? integer?)) (ctest #t flat-contract? (and/c (flat-contract number?) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 8c72a5cdde..b5590cd93a 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -357,6 +357,14 @@ late-neg?) (define optionals-length (- (length doms) min-arity)) (define mtd? #f) ;; not yet supported for the new contracts + (define okay-to-do-only-arity-check? + (and (not rest) + (not pre?) + (not post?) + (null? kwd-infos) + (not rngs) + (andmap any/c? doms) + (= optionals-length 0))) (λ (orig-blame) (define rng-blame (arrow:blame-add-range-context orig-blame)) (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) @@ -425,19 +433,24 @@ impersonator-prop:application-mark (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))] [else val])) - (cond [late-neg? - (λ (val neg-party) + (define (arrow-higher-order:lnp val neg-party) (cond [(do-arity-checking orig-blame val doms rest min-arity kwd-infos) => (λ (f) (f neg-party))] [else - (successfully-got-the-right-kind-of-function val neg-party)]))] + (successfully-got-the-right-kind-of-function val neg-party)])) + (if okay-to-do-only-arity-check? + (λ (val neg-party) + (cond + [(procedure-arity-exactly/no-kwds val min-arity) val] + [else (arrow-higher-order:lnp val neg-party)])) + arrow-higher-order:lnp)] [else - (λ (val) + (define (arrow-higher-order:vfp val) (wrapped-extra-arg-arrow (cond [(do-arity-checking orig-blame val doms rest min-arity kwd-infos) @@ -446,4 +459,20 @@ [else (λ (neg-party) (successfully-got-the-right-kind-of-function val neg-party))]) - (apply plus-one-arity-function orig-blame val plus-one-constructor-args)))]))) + (apply plus-one-arity-function orig-blame val plus-one-constructor-args))) + (if okay-to-do-only-arity-check? + (λ (val) + (cond + [(procedure-arity-exactly/no-kwds val min-arity) + (wrapped-extra-arg-arrow + (λ (neg-party) val) + (apply plus-one-arity-function orig-blame val plus-one-constructor-args))] + [else (arrow-higher-order:vfp val)])) + arrow-higher-order:vfp)]))) + +(define (procedure-arity-exactly/no-kwds val min-arity) + (and (procedure? val) + (equal? (procedure-arity val) min-arity) + (let-values ([(man opt) (procedure-keywords val)]) + (and (null? man) + (null? opt))))) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 5d9891fd8f..eeb1adffc5 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -542,9 +542,6 @@ [(_ args ...) (not (->2-handled? stx)) #'(arrow:-> args ...)] - [(_ args ...) - (->2-arity-check-only->? stx) - #`(build-arity-check-only-> #,(->2-arity-check-only->? stx))] [(_ args ... rng) (let () (define this-> (gensym 'this->)) @@ -662,10 +659,6 @@ (define-syntax (->*2 stx) (cond - [(->2*-arity-check-only->? stx) - => - (λ (n) - #`(build-arity-check-only-> #,n))] [(->*2-handled? stx) (define this->* (gensym 'this->*)) (define-values (man-dom man-dom-kwds man-lets @@ -826,18 +819,6 @@ plus-one-arity-function chaperone-constructor)])) -(define (build-arity-check-only-> n) - (make-arity-check-only-> n - (build-list n (λ (_) any/c)) - '() #f #f #f #f - (λ args - (error 'arity-check-only->-plus-one-arity-function - "this function should not be called ~s" args)) - (λ args - (error 'arity-check-only->-chaperone-constructor - "this function should not be called ~s" args)) - n)) - (define (dynamic->* #:mandatory-domain-contracts [mandatory-domain-contracts '()] #:optional-domain-contracts [optional-domain-contracts '()] #:mandatory-keywords [unsorted-mandatory-keywords '()] @@ -1244,34 +1225,6 @@ (not (base->-pre? that)) (not (base->-post? this)) (not (base->-post? that)))) - -(define-struct (arity-check-only-> base->) (arity) - #:property - prop:flat-contract - (build-flat-contract-property - #:name base->-name - #:first-order - (λ (ctc) - (define arity (arity-check-only->-arity ctc)) - (λ (val) - (arrow:procedure-arity-includes?/no-kwds val arity))) - #:late-neg-projection - (λ (ctc) - (define arity (arity-check-only->-arity ctc)) - (λ (blame) - (λ (val neg-party) - (if (arrow:procedure-arity-includes?/no-kwds val arity) - val - (raise-blame-error - blame #:missing-party neg-party val - '(expected: "a procedure that accepts ~a non-keyword argument~a" - given: "~e") - arity - (if (= arity 1) "" "s") - val))))) - #:stronger ->-stronger - #:generate ->-generate - #:exercise ->-exercise)) (define-struct (-> base->) () #:property diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index c7c510a193..72b596f12f 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -41,8 +41,7 @@ blame-add-range-context blame-add-nth-arg-context raise-no-keywords-arg - raise-wrong-number-of-args-error - procedure-arity-includes?/no-kwds) + raise-wrong-number-of-args-error) (define-syntax-parameter making-a-method #f) (define-syntax-parameter method-contract? #f) @@ -1908,25 +1907,7 @@ (define-syntax (-> stx) - (syntax-case stx (any any/c boolean?) - [(_ any/c ... any) - (not (syntax-parameter-value #'making-a-method)) - ;; special case the (-> any/c ... any) contracts to be first-order checks only - ;; this is now implemented by ->2 so we should get here only when we're - ;; building an ->m contract - (let ([dom-len (- (length (syntax->list stx)) 2)]) - #`(flat-named-contract - '(-> #,@(build-list dom-len (λ (x) 'any/c)) any) - (λ (x) - (procedure-arity-includes?/no-kwds x #,dom-len))))] - [_ - #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))])) - -(define (procedure-arity-includes?/no-kwds val dom-len) - (and (procedure? val) - (procedure-arity-includes? val dom-len) - (let-values ([(man opt) (procedure-keywords val)]) - (null? man)))) + #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))) ;; this is to make the expanded versions a little easier to read (define-syntax (values/drop stx)