From 02b0a30988def128ce016fe6c3f7ab1043d499be Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 21 Nov 2016 08:55:50 -0700
Subject: [PATCH] improve ellipsis-count checking wrapper

For a template expression that involevs ellipses, a wrapper is added
to catch failures an report as an "incompatible ellipsis match count"
error. The wrapper was only added when there are multiple pattern
variables with ellipses, but it turns out that it's possible to fail
with incompatible counts using a single pattern variable.

Besides handlign that case, the revised check avoids an unnecessary
wrapper in cases where multiple pattern variables have ellipses but
they are used independently in a template.

Closes #1511
---
 pkgs/racket-test-core/tests/racket/macro.rktl |  9 ++
 racket/collects/racket/private/sc.rkt         | 84 ++++++++++++++++---
 2 files changed, 80 insertions(+), 13 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl
index 226e5b7aa8..797ad251ba 100644
--- a/pkgs/racket-test-core/tests/racket/macro.rktl
+++ b/pkgs/racket-test-core/tests/racket/macro.rktl
@@ -1697,6 +1697,15 @@
                          (ax))])
     (test 'two values also-x)))
 
+;; ----------------------------------------
+;; Check that ellipsis-counts errors are reported when a single
+;; pattern variable is used at different depths
+
+(err/rt-test (syntax->datum
+              (with-syntax ([((b ...) ...) #'((1 2) (3) ())])
+                #'([(b (b ...)) ...] ...)))
+             (lambda (exn) (regexp-match? #rx"incompatible ellipsis" (exn-message exn))))
+
 ;; ----------------------------------------
 
 (report-errs)
diff --git a/racket/collects/racket/private/sc.rkt b/racket/collects/racket/private/sc.rkt
index ce8e282079..a082019c90 100644
--- a/racket/collects/racket/private/sc.rkt
+++ b/racket/collects/racket/private/sc.rkt
@@ -762,7 +762,7 @@
                                                          dest))])
                                          `(datum->syntax/shape (quote-syntax ,small-dest)
 							       ,build))))])
-                       (if (multiple-ellipsis-vars? proto-r)
+                       (if (multiple-ellipsis-vars? p proto-r)
                            `(catch-ellipsis-error
                              (lambda () ,main)
                              (quote ,p)
@@ -1067,18 +1067,76 @@
                            (loop (cdr nestings)))
                      (loop (cdr nestings))))))
 
-  (-define (multiple-ellipsis-vars? proto-r)
-           (let loop ([proto-r proto-r])
-             (cond
-              [(null? proto-r) #f]
-              [(pair? (car proto-r))
-               (let loop ([proto-r (cdr proto-r)])
-                 (cond
-                  [(null? proto-r) #f]
-                  [(pair? (car proto-r))
-                   #t]
-                  [else (loop (cdr proto-r))]))]
-              [else (loop (cdr proto-r))])))
+  ;; Determines whether any ellipsis has multiple pattern
+  ;; variables so that a run-time check on the pattern-variable
+  ;; matching length will be needed
+  (-define (multiple-ellipsis-vars? p proto-r)
+           (let loop ([p p])
+             (cond 
+              [(ellipsis? p)
+               (or (eq? 'multi (multiple-pattern-vars (stx-car p) proto-r))
+                   (loop (stx-cdr (stx-cdr p))))]
+              [(stx-pair? p) 
+               (let ([hd (stx-car p)])
+                 (if (and (identifier? hd)
+                          (...? hd))
+                     #f
+                     (or (loop hd)
+                         (loop (stx-cdr p)))))]
+              [(stx-vector? p #f)
+               (loop (vector->list (syntax-e p)))]
+              [(stx-box? p)
+               (loop (unbox (syntax-e p)))]
+              [(and (syntax? p)
+                    (prefab-struct-key (syntax-e p)))
+               (loop (cdr (vector->list (struct->vector (syntax-e p)))))]
+              [else #f])))
+
+  ;; Determines whether a given expression, which is under ellipses,
+  ;; has multiple pattern variables or the same variable at different
+  ;; depths; returns 'multi if so, some other internal accumulator otherwise
+  (-define (multiple-pattern-vars p proto-r)
+           (let loop ([p p] [use-ellipsis? #t] [depth 0] [found #f])
+             (cond 
+              [(identifier? p)
+               (if (ormap (lambda (l)
+                            (and
+                             (pair? l) ;; only need to track repeats
+                             (let loop ([l l])
+                               (cond
+                                [(syntax? l)
+                                 (bound-identifier=? l p)]
+                                [else (loop (car l))]))))
+                          proto-r)
+                   (cond
+                    [(not found) (cons p depth)]
+                    [(and (bound-identifier=? p (car found))
+                          (= depth (cdr found)))
+                     found]
+                    [else 'multi])
+                   found)]
+              [(and use-ellipsis? (ellipsis? p))
+               (let ([new-found (loop (stx-car p) #t (add1 depth) found)])
+                 (if (eq? new-found 'multi)
+                     new-found
+                     (loop (stx-cdr (stx-cdr p)) #t depth new-found)))]
+              [(stx-pair? p) 
+               (let ([hd (stx-car p)])
+                 (if (and (identifier? hd)
+                          (...? hd))
+                     (loop (stx-cdr p) #f depth found)
+                     (let ([new-found (loop (stx-car p) #t depth found)])
+                       (if (eq? new-found 'multi)
+                           new-found
+                           (loop (stx-cdr p) #t depth new-found)))))]
+              [(stx-vector? p #f)
+               (loop (vector->list (syntax-e p)) use-ellipsis? depth found)]
+              [(stx-box? p)
+               (loop (unbox (syntax-e p)) use-ellipsis? depth found)]
+              [(and (syntax? p)
+                    (prefab-struct-key (syntax-e p)))
+               (loop (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipsis? depth found)]
+              [else #f])))
 
   (-define (no-ellipses? stx)
            (cond