Hi Alex, Alex Shinn <alexsh...@gmail.com> writes:
> On Mon, Sep 6, 2010 at 9:12 PM, Ludovic Courtès <l...@gnu.org> wrote: [...] >> I do! :-) >> >> http://git.sv.gnu.org/cgit/guile-rpc.git/tree/modules/rpc/compiler.scm#n312 >> >> Well it uses only ‘..1’. The same code would work with ‘..1’ replaced >> by ‘...’, but then errors in the input wouldn’t be detected as nicely. > > "..1" is actually useful The attached patch adds support for ‘..1’. I’ll apply it to Guile if you’re OK with applying it upstream. What do you think? BTW, I had fearfully avoided to hack a pattern matcher until now and I was pleased to see how tractable this code is! Thanks, Ludo’.
pgphOhYGSBGp2.pgp
Description: PGP signature
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 963b89f..bf3335b 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -125,7 +125,7 @@
;; pattern so far.
(define-syntax match-two
- (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
+ (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
((match-two v () g+s (sk ...) fk i)
(if (null? v) (sk ... i) fk))
((match-two v (quote p) g+s (sk ...) fk i)
@@ -161,6 +161,10 @@
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
((match-two v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
+ ((match-two v (p ..1) g+s sk fk i)
+ (if (pair? v)
+ (match-one v (p ___) g+s sk fk i)
+ fk))
((match-two v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 70a15ec..d1432d8 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -67,6 +67,16 @@
((x . rest)
(and (eq? x 'a) (equal? rest '(b c)))))))
+ (pass-if "list ..1"
+ (match '(a b c)
+ ((x ..1)
+ (equal? x '(a b c)))))
+
+ (pass-if "list ..1, with predicate"
+ (match '(a b c)
+ (((and x (? symbol?)) ..1)
+ (equal? x '(a b c)))))
+
(pass-if "tree"
(let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
(match tree
@@ -79,4 +89,15 @@
(pass-if-exception "tree"
exception:match-error
(match '(a (b c))
- ((foo (bar)) #t))))
+ ((foo (bar)) #t)))
+
+ (pass-if-exception "list ..1"
+ exception:match-error
+ (match '()
+ ((x ..1) #f)))
+
+ (pass-if-exception "list ..1, with predicate"
+ exception:match-error
+ (match '(a 0)
+ (((and x (? symbol?)) ..1)
+ (equal? x '(a b c))))))
