Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-10 14:37:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding ..1' patterns to match (analog of regex +' patterns)

Browse source
This commit is contained in:
Alex Shinn 2010-09-26 13:56:30 +09:00
parent 67af0bb675
commit 09a5565418
2 changed files with 26 additions and 3 deletions
lib/chibi/match
match.scm
tests
match-tests.scm

12
lib/chibi/match/match.scm
View file

@ -28,6 +28,7 @@
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Court<72>«²s)
;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
@ -126,7 +127,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)
@ -162,6 +163,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 ($ rec p ...) g+s sk fk i)
(if (is-a? v rec)
(match-record-refs v rec 0 (p ...) g+s sk fk i)
@ -503,7 +508,7 @@
;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
(define-syntax match-extract-vars
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
(syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
((match-extract-vars (? pred . p) . x)
(match-extract-vars p . x))
((match-extract-vars ($ rec . p) . x)
@ -534,6 +539,7 @@
((match-extract-vars _ (k ...) i v) (k ... v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars *** (k ...) i v) (k ... v))
((match-extract-vars ..1 (k ...) i v) (k ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars p (k ...) (i ...) v)
@ -541,7 +547,7 @@
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
((new-sym? any sk fk) fk))))
(new-sym? random-sym-to-match
(k ... ((p p-ls) . v))
(k ... v))))

17
tests/match-tests.scm
View file

@ -141,4 +141,21 @@
(test "joined tail" '(1 2)
(match '(1 2 3) ((and (a ... b) x) a)))
(test "list ..1" '(a b c)
(match '(a b c) ((x ..1) x)))
(test "list ..1 failed" #f
(match '()
((x ..1) x)
(else #f)))
(test "list ..1 with predicate" '(a b c)
(match '(a b c)
(((and x (? symbol?)) ..1) x)))
(test "list ..1 with failed predicate" #f
(match '(a b 3)
(((and x (? symbol?)) ..1) x)
(else #f)))
(test-end)