diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt index ca8c2f6065..d3d6ef1afa 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -295,8 +295,24 @@ (test/pos-blame 'contract-arrow-non-function + '(contract (-> integer? any) 1 'pos 'neg)) + + (test/pos-blame + 'contract-any/c-arrow1 '(contract (-> any/c any) 1 'pos 'neg)) + (test/spec-passed + 'contract-any/c-arrow2 + '(contract (-> any/c any) (λ (x) 1) 'pos 'neg)) + + (test/pos-blame + 'contract-any/c-arrow3 + '(contract (-> any/c any) (λ (x y) x) 'pos 'neg)) + + (test/pos-blame + 'contract-any/c-arrow4 + '(contract (-> any/c any) (λ (x #:y y) x) 'pos 'neg)) + (test/spec-passed 'contract-arrow-all-kwds2 '((contract (-> #:a string? void?) diff --git a/racket/lib/collects/racket/contract/private/arrow.rkt b/racket/lib/collects/racket/contract/private/arrow.rkt index 90f61b756a..e23eb9dd37 100644 --- a/racket/lib/collects/racket/contract/private/arrow.rkt +++ b/racket/lib/collects/racket/contract/private/arrow.rkt @@ -2097,9 +2097,10 @@ [(_ any/c ... any) (not (syntax-parameter-value #'making-a-method)) ;; special case the (-> any/c ... any) contracts to be first-order checks only - (with-syntax ([dom-len (- (length (syntax->list stx)) 2)] - [name (syntax->datum stx)]) - #'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))] + (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))))] [(_ any/c boolean?) ;; special case (-> any/c boolean?) to use predicate/c (not (syntax-parameter-value #'making-a-method)) @@ -2107,6 +2108,12 @@ [_ #`(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)))) + ;; this is to make the expanded versions a little easier to read (define-syntax (values/drop stx) (syntax-case stx ()