From f8b0e949d992ef5a56f957293f45a29c0140cfa0 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 10 May 2008 19:05:40 -0400
Subject: [PATCH] - syntax-case now raises a syntax violation when _ appears in
 the   literals - syntax-rules points to the invalid literal when raising an  
 exception.

---
 scheme/last-revision       |  2 +-
 scheme/psyntax.expander.ss | 22 +++++++++++++---------
 2 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index a84d4e6..24c937d 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1470
+1471
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 5ec91b7..9bb2c8a 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -1588,13 +1588,7 @@
         ((_ (lits ...)
             (pat* tmp*) ...)
          (begin
-           (unless (for-all
-                     (lambda (x)
-                       (and (id? x)
-                            (not (free-id=? x (scheme-stx '...)))
-                            (not (free-id=? x (scheme-stx '_)))))
-                     lits)
-             (stx-error e "invalid literals"))
+           (verify-literals lits e)
            (bless `(lambda (x)
                      (syntax-case x ,lits
                        ,@(map (lambda (pat tmp)
@@ -2295,6 +2289,17 @@
     (lambda (x)
       (and (id? x) (free-id=? x (scheme-stx '...)))))
 
+  (define underscore?
+    (lambda (x)
+      (and (id? x) (free-id=? x (scheme-stx '_)))))
+
+  (define (verify-literals lits expr)
+    (for-each
+      (lambda (x) 
+        (when (or (not (id? x)) (ellipsis? x) (underscore? x))
+          (syntax-violation #f "invalid literal" expr x)))
+      lits))
+
   (define syntax-case-transformer
     (let ()
       (define build-dispatch-call
@@ -2391,8 +2396,7 @@
         (syntax-match e ()
           ((_ expr (keys ...) clauses ...)
            (begin
-             (unless (for-all (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
-               (stx-error e "invalid literals"))
+             (verify-literals keys e)
              (let ((x (gen-lexical 'tmp)))
                (let ((body (gen-syntax-case x keys clauses r mr)))
                  (build-application no-source