Merge pull request #602 from jpellegrini/syntax-rules-improper-list

`syntax-rules`: accept ellipsis with improper lists -- enhances pattern-matching (brings easy path to incorporate at least two SRFIs)
egallesio · Sep 4, 2023 · 1f6cad1 · 1f6cad1
2 parents 20ede59 + 27abbee
commit 1f6cad1
Show file tree

Hide file tree

Showing 2 changed files with 125 additions and 35 deletions.
diff --git a/lib/mbe.stk b/lib/mbe.stk
@@ -455,52 +455,112 @@ doc>
       (if (null? l) '()
           (append (f (car l)) (loop (cdr l)))))))
 
+
+;; split-improper-tail helps deal with improper lists when matching,
+;; and is used by both mbe:matches-pattern? and mbe:get-bindings.
+;; It will return two values:
+;;
+;; 1. The last CDR (either NIL if it's a proper list, or the improper tail)
+;; 2. The original list WITHOUT the impreper tail.
+;;
+;; Examples:
+;;
+;; (split-improper-tail '())        => values '(), '()
+;; (split-improper-tail '(1 2 3))   => values '(), '(1 2 3)
+;; (split-improper-tail '(1 2 . 3)) => values '(3), '(1 2)
+(define (split-improper-tail L)
+  (let Loop ((new '())
+             (old L))
+    (if (pair? old)
+        (Loop (cons (car old) new)
+              (cdr old))
+        (values old (reverse new)))))
+
 ;;; tests if expression e matches pattern p where k is the list of
-;;; keywords
+;;; keywords, and 'ellipsis' is the symbol used for the ellipsis.
 ;;
 ;; Examples:
 ;;
-;; (mbe:matches-pattern? '(f a b) '(* 3 4) '())      => #t
-;; (mbe:matches-pattern? '(f a x b) '(* 2 x 4) '(x)) => #t
-;; (mbe:matches-pattern? '(f a x b) '(* 2 3 4) '(x)) => #f
+;; (mbe:matches-pattern? '(f a b) '(* 3 4) '() '...)      => #t
+;; (mbe:matches-pattern? '(f a x b) '(* 2 x 4) '(x) '...) => #t
+;; (mbe:matches-pattern? '(f a x b) '(* 2 3 4) '(x) '...) => #f
 (define mbe:matches-pattern?
   (lambda (p e k ellipsis)
-    (cond ((mbe:ellipsis? p ellipsis)
-           (and (or (null? e) (pair? e))
-                (let* ((p-head (car p))
-                       (p-tail (cddr p))
-                       (e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
-                  (and e-head=e-tail
-		           (not (memq ellipsis p-tail)) ; fail on multiple ellipses
-                       (let ((e-head (car e-head=e-tail))
-                             (e-tail (cdr e-head=e-tail)))
-                         (and (every
-			               (lambda (x) (mbe:matches-pattern? p-head x k ellipsis))
-                               e-head)
-			              (mbe:matches-pattern? p-tail e-tail k ellipsis)))))))
-          ((pair? p)
-           (and (pair? e)
-		        (mbe:matches-pattern? (car p) (car e) k ellipsis)
-		        (mbe:matches-pattern? (cdr p) (cdr e) k ellipsis)))
-          ((symbol? p) (if (memq p k) (eq? p e) #t))
-          (else (equal? p e)))))
-
+      (cond ((mbe:ellipsis? p ellipsis)
+             ;; p+, e+ will be the last CDRs of p, e (the improper tail of '())
+             ;; then, p and e will be rebound to a similar list, WITHOUT that tail,
+             ;; if it existed (see split-improper-tail
+             (let-values (((p+ p) (split-improper-tail p))
+                          ((e+ e) (split-improper-tail e)))
+               (and (or (null? e) (pair? e))
+                    (let* ((p-head (car p))
+                           (p-tail (cddr p))
+                           (e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
+                      (and e-head=e-tail
+		                   (not (memq ellipsis p-tail))             ; fail on multiple ellipses
+                           (mbe:matches-pattern?  p+ e+ k ellipsis) ; if improper, match tails
+                           (let ((e-head (car e-head=e-tail))
+                                 (e-tail (cdr e-head=e-tail)))
+                             (and (every
+			                       (lambda (x) (mbe:matches-pattern? p-head x k ellipsis))
+                                   e-head)
+			                      (mbe:matches-pattern? p-tail e-tail k ellipsis))))))))
+            ((pair? p)
+             (and (pair? e)
+		          (mbe:matches-pattern? (car p) (car e) k ellipsis)
+		          (mbe:matches-pattern? (cdr p) (cdr e) k ellipsis)))
+            ((symbol? p) (if (memq p k) (eq? p e) #t))
+            (else (equal? p e)))))
 
 ;;; gets the bindings of pattern variables of pattern p for
-;;; expression e;
-;;; k is the list of keywords
+;;; expression e where k is the list of keywords, and 'ellipsis'
+;;; is the symbol used for the ellipsis.
+;;
+;; Examples:
+;;
+;; (mbe:get-bindings '(f a b) '(* 3 4) '() '...)
+;;   => ((f . *) (a . 3) (b . 4))
+;;
+;; (mbe:get-bindings'(f a x b) '(* 2 x 4) '(x) '...)
+;;   => ((f . *) (a . 2) (b . 4))
+;;
+;; (mbe:get-bindings '(f a x b) '(* 2 3 4) '(x) '...)
+;;   => ((f . *) (a . 2) (b . 4))
+;;
+;; (mbe:get-bindings '(f a . b) '(func 1 2 3) '() '...)
+;;   =>((f . func) (a . 1) (b 2 3))
+;;
+;; (mbe:get-bindings '(f a ...) '(func 1 2) '() '...) ; see how lists are dealt with!
+;;   => ((f . func) ((a) ((a . 1)) ((a . 2))))
+;;
+;; (mbe:get-bindings '(f a ...) '(func 1 2) '() ':::) ; alternative ellipsis
+;;   => ((f . func) (a . 1) (... . 2))
+;;
+;; (mbe:get-bindings '(f a :::) '(func 1 2) '() ':::)  ; alternative ellipsis
+;;   => ((f . func) ((a) ((a . 1)) ((a . 2))))
+;;
+;; (mbe:get-bindings '(f a b ... c) '(func 1 2 3 4 5 6) '() '...)
+;;   => ((f . func) (a . 1) ((b) ((b . 2)) ((b . 3)) ((b . 4)) ((b . 5))) (c . 6))
 (define mbe:get-bindings
   (lambda (p e k ellipsis)
     (cond ((mbe:ellipsis? p ellipsis)
-           (let* ((p-head (car p))
-                  (p-tail (cddr p))
-                  (e-head=e-tail (mbe:split-at-ellipsis e p-tail))
-                  (e-head (car e-head=e-tail))
-                  (e-tail (cdr e-head=e-tail)))
-	         (cons (cons (mbe:get-ellipsis-nestings p-head k ellipsis)
-		                 (map (lambda (x) (mbe:get-bindings p-head x k ellipsis))
-                          e-head))
-	               (mbe:get-bindings p-tail e-tail k ellipsis))))
+           ;; p+, e+ will be the last CDRs of p, e (the improper tail of '())
+           ;; then, p and e will be rebound to a similar list, WITHOUT that tail,
+           ;; if it existed (see split-improper-tail
+           (let-values (((p+ p) (split-improper-tail p))
+                        ((e+ e) (split-improper-tail e)))
+             (let* ((p-head (car p))
+                    (p-tail (cddr p))
+                    (e-head=e-tail (mbe:split-at-ellipsis e p-tail))
+                    (e-head (car e-head=e-tail))
+                    (e-tail (cdr e-head=e-tail)))
+	           (let ((res (cons (cons (mbe:get-ellipsis-nestings p-head k ellipsis)
+		                              (map (lambda (x) (mbe:get-bindings p-head x k ellipsis))
+                                           e-head))
+	                            (mbe:get-bindings p-tail e-tail k ellipsis))))
+                 (if (null? p+)
+                     res
+                     (append (mbe:get-bindings p+ e+ k ellipsis) res))))))
           ((pair? p)
 	       (append (mbe:get-bindings (car p) (car e) k ellipsis)
 	               (mbe:get-bindings (cdr p) (cdr e) k ellipsis)))

diff --git a/tests/test-macros.stk b/tests/test-macros.stk
@@ -243,6 +243,36 @@
         '(3 1)
         (begin (swap! b temp) (list b temp))))
 
+
+(define-syntax g
+  (syntax-rules ()
+    ((g (a b ... c . d))
+     (begin (display (vector b ...))
+            (display a)
+            (display c)
+            (display d)))))
+
+(test "ellipsis in improper list.1"
+      "#(2 3 4 5)16()"
+      (with-output-to-string
+        (lambda ()
+          (g (1 2 3 4 5 6)))))
+
+(define-syntax g
+  (syntax-rules ^^^ ()
+    ((g (a b ^^^ c . d))
+     (begin (display (vector b ^^^))
+            (display a)
+            (display c)
+            (display d)))))
+
+(test "ellipsis in improper list.2"
+      "#(2 3 4 5)...6()"
+      (with-output-to-string
+        (lambda ()
+          (g ((quote ...) 2 3 4 5 6)))))
+
+
 ;;FIXME: Add more tests !!!!!!!!!