diff options
| -rw-r--r-- | lisplib.c | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 18 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 31 | ||||
| -rw-r--r-- | tests/011/patmatch.tl | 53 | ||||
| -rw-r--r-- | txr.1 | 232 |
5 files changed, 331 insertions, 6 deletions
@@ -877,6 +877,9 @@ static val match_set_entries(val dlt, val fun) val name[] = { lit("when-match"), lit("match-case"), lit("if-match"), lit("lambda-match"), lit("defun-match"), lit("defmatch"), + lit("each-match"), lit("append-matches"), + lit("keep-matches"), lit("each-match-product"), + lit("append-match-products"), lit("keep-match-products"), lit("*match-macro*"), nil }; diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl index de12a878..084b4228 100644 --- a/share/txr/stdlib/doc-syms.tl +++ b/share/txr/stdlib/doc-syms.tl @@ -24,6 +24,7 @@ ("estale" "N-036B1BDB") ("carray-pun" "N-0057639E") ("o-wronly" "N-034BF6C9") + ("each-match-product" "N-01CB9595") ("read-until-match" "N-001D3F81") ("hash-from-pairs" "N-017E6F4C") ("iffi" "N-000E3A74") @@ -375,8 +376,8 @@ ("list" "N-0206CE91") ("collect-each" "N-0105F01D") ("cstopb" "N-01B1B5DF") - ("greater" "N-02AC1F73") ("*stdnull*" "N-006566FB") + ("greater" "N-02AC1F73") ("vt0" "N-03BD477F") ("crypt" "N-00F928CE") ("enotty" "N-036B1BDB") @@ -673,6 +674,7 @@ ("filter" "N-00B50006") ("pushhash" "N-022660B2") ("defex" "D-002A") + ("keep-match-products" "N-01A846D2") ("ceil1" "N-02C8FF28") ("*filters*" "N-00E6A902") ("emultihop" "N-036B1BDB") @@ -701,6 +703,7 @@ ("copy-cons" "N-037EBB77") ("tree-clear" "N-03C88274") ("flatcar*" "N-01FF2F12") + ("keep-matches" "N-01A846D2") ("str" "N-00C6B7C4") ("shut-rd" "N-028953A4") ("sig-iot" "N-0176430F") @@ -836,6 +839,7 @@ ("lchown" "N-003B491C") ("html-encode" "N-01263EAE") ("fstat" "N-006DE1CC") + ("each-match" "N-01CB9595") ("enetreset" "N-036B1BDB") ("package-alist" "N-017F684C") ("span-str" "N-0394CA3A") @@ -1060,9 +1064,9 @@ ("iread" "N-03FE5500") ("handle-frame" "N-0233BAE3") ("time-fields-local" "N-00789418") + ("*print-flo-digits*" "N-00F41F6C") ("copy" "N-0036CED9") ("each*" "N-0105F01D") - ("*print-flo-digits*" "N-00F41F6C") ("fs" "N-03B6902C") ("fname" "N-039E5F67") ("handle*" "N-03F7D8B5") @@ -1353,9 +1357,9 @@ ("ushort" "N-018C7C8C") ("enotconn" "N-036B1BDB") ("flush-stream" "N-03999913") - ("use" "N-0137D341") - ("*stderr*" "N-006566FB") ("*print-flo-precision*" "N-02E97D03") + ("*stderr*" "N-006566FB") + ("use" "N-0137D341") ("buf-get-float" "N-001D239A") ("hash_pairs" "N-01BD56A5") ("efbig" "N-036B1BDB") @@ -1496,8 +1500,8 @@ ("path-setuid-p" "N-02FBA677") ("set-cflags" "N-02061924") ("time-utc" "N-001284ED") - ("buf-put-float" "N-001D2408") ("*pprint-flo-format*" "N-02B252AA") + ("buf-put-float" "N-001D2408") ("log-daemon" "N-0116F48F") ("special-operator-p" "N-01E259AD") ("remq" "N-000ECD82") @@ -1710,6 +1714,7 @@ ("equal" "D-006D") ("sig-hup" "N-0176430F") ("for" "N-031372ED") + ("append-matches" "N-026DC56D") ("tree-delete" "N-022035DF") ("kill" "N-0386CCD5") ("path-dir-empty" "N-01EFC15D") @@ -1735,12 +1740,12 @@ ("lutimes" "N-00E96FCF") ("econnaborted" "N-036B1BDB") ("put-string" "D-006E") + ("*print-flo-format*" "N-02B252AA") ("fun" "N-006E109C") ("rsearch" "N-03405F7D") ("push" "N-01C211C1") ("tan" "D-006F") ("fixnump" "N-03E9D6E1") - ("*print-flo-format*" "N-02B252AA") ("cptr-buf" "N-037139E3") ("butlast" "N-026BB6FA") ("r-atan2" "N-03BBA063") @@ -1758,6 +1763,7 @@ ("getegid" "N-00125C22") ("path-dir-p" "N-00198FC7") ("fourth" "N-01B0FA33") + ("append-match-products" "N-026DC56D") ("*-2" "N-02B67C9B") ("*1" "N-03F9BE17") ("source-loc-str" "N-0370CD69") diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 0e48773f..a069e322 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -961,3 +961,34 @@ (stringp ,str)) @(with ,pos 0) ,*(quasi-match var-list (normalize args) nil str pos))))) + +(defun each-match-expander (f pat-seq-list body fun) + (unless (and (proper-list-p pat-seq-list) + (evenp (len pat-seq-list))) + (compile-error f "pattern-sequence arguments must form pairs")) + (let ((pat-seq-pairs (tuples 2 pat-seq-list))) + (each ((pair pat-seq-pairs)) + (unless (and (proper-list-p pair) + (eql 2 (length pair))) + (compile-error f "invalid pattern-sequence pair ~s" pair))) + (let* ((pats [mapcar car pat-seq-pairs]) + (seqs [mapcar cadr pat-seq-pairs])) + ^(,fun (lambda-match ((,*pats) (progn ,*body))) ,*seqs)))) + +(defmacro each-match (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'mapdo)) + +(defmacro append-matches (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'mappend)) + +(defmacro keep-matches (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'mappend)) + +(defmacro each-match-product (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'maprodo)) + +(defmacro append-match-products (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'maprend)) + +(defmacro keep-match-products (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'maprend)) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index f7055602..85adb352 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -412,6 +412,59 @@ (let ((a "$")) (test (when-match `@a-@b` "$-@" b) "@")) +(test + (build + (each-match (`(@a) @b-@c` '("x" + "" + "(311) 555-5353" + "(604) 923-2323" + "133" + "4-5-6-7") + @x 1) + (add (list x a b c)))) + ((3 "311" "555" "5353") (4 "604" "923" "2323"))) + +(test + (append-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + (1 a 3 c)) + +(test + (append-matches (@x '((1) (2) (3) 4)) x) + (1 2 3 . 4)) + +(test + (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + ((1 a) (3 c))) + +(test + (build + (each-match-product (`(@a) @b-@c` '("x" + "" + "(311) 555-5353" + "(604) 923-2323" + "133" + "4-5-6-7") + @(oddp @x) '(1 2 3)) + (add (list x a b c)))) + ((1 "311" "555" "5353") (3 "311" "555" "5353") + (1 "604" "923" "2323") (3 "604" "923" "2323"))) + +(test + (append-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + (1 2 1 4 3 2 3 4 5 2 5 4)) + +(test + (keep-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4))) + (compile-only (eval-only (compile-file (base-name *load-path*) "temp.tlo") @@ -42543,6 +42543,238 @@ environment object which the expander can capture using .code :env in its macro parameter list. +.coNP Macros @ each-match and @ each-match-product +.synb +.mets (each-match >> ({ pattern << seq-form }*) << body-form *) +.mets (each-match-product >> ({ pattern << seq-form }*) << body-form *) +.syne +.desc +The +.code each-match +macro arranges for elements from multiple sequences to be +visited in parallel, and each to be matched against respective patterns. +For each matching tuple of parallel elements, a body of forms is evaluated in +the scope of the variables bound in the patterns. + +The first argument of +.code each-match +specifies a list of alternating +.meta pattern +and +.meta seq-form +expressions. Each +.meta pattern +is associated with the sequence which results from evaluating the +immediately following +.metn seq-form . +Items coming from that sequence correspond with that pattern. + +The remaining arguments are +.metn body-form s +to evaluated for successful matches. + +The processing takes place as follows: +.RS +.IP 1. +Every +.meta seq-form +is evaluated in left-to-right order and is expected to produce an +iterable sequence or object that would be a suitable argument to +.code mapcar +or +.codn iter-begin . +This evaluation takes place in the scope surrounding the macro form, +in which none of the variables that are bound in the +.meta pattern +expressions are yet visible. +.IP 2. +The next available item is taken from each of the sequences. +If any of the sequences has no more items available, then +.code each-match +terminates and returns +.codn nil . +.IP 3. +Each item taken in step 2 is matched against the +.meta pattern +which is corresponds with its sequence. Each successive pattern can +refer to the variables bound in the previous patterns in the same +iteration. If any pattern match fails, then the process continues with step 2. +.IP 4. +If all the matches are successful, then +.metn body-form s, +if any, are executed in the scope of variables bound in the +.metn pattern s. +Processing then continues at step 2. +.RE +.IP +The +.code each-match-product +differs from +.code each-match +in that instead of taking parallel tuples of items from the sequences, +it iterates over the tuples of the Cartesian product of the sequences +similarly to the +.code maprod +function. The product tuples are ordered in such a way that the rightmost +element, which always coming coming from sequence produced by the last +.metn seq-form , +varies the fastest. If there are two sequences +.code "(1 2)" +and +.codn "(a b)" , +then +.code each-match +iterates over the tuples +.code "(1 a)" +and +.codn "(2 b)" , +whereas +.code each-match-product +iterates over +.codn "(1 a)" , +.codn "(1 b)" , +.code "(2 a)" +and +.codn "(2 b)" . + +.TP* Examples: +.verb + ;; Number all the .JPG files in the current directory. + ;; For instance foo.jpg becomes foo-0001.jpg, if it is + ;; the first file. + (each-match (@(as name `@base.jpg`) (glob "*.jpg") + @(@num (fmt "~,04a")) 1) + (rename-path name `@base-@num.jpg`)) + + ;; Iterate over combinations of matching phone + ;; numbers and odd integers from the (1 2 3) list + (build + (each-match-product (`(@a) @b-@c` '("x" + "" + "(311) 555-5353" + "(604) 923-2323" + "133" + "4-5-6-7") + @(oddp @x) '(1 2 3)) + (add (list x a b c)))) + --> + ((1 "311" "555" "5353") (3 "311" "555" "5353") + (1 "604" "923" "2323") (3 "604" "923" "2323"))) +.brev + +.coNP Macros @ append-matches and @ append-match-products +.synb +.mets (append-matches >> ({ pattern << seq-form }*) << body-form *) +.mets (append-match-products >> ({ pattern << seq-form }*) << body-form *) +.syne +.desc +The macro +.code append-matches +is subject to all of the requirements specified for +.code each-match +in regard to the argument conventions and semantics. + +Whereas +.code each-match +returns +.codn nil , +the +.code append-matches +macro requires, in each iteration which produces a match for each +.metn pattern , +that the last +.meta body-form +evaluated must produce a list. + +These lists are catenated together as if by the +.code append +function and returned. + +It is unspecified whether the non-matching iterations produce +empty lists which are included in the append operation. + +If the last tuple of items which produces a match is absolutely the +the last tuple, the corresponding +.meta body-form +evaluation may yield an atom which then becomes the terminator +for the returned list, in keeping with the semantics of +.codn append . +an atom. + +The +.code append-match-products +macro differs from +.code append-matches +in that it iterates over the Cartesian product tuples of the sequences, +rather than parallel tuples. The difference is exactly like that between +.code each-match +and +.codn each-match-product . + +.TP* Examples: + +.verb + (append-matches + ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + --> (1 a 3 c) + + (append-matches (@x '((1) (2) (3) 4)) x) + --> (1 2 3 . 4) + + (append-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + --> (1 2 1 4 3 2 3 4 5 2 5 4) +.brev + +.coNP Macros @ keep-matches and @ keep-match-products +.synb +.mets (keep-matches >> ({ pattern << seq-form }*) << body-form *) +.mets (keep-match-products >> ({ pattern << seq-form }*) << body-form *) +.syne +.desc +The macro +.code keep-matches +is subject to all of the requirements specified for +.code each-match +in regard to the argument conventions and semantics. + +Whereas +.code each-match +returns +.codn nil , +the +.code keep-matches +macro returns a list of the values produced by all matching iterations which +led to the the execution of the +.metn body-form s. + +The +.code keep-match-products +macro differs from +.code keep-matches +in that it iterates over the Cartesian product tuples of the sequences, +rather than parallel tuples. The difference is exactly like that between +.code each-match +and +.codn each-match-product . + +.TP* Examples: + +.verb + (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + --> ((1 a) (3 c)) + + (keep-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + --> ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4)) +.brev + .SS* Quasiquote Operator Syntax .coNP Macro @ qquote .synb |