diff options
| -rw-r--r-- | lisplib.c | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 45 | ||||
| -rw-r--r-- | tests/011/patmatch.tl | 37 | ||||
| -rw-r--r-- | txr.1 | 125 |
5 files changed, 210 insertions, 2 deletions
@@ -871,7 +871,7 @@ static val match_instantiate(val set_fun) static val match_set_entries(val dlt, val fun) { val name_noload[] = { - lit("all*"), lit("as"), lit("with"), lit("scan"), + lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"), nil }; val name[] = { diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl index 389ea679..dfd6f178 100644 --- a/share/txr/stdlib/doc-syms.tl +++ b/share/txr/stdlib/doc-syms.tl @@ -407,12 +407,12 @@ ("lset" "N-008216EC") ("clock-t" "N-03258244") ("ai-v4mapped" "N-020DFFDE") + ("pprinl" "N-02FCCE0D") ("struct-type-name" "N-00088BD7") ("rplacd" "D-0013") ("unless" "N-017EFAB6") ("log10" "D-0014") ("*hash-seed*" "N-0041D85A") - ("pprinl" "N-02FCCE0D") ("vec-push" "N-01693B82") ("base64-stream-enc" "N-03BEDB34") ("ftw-stop" "N-03853999") @@ -1640,6 +1640,7 @@ ("nzerop" "N-0197FF9D") ("*" "N-022396F7") ("arraysize" "N-002129D6") + ("sme" "N-008C6621") ("tcioff" "N-02173FF9") ("log-pid" "N-02371913") ("typep" "N-03B8D9EE") diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 91885472..c43f7722 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -756,6 +756,51 @@ ,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 non-triv-pat-p (syntax) t) (defun non-triv-pat-p (syntax) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index abad6b44..4be407fa 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -277,3 +277,40 @@ ((@a 2 @b) ^(2 ,a)))) (local 3 2 1))) (2 3)) + +(test + (when-match @(sme (1 2) (3 4) (5 . 6) m e) + '(1 2 3 4 5 . 6) + (list m e)) + ((3 4 5 . 6) (5 . 6))) + +(test + (when-match @(sme (1 2) (3 4) (5 . 6) m d) + '(1 2 abc 3 4 def 5 . 6) + (list m d)) + ((3 4 def 5 . 6) (5 . 6))) + +(test + (when-match @(sme (1 2 @x . @y) (4 @z) 6) + '(1 2 abc 3 4 def 5 . 6) + (list x y z)) + (abc (3 4 def 5 . 6) def)) + +(test (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil) +(test (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil) +(test (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil) +(test (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t) +(test (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t) +(test (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil) + +(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2) + (list x y z)) + (1 2 3)) + +(test (when-match @(and @(sme (1 @x) (3) (7) m n) + @(with @(coll @(oddp @y)) (ldiff m n))) + '(1 2 3 4 5 6 7) + (list x y)) + (2 (3 5))) + +(test (when-match @(sme () () 5) 5 t) t) @@ -41356,6 +41356,131 @@ is a standard \*(TL notation with the same meaning as - > (t (1 2 3)) .brev +.coNP Pattern macro @ sme +.synb +.mets @(sme < spat < mpat < epat >> [ mvar <> [ evar ]]) +.syne +.desc +The pattern macro +.code sme +(start, middle, end) is a notation defined using the +.code defmatch +macro. + +The +.code sme +macro generates a complex pattern which matches three non-overlapping +parts of a list object using three patterns. The +.meta spat +pattern is required to match a prefix of the input list. If that match is +successful, then the remainder of the list is searched for a match for +.metn mpat , +using the +.code scan +operator. If that match, in turn, is successful, then the suffix of +the remainder of the list is required to match +.codn epat . + +The optional +.meta mvar +and +.meta evar +arguments must be bindable symbols, if they are specified. +These symbols specify lexical variables which are bound to, respectively, +the object matched by +.meta mpat +and +.metn epat , +using the fresh binding semantics of the +.code as +pattern operator. + +The first two patterns, +.meta spat +and +.metn mpat , +must be possibly dotted list patterns. +The last pattern, +.metn epat , +must be either an atom or a possibly dotted list pattern. + +Important to the semantics of +.code sme +is the concept of the length of a list pattern. + +The length of a pattern with a pattern variable or operator +in the dotted position is the number of items before that variable +or operator. The length of +.code "(1 2 . @(and a b))" +is 2; likewise the length of +.code "(1 2 . @nil)" +is also 2. +The length of a pattern which does not have a variable or +operator in the dotted position is simply its list length. +For instance, the pattern +.code "(1 2 3)" +has length 3, and so does the pattern +.codn "(1 2 3 . 4)" . +The length is determined by the list object structure of the +pattern, and not the printed syntax used to express it. Thus, +.code "(1 . (2 3))" +is still a length 3 pattern, because it denotes the same +.code "(1 2 3)" +object, using the dot notation unnecessarily. + +The non-overlapping semantics of +.code sme +develops as follows. When the +.meta spat +pattern matches a prefix of the input object, then a middle suffix is +calculated of the input object by dropping leading elements from it. The number +of elements dropped is equal to the length +.metn spat . +The +.meta mpat +is then similarly matched against a prefix of this middle suffix. If that match +is successful, a number of leading elements equal to the length of +.meta mpat +is dropped from the middle suffix to determine the final suffix. +Then +.meta epat +is matched against the tail portion of the final suffix which is equal +to its length. If the final suffix is shorter than +.metn epat , +then the match isn't possible. + +.TP* Examples: + +.verb + (when-match @(sme (1 2) (3 4) (5 . 6) m e) + '(1 2 3 4 5 . 6) + (list m e)) + -> ((3 4 5 . 6) (5 . 6)) + + (when-match @(sme (1 2) (3 4) (5 . 6) m e) + '(1 2 abc 3 4 def 5 . 6) + (list m e)) + ((3 4 def 5 . 6) (5 . 6)) + + ;; backreferencing + (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2) + (list x y z)) + -> (1 2 3)) + + ;; collect odd items starting at 3, before 7 + (when-match @(and @(sme (1 @x) (3) (7) m e) + @(with @(coll @(oddp @y)) (ldiff m e))) + '(1 2 3 4 5 6 7) + (list x y)) + -> (2 (3 5))) + + ;; no overlap + (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) -> nil + + ;; The atom 5 is like a "zero-length improper list". + (when-match @(sme () () 5) 5 t) -> t +.brev + .SS* Pattern Matching Macros .coNP Macros @ when-match and @ if-match |