diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index 567b9233a4..c5ecff1614 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -323,6 +323,19 @@ 'contract-any/c-arrow5 '((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2)) + (test/spec-passed/result + 'contract-any/c-arrow6 + '(let ([f (λ (x) x)]) + (eq? f (contract (-> any/c any) f 'pos 'neg))) + #t) + + (test/spec-passed/result + 'contract-any/c-arrow7 + '(let ([f (λ (x [y 1]) x)]) + (eq? f (contract (-> any/c any) f 'pos 'neg))) + #f) + + (test/spec-passed 'contract-arrow-all-kwds2 '((contract (-> #:a string? void?) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index b5590cd93a..01e0469037 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -11,6 +11,7 @@ (prefix-in arrow: "arrow.rkt")) (provide (for-syntax build-chaperone-constructor/real) + procedure-arity-exactly/no-kwds ->-proj check-pre-cond check-post-cond diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 64c4e97b25..7eaa59ea07 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -6,6 +6,7 @@ "blame.rkt" "arrow.rkt" "arrow-val-first.rkt" + "arrow-higher-order.rkt" "orc.rkt" (for-syntax racket/base syntax/stx @@ -619,6 +620,10 @@ #`(list 'values #,@rng-names)))))) (define (opt/arrow-any-ctc doms) + (define all-anys? (for/and ([d (in-list doms)]) + (syntax-case d (any/c) + [any/c #t] + [anything-else #f]))) (let*-values ([(dom-vars) (generate-temporaries doms)] [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names) (let loop ([vars dom-vars] @@ -662,14 +667,20 @@ ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) - (syntax (begin - (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f) - (chaperone-procedure - val - (case-lambda - [(dom-arg ...) (values next-dom ...)] - [args - (bad-number-of-arguments blame val args dom-len)]))))) + (define do-chap-stx + #'(begin + (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f) + (chaperone-procedure + val + (case-lambda + [(dom-arg ...) (values next-dom ...)] + [args + (bad-number-of-arguments blame val args dom-len)])))) + (if all-anys? + #`(if (procedure-arity-exactly/no-kwds val #,(length doms)) + val + #,do-chap-stx) + do-chap-stx)) lifts-doms superlifts-doms partials-doms @@ -682,25 +693,6 @@ 'any)))) (syntax-case* stx (-> values any any/c boolean?) module-or-top-identifier=? - [(_ any/c ... any) - (with-syntax ([n (- (length (syntax->list stx)) 2)]) - (build-optres - #:exp - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (blame (opt/info-blame opt/info))) - (syntax (if (and (procedure? val) - (procedure-arity-includes? val n)) - val - (raise-flat-arrow-err blame val n)))) - #:lifts null - #:superlifts null - #:partials null - #:flat #'(and (procedure? val) (procedure-arity-includes? val n)) - #:opt #f - #:stronger-ribs null - #:chaperone #t - #:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))] [(_ any/c boolean?) (predicate/c-optres opt/info #f)] [(_ dom ... (values rng ...))