[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-122-gaa8630e

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=aa8630efb37e71db56430d2090b0aaabbbaf2df3

The branch, stable-2.0 has been updated
       via  aa8630efb37e71db56430d2090b0aaabbbaf2df3 (commit)
      from  d8c476b68d2c8c1aee3cefd5226f091ce34c7c2a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit aa8630efb37e71db56430d2090b0aaabbbaf2df3
Author: Mark H Weaver <address@hidden>
Date:   Fri Dec 13 12:53:24 2013 -0500

    syntax-case: fix error reporting for misplaced ellipses.
    
    Reported by address@hidden (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.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/psyntax-pp.scm  |   25 ++++++++++--------
 module/ice-9/psyntax.scm     |   17 ++++++------
 test-suite/tests/syntax.test |   57 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 80 insertions(+), 19 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7b801ad..f5f764b 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 5f1bd8a..fa009d2 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 cdaee71..6fac0ba 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:


hooks/post-receive
-- 
GNU Guile