From 24c5a9aed8268de7caad56ec1ba44ec7bc708dfc Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 25 May 2010 12:59:46 -0400
Subject: [PATCH] Fix for optional keyword contracts used on
 make-keyword-procedure results.

This fix should go into the 5.0 release.
---
 collects/racket/contract/private/arrow.rkt | 15 ++++++++-------
 collects/tests/racket/contract-test.rktl   | 17 +++++++++++++++++
 2 files changed, 25 insertions(+), 7 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 7087818bc6..7d785df945 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -172,10 +172,7 @@ v4 todo:
                 (if (->-dom-rest/c ctc)
                   (procedure-accepts-and-more? x l)
                   (procedure-arity-includes? x l))
-                (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
-                  (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
-                       (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
-                               (->-mandatory-kwds ctc))))
+                (keywords-match (->-mandatory-kwds ctc) (->-optional-kwds ctc) x)
                 #t))))
    #:stronger
    (λ (this that)
@@ -1541,9 +1538,13 @@ v4 todo:
          (andmap (λ (kwd) (member kwd mandatory-kwds))
                  proc-mandatory)
          ;; proc accepts (but does not require) ctc's optional keywords
-         (andmap (λ (kwd) (and (member kwd proc-all)
-                               (not (member kwd proc-mandatory))))
-                 optional-kwds))))
+         ;;
+         ;; if proc-all is #f, then proc accepts all keywords and thus
+         ;; this is triviably true (e.g. result of make-keyword-procedure)
+         (or (not proc-all)
+             (andmap (λ (kwd) (and (member kwd proc-all)
+                                   (not (member kwd proc-mandatory))))
+                     optional-kwds)))))
 
 (define (keyword-error-text mandatory-keywords optional-keywords)
   (define (format-keywords-error type kwds)
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index b0274c70b4..2952aa7a47 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -687,6 +687,23 @@
                (λ () (values 1 2))
                'pos 'neg)))
   
+  (test/spec-passed
+   'contract-arrow-star-optional24
+   '(let ()
+      (define (statement? s)
+        (and (string? s)
+             (> (string-length s) 3)))
+      (define statement/c (flat-contract statement?))
+      
+      (define new-statement
+        (make-keyword-procedure
+         (λ (kws kw-args . statement)
+           (format "kws=~s  kw-args=~s  statement=~s" kws kw-args statement))))
+      
+      (contract (->* (statement/c) (#:s string?) statement/c)
+                new-statement
+                'pos 'neg)))
+  
   (test/spec-passed
    'contract-arrow-star-keyword-ordering
    '((contract (->* (integer? #:x boolean?) (string? #:y char?) any)