syntax-case: fix error reporting for misplaced ellipses.

Reported by taylanbayirli@gmail.com (Taylan Ulrich B.).

* module/ice-9/psyntax.scm (cvt*): Use 'syntax-case' to destructure
  the pattern tail, instead of 'pair?', 'car', and 'cdr'.
  (gen-clause): When checking for errors, check for misplaced ellipsis
  before duplicate pattern variables, to improve the error message in
  case of multiple misplaced ellipses.

* module/ice-9/psyntax-pp.scm: Regenerate.

* test-suite/tests/syntax.test: Add tests.

3 files changed, 80 insertions, 19 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7b801ad24..f5f764b0f 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2072,14 +2072,17 @@
          (lambda (pattern keys)
            (letrec*
              ((cvt* (lambda (p* n ids)
-                      (if (not (pair? p*))
-                        (cvt p* n ids)
-                        (call-with-values
-                          (lambda () (cvt* (cdr p*) n ids))
-                          (lambda (y ids)
-                            (call-with-values
-                              (lambda () (cvt (car p*) n ids))
-                              (lambda (x ids) (values (cons x y) ids))))))))
+                      (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
+                        (if tmp
+                          (apply (lambda (x y)
+                                   (call-with-values
+                                     (lambda () (cvt* y n ids))
+                                     (lambda (y ids)
+                                       (call-with-values
+                                         (lambda () (cvt x n ids))
+                                         (lambda (x ids) (values (cons x y) ids))))))
+                                 tmp)
+                          (cvt p* n ids)))))
               (v-reverse
                 (lambda (x)
                   (let loop ((r '()) (x x))
@@ -2162,10 +2165,10 @@
            (call-with-values
              (lambda () (convert-pattern pat keys))
              (lambda (p pvars)
-               (cond ((not (distinct-bound-ids? (map car pvars)))
-                      (syntax-violation 'syntax-case "duplicate pattern variable" pat))
-                     ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+               (cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
                       (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+                     ((not (distinct-bound-ids? (map car pvars)))
+                      (syntax-violation 'syntax-case "duplicate pattern variable" pat))
                      (else
                       (let ((y (gen-var 'tmp)))
                         (build-application
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 5f1bd8ae4..fa009d2d5 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2341,15 +2341,16 @@
                        (lambda (pattern keys)
                          (define cvt*
                            (lambda (p* n ids)
-                             (if (not (pair? p*)) 
-                                 (cvt p* n ids)
-                                 (call-with-values
-                                     (lambda () (cvt* (cdr p*) n ids))
+                             (syntax-case p* ()
+                               ((x . y)
+                                (call-with-values
+                                     (lambda () (cvt* #'y n ids))
                                    (lambda (y ids)
                                      (call-with-values
-                                         (lambda () (cvt (car p*) n ids))
+                                         (lambda () (cvt #'x n ids))
                                        (lambda (x ids)
-                                         (values (cons x y) ids))))))))
+                                         (values (cons x y) ids))))))
+                               (_ (cvt p* n ids)))))
                          
                          (define (v-reverse x)
                            (let loop ((r '()) (x x))
@@ -2429,10 +2430,10 @@
                              (lambda () (convert-pattern pat keys))
                            (lambda (p pvars)
                              (cond
-                              ((not (distinct-bound-ids? (map car pvars)))
-                               (syntax-violation 'syntax-case "duplicate pattern variable" pat))
                               ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
                                (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+                              ((not (distinct-bound-ids? (map car pvars)))
+                               (syntax-violation 'syntax-case "duplicate pattern variable" pat))
                               (else
                                (let ((y (gen-var 'tmp)))
                                  ;; fat finger binding and references to temp variable y
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index cdaee716b..6fac0ba34 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1171,3 +1171,60 @@
 		    (unreachable))))))
 	(r 'outer))
       #t)))
+
+(with-test-prefix "syntax-case"
+  
+  (pass-if-syntax-error "duplicate pattern variable"
+    '(syntax-case . "duplicate pattern variable")
+    (eval '(lambda (e)
+             (syntax-case e ()
+               ((a b c d e d f) #f)))
+          (interaction-environment)))
+
+  (with-test-prefix "misplaced ellipses"
+
+    (pass-if-syntax-error "bare ellipsis"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 (... #f)))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "ellipsis singleton"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 ((...) #f)))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "ellipsis in car"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 ((... . _) #f)))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "ellipsis in cdr"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 ((_ . ...) #f)))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "two ellipses in the same list"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 ((x ... y ...) #f)))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "three ellipses in the same list"
+      '(syntax-case . "misplaced ellipsis")
+      (eval '(lambda (e)
+               (syntax-case e ()
+                 ((x ... y ... z ...) #f)))
+            (interaction-environment)))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
+;;; End: