From: Andreas Rottmann
Subject: [PATCH] Add support for tail patterns to syntax-case and syntax-rules
---
module/ice-9/psyntax.scm | 120 +++++++++++++++++++++++++++++++---------
test-suite/tests/syncase.test | 43 ++++++++++++++-
2 files changed, 134 insertions(+), 29 deletions(-)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6fcc9b0..af0e5e6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2242,33 +2242,55 @@
; accepts pattern & keys
; returns $sc-dispatch pattern & ids
(lambda (pattern keys)
- (let cvt ((p pattern) (n 0) (ids '()))
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (fx+ n 1) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p) ids))))
- (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
+ (define cvt*
+ (lambda (p* n ids)
+ (if (null? p*)
+ (values '() 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))))))))
+ (define cvt
+ (lambda (p n ids)
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt (syntax x) (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x dots ys ...)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt* (syntax (ys ...)) n ids))
+ (lambda (ys ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) (+ n 1) ids))
+ (lambda (x ids)
+ (values `#(each+ ,x ,(reverse ys) ()) ids))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt (syntax y) n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt (syntax (x ...)) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p empty-wrap)) ids))))))
+ (cvt pattern 0 '())))
(define build-dispatch-call
(lambda (pvars exp y r mod)
@@ -2461,6 +2483,7 @@
;;; each-any (any*)
;;; #(free-id ) with free-identifier=?
;;; #(each ) (*)
+;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;;; #(vector ) (list->vector )
;;; #(atom