>From 17babaf2678ed1a5b2740add2052314d2b02469a Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sat, 25 May 2013 14:25:09 +0200
Subject: [PATCH 2/2] syntax-rules R7RS-compatibility: Implement underscore
 syntax in pattern, it matches any value, and creates no binding.  However, if
 it's part of the literals list, it will match. Also add some small cleanups:
 remove unused renamed aliases.

It's unclear whether underscore is allowed as an ellipsis identifier, so we'll just nail down the currently implemented behaviour, so as to avoid unintended breakage of code that will come to rely on it.  Same for mixing of custom ellipsis identifiers and literals.
---
 synrules.scm           | 27 ++++++++++---------
 tests/syntax-tests.scm | 70 +++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 82 insertions(+), 15 deletions(-)

diff --git a/synrules.scm b/synrules.scm
index 5ecfc3b..e3606f4 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -67,8 +67,6 @@
   (define %cdr '##sys#cdr)
   (define %length '##sys#length)
   (define %vector? '##sys#vector?)
-  (define %vector-length '##sys#vector-length)
-  (define %vector-ref '##sys#vector-ref)
   (define %vector->list '##sys#vector->list)
   (define %list->vector '##sys#list->vector)
   (define %>= '##sys#>=)
@@ -90,8 +88,6 @@
   (define %loop (r 'loop))
   (define %map1 '##sys#map)
   (define %map '##sys#map-n)
-  (define %null? '##sys#null?)
-  (define %or (r 'or))
   (define %pair? '##sys#pair?)
   (define %quote (r 'quote))
   (define %rename (r 'rename))
@@ -103,6 +99,10 @@
   (define (ellipsis? x)
     (c x %ellipsis))
 
+  ;; R7RS support: underscore matches anything
+  (define (underscore? x)
+    (c x (r '_)))
+
   (define (make-transformer rules)
     `(##sys#er-transformer
       (,%lambda (,%input ,%rename ,%compare)
@@ -125,7 +125,7 @@
 				       0
                                        ellipsis?
 				       (meta-variables pattern 0 ellipsis? '() #f)))))
-	(##sys#syntax-error-hook "ill-formed syntax rule" rule)))
+	(%syntax-error "ill-formed syntax rule" rule)))
 
   ;; Generate code to test whether input expression matches pattern
 
@@ -170,7 +170,7 @@
 
   (define (process-pattern pattern path mapit seen-segment? el?)
     (cond ((symbol? pattern)
-	   (if (memq pattern subkeywords)
+	   (if (or (memq pattern subkeywords) (underscore? pattern))
 	       '()
 	       (list (list pattern (mapit path)))))
 	  ((segment-pattern? pattern seen-segment? el?)
@@ -206,13 +206,12 @@
 	     (if probe
 		 (if (<= (cdr probe) dim)
 		     template
-		     (##sys#syntax-error-hook "template dimension error (too few ellipses?)"
-					      template))
+		     (%syntax-error "template dimension error (too few ellipses?)"
+                                    template))
 		 `(,%rename (##core#syntax ,template)))))
           ((ellipsis-escaped-pattern? template el?)
            (if (or (not (pair? (cdr template))) (pair? (cddr template)))
-               (##sys#syntax-error-hook
-                "Invalid escaped ellipsis template" template)
+               (%syntax-error "Invalid escaped ellipsis template" template)
                (process-template (cadr template) dim (lambda _ #f) env)))
 	  ((segment-template? template el?)
 	   (let* ((depth (segment-depth template el?))
@@ -220,7 +219,7 @@
 		  (vars
 		   (free-meta-variables (car template) seg-dim el? env '())))
 	     (if (null? vars)
-		 (##sys#syntax-error-hook "too many ellipses" template)
+		 (%syntax-error "too many ellipses" template)
 		 (let* ((x (process-template (car template) seg-dim el? env))
 			(gen (if (and (pair? vars)
 				      (null? (cdr vars))
@@ -250,7 +249,7 @@
 
   (define (meta-variables pattern dim el? vars seen-segment?)
     (cond ((symbol? pattern)
-	   (if (memq pattern subkeywords)
+	   (if (or (memq pattern subkeywords) (underscore? pattern))
 	       vars
 	       (cons (cons pattern dim) vars)))
 	  ((segment-pattern? pattern seen-segment? el?)
@@ -293,9 +292,9 @@
     (and (segment-template? p el?)
          (cond
           (seen-segment?
-           (##sys#syntax-error-hook "Only one segment per level is allowed" p))
+           (%syntax-error "Only one segment per level is allowed" p))
           ((not (list? p))              ; Improper list
-           (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p))
+           (%syntax-error "Cannot combine dotted tail and ellipsis" p))
           (else #t))))
 
   (define (segment-template? pattern el?)
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 6da0277..717be5d 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -319,6 +319,74 @@
 (t '(1)
    (foo #((1))))
 
+;;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
+;;; occurrances of <ellipsis> inside the template.
+
+(define-syntax be-like-begin
+  (syntax-rules ()
+    ((be-like-begin name)
+     (define-syntax name
+       (syntax-rules ()
+         ((name expr (... ...))
+          (begin expr (... ...))))))))
+(be-like-begin sequence)
+(t 4 (sequence 1 2 3 4))
+
+;;; R7RS: _ is ignored...
+
+(define (_) 1)
+(define-syntax ignore-underscores
+  (syntax-rules ()
+    ((_ _ _ _) (_))))
+
+(t 1 (ignore-underscores _ b c))
+
+;;; ... except if it's part of the literals list
+
+(define-syntax match-literal-underscores
+  (syntax-rules (_)
+    ((x a _ c) (_))
+    ((x _ b c) 2)))
+
+(f (eval '(match-literal-underscores d e f)))
+(t 1 (match-literal-underscores g _ i))
+(t 2 (match-literal-underscores _ h i))
+
+;;; Undefined what this should do.  Logically, it should be possible
+;;; to bind _ as an ellipsis identifier.
+
+(define-syntax match-ellipsis-underscores
+  (syntax-rules _ ()
+    ((x a _ c) (list a _ c))))
+
+(f (eval '(match-ellipsis-underscores)))
+(t '(1) (match-ellipsis-underscores 1))
+(t '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6))
+
+;;; Even more undefined behaviour: mixing literals and ellipsis identifiers
+;;; Currently, ellipsis identifiers have precedence over the other two.
+
+(define-syntax match-ellipsis-and-literals-underscores
+  (syntax-rules _ (_)
+    ((x a _ c) (list a _ c))))
+
+(f (eval '(match-ellipsis-and-literals-underscores)))
+(t '(1) (match-ellipsis-and-literals-underscores 1))
+(t '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
+(t '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6))
+
+;;; This is similar to the above, but maybe a little simpler because
+;;; it does not use reserved names:
+
+(define ___ 2)
+(define-syntax match-ellipsis-literals
+  (syntax-rules ___ (___)
+    ((_ x ___) (list x ___))))
+
+(t '(1) (match-ellipsis-literals 1))
+(t '(1 2) (match-ellipsis-literals 1 2))
+(t '(1 2) (match-ellipsis-literals 1 ___))
+
 ;;;
 
 (define-syntax usetmp
@@ -1078,4 +1146,4 @@ take
     (syntax-rules ()
       ((_) (begin (define req 2) (display req) (newline)))))
   (bar)
-  (assert (eq? req 1)))
\ No newline at end of file
+  (assert (eq? req 1)))
-- 
1.8.2.3