From 011f47540dde2555258c1089c940f41471c010c0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 9 Apr 2013 21:23:41 -0500
Subject: [PATCH] fix opt/c for -> contracts when the function accepts keyword
 arguments

---
 collects/racket/contract/private/opters.rkt | 44 ++++++++++++++-------
 collects/tests/racket/contract-test.rktl    |  8 ++++
 2 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt
index 5da77f7357..b0b1264cca 100644
--- a/collects/racket/contract/private/opters.rkt
+++ b/collects/racket/contract/private/opters.rkt
@@ -486,21 +486,27 @@
                      (dom-len (length dom-vars))
                      (rng-len (length rng-vars))
                      ((next-rng ...) next-rngs))
-         (syntax (begin
-                   (check-procedure val #f dom-len 0 '() '() #| keywords |# blame)
-                   (chaperone-procedure
-                    val
-                    (case-lambda
-                      [(dom-arg ...)
-                       (values 
-                        (case-lambda
-                          [(rng-arg ...)
-                           (values next-rng ...)]
-                          [args 
-                           (bad-number-of-results blame val rng-len args)])
-                        next-dom ...)]
-                      [args
-                       (bad-number-of-arguments blame val args dom-len)])))))
+         (define (values/maybe-one stx)
+           (syntax-case stx ()
+             [(x) #'x]
+             [(x ...) #'(values x ...)]))
+         #`(let ([exact-proc (case-lambda
+                               [(dom-arg ...)
+                                (values
+                                 (case-lambda
+                                   [(rng-arg ...)
+                                    #,(values/maybe-one #'(next-rng ...))]
+                                   [args 
+                                    (bad-number-of-results blame val rng-len args)])
+                                 next-dom ...)]
+                               [args
+                                (bad-number-of-arguments blame val args dom-len)])])
+             (if (and (procedure? val)
+                      (equal? dom-len (procedure-arity val))
+                      (let-values ([(a b) (procedure-keywords val)])
+                        (null? b)))
+                 (chaperone-procedure val exact-proc)
+                 (handle-non-exact-procedure val dom-len blame exact-proc))))
        (append lifts-doms lifts-rngs)
        (append superlifts-doms superlifts-rngs)
        (append partials-doms partials-rngs)
@@ -622,6 +628,14 @@
                              #:name name)
                (opt/unknown opt/i opt/info stx))))]))
 
+(define (handle-non-exact-procedure val dom-len blame exact-proc)
+  (check-procedure val #f dom-len 0 '() '() blame)
+  (chaperone-procedure
+   val
+   (make-keyword-procedure
+    (λ (kwds kwd-args . regular-args) (raise-blame-error '...))
+    exact-proc)))
+
 (define (raise-flat-arrow-err blame val n)
   (raise-blame-error blame val
                      '(expected "a procedure matching the contract ~s")
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index eeb27b9141..bfe828b17f 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -1112,6 +1112,14 @@
                'pos
                'neg)
      1 #:y #t))
+  
+  (test/spec-passed
+   'contract-arrow-keyword16
+   '((contract (-> integer? integer?)
+               (λ (x #:y [y #f]) x)
+               'pos
+               'neg)
+     1))
 
   (test/spec-passed
    'contract-arrow1