From 05ce59c54e3006908baea807426d272595fc7a46 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 16 Jul 2013 08:36:16 -0500
Subject: [PATCH] fix bug in ->

Specifically, in the case when the arrow is of the shape
(-> any/c ... any), then the predicate didn't ensure that
there were no mandatory keywords in the given function
---
 .../racket-test/tests/racket/contract/arrow.rkt  | 16 ++++++++++++++++
 .../collects/racket/contract/private/arrow.rkt   | 13 ++++++++++---
 2 files changed, 26 insertions(+), 3 deletions(-)

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 ()