Implement ellipsis escaping, as per R7RS

In Section 4.3.2 of R7RS (page 23 of the PDF), it is said that a <template> can be one of: 1. (<element> ...) 2. (<element> <element> ... . <template>) 3. (<ellipsis> <template>) 4. #(<element> ...) Number (3) is an escaping pattern. Inside ir, ellipses are treated like a symbol, and not like the syntax-rules ellipsis. And that template *must* have only two elements. (<ellipsis> <template>) should be transformed into <template> but protecting the ellipses (they have no special meaning there). So (... a) => a (... (a b ... c) => (a b ... c) (... ...) => ... (... a b) => error (too many elements) but the ellipses on the right side are ignored by syntax-rules. The implementation is: 1. In MBE, include a check for malformed escapes (as in the last case above, (... a b)) 2. In MBE: (mbe:subst-ellipsis expr ell new-ell) will go through expr, and substitute *only* the sublists that match the form of an escaping ellipsis, doing the appropriate transform. However, inside the subtemplate, the ellipses will be transformed into a symbol which is internal to MBE, produced by gensym (so no match will be possible). This is in find-clause 3. in MBE, "replace" can be used to get the original ellipses back. This is also in find-clause 4. In runtime-macros, syntax-rules calls the internal MBE procedure check-wrong-ellipsis-escape 5. In MBE, let-syntax also does that. Some tests, including the example in R7RS, were added.
egallesio · Jan 29, 2025 · 6c085cd · 6c085cd
1 parent 4fef53c
commit 6c085cd
Show file tree

Hide file tree

Showing 3 changed files with 205 additions and 10 deletions.
diff --git a/lib/mbe.stk b/lib/mbe.stk
@@ -168,6 +168,8 @@ doc>
 (define mbe:ellipsis-sub-envs           #f)
 (define mbe:contained-in?               #f)
 
+(define ellipsis-marker (gensym "ELLIPSIS-"))
+
 ;=============================================================================
 
 ;; reverse assq:
@@ -645,6 +647,85 @@ doc>
     (and (pair? x) (pair? (cdr x)) (eq? (cadr x) ellipsis))))
 
 
+;;; tests if x is an ellipsis escape pattern, i.e., of the form
+;;; (... <template>)
+;;;
+;;; (mbe:ellipsis-escape? 'a '...)         => #f
+;;; (mbe:ellipsis-escape? '(a b) '...)     => #f
+;;; (mbe:ellipsis-escape? '(... b) '...)   => #t
+;;; (mbe:ellipsis-escape? '(... ...) '...) => #t
+;;; (mbe:ellipsis-escape? '(... b c) '...) => error
+(define mbe:ellipsis-escape?
+  (lambda (expr ell)
+    (and (pair? expr)
+         (eq? ell (car expr))
+         (pair? (cdr expr)))))
+
+
+;; Simple substitituon x -> y in a nested list.
+;;
+;; (replace
+;;  '(a b (c d e) (f (d e) g) h e)
+;;  'e
+;;  'EH) => (a b (c d EH) (f (d EH) g) h EH)
+;;
+;; The test used is eq? so no substitution is done
+;; in the following case, for example:
+;;
+;; (replace
+;;  '(a b (c d (e e e)) (f (d e) g) h (e e e))
+;;  '(e e e)
+;;  'EH) => '(a b (c d (e e e)) (f (d e) g) h (e e e))
+;;
+(define (replace lst x y)
+  (cond ((eq? lst x) y)
+        ((pair? lst)
+         (cons (replace (car lst) x y)
+               (replace (cdr lst) x y)))
+        (else lst)))
+
+;; mbe:subst-ellipsis will replace the ellipsis symbol inside
+;; a template that is marked as an "ellipsis escape":
+;;
+;; (mbe:subst-ellipsis
+;;  '(... x)
+;;  '... 'ELL)         => 'x
+;;
+;; (mbe:subst-ellipsis
+;;  '(... ...)
+;;  '... 'ELL)         => 'ELL
+;;
+;; (mbe:subst-ellipsis
+;;  '(a (b ... x) c)
+;;  '... 'ELL)         => '(a (b ... x) c)
+;;
+;; (mbe:subst-ellipsis
+;;  '(a (... x) c)
+;;  '... 'ELL)         => '(a x c)
+;;
+;;  (mbe:subst-ellipsis
+;;  'a
+;;  '... 'ELL)          => 'a
+;;
+;; (mbe:subst-ellipsis
+;;  '(a (b (... (x y z)) c) d)
+;;  '... 'ELL)          => '(a (b (x y z) c) d)
+;;
+;; (mbe:subst-ellipsis
+;;  '(a (b (... (x (... u) y z)) c) d)
+;;  '... 'ELL)          => (a (b (x (ELL u) y z) c) d)
+;;
+;; (mbe:subst-ellipsis
+;;  '(a (b (... c d)))
+;;  '... 'ELL)          => error
+(define (mbe:subst-ellipsis lst ell new-ell)
+  (cond ((mbe:ellipsis-escape? lst ell)
+         (cadr (replace lst ell new-ell)))
+        ((pair? lst)
+         (map* (lambda (x) (mbe:subst-ellipsis x ell new-ell)) lst))
+        (else lst)))
+
+
 #|
 
                         Original DEFINE-SYNTAX
@@ -706,21 +787,70 @@ doc>
           (let ((in-pattern  (caar  l))
                 (out-pattern (cadar l)))
             (if (mbe:matches-pattern? in-pattern macro-form keywords ellipsis)
-                (let ((tmp (hyg:tag out-pattern
+                ;; We call mbe:subst-ellipsis on the out-pattern before anything else, so the
+                ;; escaped ellipsis patterns have their ellispses truned into the gensymed
+                ;; symbol "ellipsis-marker".
+                ;; Then, after doing the tag/untag/get-bindings, we call replace to put
+                ;; the ellipsis symbols back into their places.
+                (let ((tmp (hyg:tag (mbe:subst-ellipsis out-pattern ellipsis ellipsis-marker)
                                     (append! (hyg:flatten in-pattern) keywords)
                                     '()
                                     ellipsis)))
-                  (hyg:untag (mbe:expand-pattern (car tmp)
-                                                 (mbe:get-bindings in-pattern
-                                                                   macro-form
-                                                                   keywords
-                                                                   ellipsis)
-                                                 keywords
-                                                 ellipsis)
-                             (cdr tmp)
-                             '()))
+                  (replace (hyg:untag (mbe:expand-pattern (car tmp)
+                                                          (mbe:get-bindings in-pattern
+                                                                            macro-form
+                                                                            keywords
+                                                                            ellipsis)
+                                                          keywords
+                                                          ellipsis)
+                                      (cdr tmp)
+                                      '())
+                           ellipsis-marker ellipsis))
                 (Loop (cdr l))))))))
 
+;; This utility checks for ellipsis escaping patterns written wrongly, like
+;; (... a b)  --> the "b" cannot be there
+(define (check-wrong-ellipsis-escape-single expr ell)
+  (when (and (pair? expr)
+             (eq? ell (car expr))
+             (pair? (cdr expr)))
+    (unless (null? (cddr expr))
+      (error 'syntax-rules
+             "In (<ellipsis> <pattern>), <pattern> should be a single element: ~s" expr))))
+
+;; for-each, but goes into sublists. used by the ellipsis escaping chack in syntax-rules
+(define (deep-for-each f lst)
+  (f lst)
+  (cond
+   ((null? lst)
+    (void))
+   ((pair? lst)
+    (deep-for-each f (car lst))
+    (deep-for-each f (cdr lst))
+    (void))
+   (else (void))))
+
+;; Check for wrong ellipsis escaping patterns
+(define (check-wrong-ellipsis-escape clauses ell)
+  ;; clauses is like
+  ;;
+  ;; (((arg1 arg2 ...)
+  ;;   template))
+  ;;
+  ;; then each clause is
+  ;;
+  ;; ((arg1 arg2 ...)
+  ;;   template)
+  ;;
+  ;; so we do for-each in the clauses list, and in each one we run
+  ;; deep-for-each on (cadr clause)
+  (for-each
+   (lambda (clause)
+     (deep-for-each
+      (lambda (x)
+        (check-wrong-ellipsis-escape-single x ell))
+      (cadr clause)))
+   clauses))
 
 ;;
 ;; A very simple implementation of let-syntax.
@@ -756,6 +886,7 @@ doc>
                       (clauses  (if alt-ellipsis?
                                     (cdddr syn-rules)
                                     (cddr syn-rules))))
+                  (check-wrong-ellipsis-escape clauses ellipsis)
                   `(,macro-name (lambda args
                                   ((%%symbol-value 'find-clause 'MBE)
                                            ',macro-name
@@ -766,6 +897,8 @@ doc>
           bindings)
     ,@body))
 
+
+
 ;; NOTE:
 ;;    define-syntax is defined in the file lib/runtime-macros.stk
 ;;

diff --git a/lib/runtime-macros.stk b/lib/runtime-macros.stk
@@ -100,6 +100,10 @@
 
         (let ((keywords    (cons macro-name (cadr syn-rules)))
               (clauses     (cddr syn-rules)))
+
+          ;; Should we export this symbol from MBE? It will only be used here.
+          ((in-module MBE check-wrong-ellipsis-escape) clauses ellipsis)
+
           `(define-macro (,macro-name . args)
              ((%%symbol-value 'find-clause 'MBE) ',macro-name
                                                  args

diff --git a/tests/test-macros.stk b/tests/test-macros.stk
@@ -273,6 +273,64 @@
           (g ((quote ...) 2 3 4 5 6)))))
 
 
+;;; ellipsis escaping (example in R7RS)
+(define-syntax be-like-begin
+  (syntax-rules ()
+    ((be-like-begin name)
+      (define-syntax name
+        (syntax-rules ()
+          ((name expr (... ...))
+            (begin expr (... ...))))))))
+
+(be-like-begin sequence)
+
+(test "ellipsis escaping (example in R7RS)"
+      4
+      (sequence 1 2 3 4))
+
+(let-syntax ((with-alternate-begin
+              (syntax-rules ()
+                ((_ name body ...)
+                 (let-syntax ((name
+                               (syntax-rules ()
+                                 ((name expr (... ...))
+                                  (begin expr (... ...))))))
+                   body ...)))))
+  (with-alternate-begin sequence
+                        (test "ellipsis escaping (example in R7RS), adapted"
+                              30
+                              (sequence 10 20 30))))
+
+
+
+(define-syntax test-macro:nested-ellipsis-escape
+  (syntax-rules ()
+    ((_ a b c d e)
+     (a (b (... (c d e ...)) c)))))
+
+(test "ellipsis escaping (nested)"
+      '(1 (2 (3 4 5 ...) 3))
+      (macro-expand '(test-macro:nested-ellipsis-escape 1 2 3 4 5)))
+
+(let-syntax ((test-macro:nested-ellipsis-escape
+              (syntax-rules ()
+                ((_ a b c d e)
+                 (a (b (... (c d e ...)) c))))))
+  (test "ellipsis escaping (nested) - let-syntax"
+        '(1 (2 (3 4 5 ...) 3))
+        (macro-expand '(test-macro:nested-ellipsis-escape 1 2 3 4 5))))
+
+(test/compile-error "ellipsis escape with too many elements in template.1"
+                    (define-syntax %f
+                      (syntax-rules ()
+                        ((%f) (... 1 2))))) ;; wrong, will signal an error!
+
+(test/compile-error "ellipsis escape with too many elements in template.2"
+                    (let-syntax ((%f (syntax-rules ()
+                                       ((%f) (... 1 2)))))
+                      (%f)))
+
+
 ;;FIXME: Add more tests !!!!!!!!!