diff options
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 1 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 96 | ||||
| -rw-r--r-- | tests/011/patmatch.tl | 7 | ||||
| -rw-r--r-- | txr.1 | 58 |
4 files changed, 118 insertions, 44 deletions
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl index dfd6f178..b980e6b3 100644 --- a/share/txr/stdlib/doc-syms.tl +++ b/share/txr/stdlib/doc-syms.tl @@ -405,6 +405,7 @@ ("*args-full*" "N-03DEE18A") ("atom" "N-0076C7BE") ("lset" "N-008216EC") + ("end" "N-037C6608") ("clock-t" "N-03258244") ("ai-v4mapped" "N-020DFFDE") ("pprinl" "N-02FCCE0D") diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index c43f7722..3026ab0a 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -756,50 +756,58 @@ ,args ,*body))) ',name))) -(defmatch sme (:form f sta mid end : (mobj (gensym)) tobj) - (flet ((check (pat) - (if (or (not (listp pat)) - (meq (car pat) 'sys:expr 'sys:var)) - (compile-error f - "~s: list pattern expected, not ~s" - 'sme pat) - pat)) - (check-end (pat) - (if (and (listp pat) - (meq (car pat) 'sys:expr 'sys:var)) - (compile-error f - "~s: list or atom pattern expected, not ~s" - 'sme pat) - pat)) - (check-sym (sym : nil-ok) - (cond - ((bindable sym) sym) - ((and (null sym) nil-ok) sym) - (t (compile-error f "~s: bindable symbol expected, not ~s" - 'sme sym)))) - (loosen (pat) - (if (proper-list-p pat) - (append pat '@nil) - pat)) - (pat-len (pat) - (if (consp pat) - (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr) - (butlastn 0 pat)))) - (if var-op-pos var-op-pos (len pat))) - 0))) - (let* ((psta (loosen (check sta))) - (pmid (loosen (check mid))) - (pend (check-end end)) - (lsta (pat-len psta)) - (lmid (pat-len pmid)) - (lend (pat-len pend)) - (obj (gensym))) - ^@(as ,(check-sym obj) - @(and ,psta - @(with @(scan @(as ,(check-sym mobj) ,pmid)) - (nthcdr ,lsta ,obj)) - @(with @(as ,(check-sym tobj t) ,pend) - (nthlast ,lend (nthcdr ,lmid ,mobj)))))))) +(defun check (f op pat) + (if (or (not (listp pat)) + (meq (car pat) 'sys:expr 'sys:var)) + (compile-error f "~s: list pattern expected, not ~s" op pat) + pat)) + +(defun check-end (f op pat) + (if (and (listp pat) + (meq (car pat) 'sys:expr 'sys:var)) + (compile-error f "~s: list or atom pattern expected, not ~s" op pat) + pat)) + +(defun check-sym (f op sym : nil-ok) + (cond + ((bindable sym) sym) + ((and (null sym) nil-ok) sym) + (t (compile-error f "~s: bindable symbol expected, not ~s" op sym)))) + +(defun loosen (f pat) + (if (proper-list-p pat) + (append pat '@nil) + pat)) + +(defun pat-len (f pat) + (if (consp pat) + (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr) + (butlastn 0 pat)))) + (if var-op-pos var-op-pos (len pat))) + 0)) + +(defmatch sme (:form f sta mid end : (mvar (gensym)) eobj) + (let* ((psta (loosen f (check f 'sme sta))) + (pmid (loosen f (check f 'sme mid))) + (pend (check-end f 'sme end)) + (lsta (pat-len f psta)) + (lmid (pat-len f pmid)) + (lend (pat-len f pend)) + (obj (gensym))) + ^@(as ,(check-sym f 'sme obj) + @(and ,psta + @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid)) + (nthcdr ,lsta ,obj)) + @(with @(as ,(check-sym f 'sme eobj t) ,pend) + (nthlast ,lend (nthcdr ,lmid ,mvar))))))) + +(defmatch end (:form f end : evar) + (let* ((pend (check-end f 'end end)) + (lend (pat-len f pend)) + (obj (gensym))) + ^@(as ,(check-sym f 'end obj) + @(with @(as ,(check-sym f 'end evar t) ,pend) + (nthlast ,lend ,obj))))) (defun non-triv-pat-p (syntax) t) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index 4be407fa..346b21b6 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -314,3 +314,10 @@ (2 (3 5))) (test (when-match @(sme () () 5) 5 t) t) + +(test (when-match @(end 3 x) 3 x) 3) +(test (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3))) +(test (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3))) + +(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z)) + (3 (2 3) (1 2 3))) @@ -41481,6 +41481,64 @@ then the match isn't possible. (when-match @(sme () () 5) 5 t) -> t .brev +.coNP Pattern macro @ end +.synb +.mets @(end < pattern <> [ var ]) +.syne +.desc +The pattern macro +.code end +is a notation defined using the +.code defmatch +macro, which matches +.meta pattern +against the suffix of a corresponding list object, +which may be an improper list or atom. + +The optional argument +.meta var +specifies the name of a variable which captures the matched portion of the +object. + +The +.code end +macro is related to the +.code sme +macro according to the following equivalence: + +.verb + @(end pat var) <--> @(sme () () pat : : var) +.brev + +All of the requirements given for +.code sme +apply accordingly. + +.TP* Examples: + +.verb + ;; atom match + (when-match @(end 3 x) 3 x) -> 3 + + ;; y captures (2 3) + (when-match @(end (2 @x) y) + '(1 2 3) + (list x y)) + -> (3 (2 3)) + + ;; variable in dot position + (when-match @(end (2 . @x) y) + '(1 2 . 3) + (list x y)) + -> (3 (2 . 3)) + + ;; z captures entire object + (when-match @(as z @(end (2 @x) y)) + '(1 2 3) + (list x y z)) + -> (3 (2 3) (1 2 3))) +.brev + .SS* Pattern Matching Macros .coNP Macros @ when-match and @ if-match |