From c442e9707f8ac023723edc6e00a560978fc0c934 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 20 Mar 2018 07:47:38 -0500
Subject: [PATCH] fix bugs with error checking for ->* and ->

closes 1997
---
 .../tests/racket/contract/arrow.rkt           | 11 ++++++++
 .../racket/contract/private/arr-util.rkt      | 27 ++++++++++---------
 .../contract/private/arrow-val-first.rkt      |  9 +++++++
 3 files changed, 35 insertions(+), 12 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt
index bb9b7c0d7f..1cb3df514a 100644
--- a/pkgs/racket-test/tests/racket/contract/arrow.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt
@@ -683,4 +683,15 @@
      (regexp-match? "a procedure that accepts the #:x keyword argument"
                     (exn-message e))))
 
+  (contract-syntax-error-test
+   '->-duplicate-keywords.1
+   #'(->* [] [#:a any/c #:a any/c] void?))
+  (contract-syntax-error-test
+   '->-duplicate-keywords.2
+   #'(->* [#:a any/c #:a any/c] [] void?))
+  (contract-error-test
+   '->-duplicate-keywords.3
+   #'(eval '(->* [#:a any/c] [#:a any/c] void?))
+   (λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"->[*]: duplicate keyword" (exn-message x)))))
+
   )
diff --git a/racket/collects/racket/contract/private/arr-util.rkt b/racket/collects/racket/contract/private/arr-util.rkt
index 6c77d61d5b..a476f19c61 100644
--- a/racket/collects/racket/contract/private/arr-util.rkt
+++ b/racket/collects/racket/contract/private/arr-util.rkt
@@ -94,17 +94,20 @@
     (cond
       [(null? lst) (list x)]
       [else
-       (let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
-             [x-kwd (syntax-e (car (syntax-e x)))])
-         (cond
-           [(equal? x-kwd fst-kwd)
-            (raise-syntax-error #f 
-                                "duplicate keyword"
-                                stx
-                                (car x))]
-           [(keyword<? x-kwd fst-kwd)
-            (cons x lst)]
-           [else (cons (car lst) (insert x (cdr lst)))]))]))
+       (define fst-kwd-stx (car (syntax-e (car lst))))
+       (define fst-kwd (syntax-e fst-kwd-stx))
+       (define x-kwd-stx (car (syntax-e x)))
+       (define x-kwd (syntax-e x-kwd-stx))
+       (cond
+         [(equal? x-kwd fst-kwd)
+          (raise-syntax-error #f
+                              "duplicate keyword"
+                              stx
+                              x-kwd-stx
+                              (list fst-kwd-stx))]
+         [(keyword<? x-kwd fst-kwd)
+          (cons x lst)]
+         [else (cons (car lst) (insert x (cdr lst)))])]))
   
   (let loop ([pairs kwd/ctc-pairs])
     (cond
@@ -120,4 +123,4 @@
                                 (+ min-arg-length num-of-opts 1))
                         opt+man-dom-lengths)
                     man-kwds
-                    opt-kwds))
\ No newline at end of file
+                    opt-kwds))
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index 59f78dc23d..37a05de5f7 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -588,6 +588,13 @@
          (sort (map cons kwds kwd-args)
                keyword<?
                #:key (compose syntax-e car)))
+       (when (pair? sorted)
+         (for ([pr1 (in-list sorted)]
+               [pr2 (in-list (cdr sorted))])
+           (when (equal? (syntax-e (car pr1)) (syntax-e (car pr2)))
+             (raise-syntax-error #f "duplicate keyword" stx
+                                 (car pr1)
+                                 (list (car pr2))))))
        (values (reverse regular-args)
                (map car sorted)
                (map cdr sorted)
@@ -811,6 +818,8 @@
                        opt-dom-kwds
                        opt-lets)
                       (:split-doms stx '->* raw-optional-doms this->*)])
+         ;; call sort-keywords for the duplicate variable check
+         (sort-keywords stx (append (syntax->list #'man-dom-kwds) (syntax->list #'opt-dom-kwds)))
          (values
           #'man-dom
           #'man-dom-kwds