From 7ddf60607eda5d7284a31f285eff03e8af5c72bd Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 12 Jan 2022 07:04:03 -0800 Subject: New macros: each-true, some-true, each-false, some-false. * lisplib.c (arith_each_set_entries): Trigger autoload on new symbols. * stdilb/arith-each.tl (sys:arith-each): Generalize macro to handle short-circuiting logical operations. The op-iv parameter, which is a cons, is spread into two op and iv parameter. One new argument appears, short-circ. This specifies a code for short-circuiting behavior: t means iteration continues while the result is true; nil means it continues while it is nil, and + means iteration continues while the accumulator is nonzero. A new convention is in effect: the operator has to be specified as a list in order to request accumulating behavior, e.g (+) or (*). Otherwise the operator specifies a predicate that is applied to the forms, without taking into account the prior value. (sum-each, sum-each*, mul-each, mul-each*): Spread the op-iv arguments. Wrap the op argument in a list to request accumulation. In the case of mul-each and mul-each*, specify + for the short-circ argument, which means that iteration stops when the accumulator becomes zerop. sum-each and sum-each* specify : for the short-circ argument which is unrecognized, and so ther is no short-circuiting behavior. (each-true, some-true, each-false, some-false): New macros. * tests/016/arith.tl: New tests. * txr.1: Documented new macros and added note about possible short-circuiting in mul-each and mul-each*. * stdlib/doc-syms.tl: Updated. --- lisplib.c | 1 + stdlib/arith-each.tl | 50 ++++++++++++++++---- stdlib/doc-syms.tl | 4 ++ tests/016/arith.tl | 41 +++++++++++++++++ tests/016/log.tl | 42 ----------------- txr.1 | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 212 insertions(+), 52 deletions(-) delete mode 100644 tests/016/log.tl diff --git a/lisplib.c b/lisplib.c index bf88d921..80c8dc59 100644 --- a/lisplib.c +++ b/lisplib.c @@ -848,6 +848,7 @@ static val arith_each_set_entries(val dlt, val fun) { val name[] = { lit("sum-each"), lit("mul-each"), lit("sum-each*"), lit("mul-each*"), + lit("each-true"), lit("some-true"), lit("each-false"), lit("some-false"), nil }; set_dlt_entries(dlt, name, fun); diff --git a/stdlib/arith-each.tl b/stdlib/arith-each.tl index ba8c8c8a..b2904dee 100644 --- a/stdlib/arith-each.tl +++ b/stdlib/arith-each.tl @@ -31,43 +31,73 @@ (whenlet ((bad (find-if [notf consp] vars))) (compile-error form "~s isn't a var-initform pair" bad))) -(defmacro sys:arith-each (:form f op-iv vars . body) +(defmacro sys:arith-each (:form f fn iv short-circ vars . body) (let* ((gens (mapcar (ret (gensym)) vars)) (syms [mapcar car vars]) - (accum (gensym)) - (op (car op-iv)) - (iv (cdr op-iv))) + (accum (gensym))) (if (null vars) iv ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens syms) (,accum ,iv)) (block nil (sys:for-op () - ((and ,*(mapcar (op list 'iter-more) gens)) ,accum) + ((and ,*(mapcar (op list 'iter-more) gens) + ,*(cond + ((eq t short-circ) ^(,accum)) + ((null short-circ) ^((null ,accum))) + ((eq '+ short-circ) ^((nzerop ,accum))))) + ,accum) (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens)) ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) syms gens) - (set ,accum (,op ,accum (progn ,*body))))))))) + (set ,accum ,(cond + ((consp fn) ^(,(car fn) ,accum (progn ,*body))) + (fn ^(,fn (progn ,*body))) + (t ^(progn ,*body)))))))))) (defmacro sum-each (:form f vars . body) (sys:vars-check f vars) ^(let ,vars (block nil - (sys:arith-each (+ . 0) ,vars ,*body)))) + (sys:arith-each (+) 0 : ,vars ,*body)))) (defmacro sum-each* (:form f vars . body) (sys:vars-check f vars) ^(let* ,vars (block nil - (sys:arith-each (+ . 0) ,vars ,*body)))) + (sys:arith-each (+) 0 : ,vars ,*body)))) (defmacro mul-each (:form f vars . body) (sys:vars-check f vars) ^(let ,vars (block nil - (sys:arith-each (* . 1) ,vars ,*body)))) + (sys:arith-each (*) 1 + ,vars ,*body)))) (defmacro mul-each* (:form f vars . body) (sys:vars-check f vars) ^(let* ,vars (block nil - (sys:arith-each (* . 1) ,vars ,*body)))) + (sys:arith-each (*) 1 + ,vars ,*body)))) + +(defmacro each-true (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (sys:arith-each nil t t ,vars ,*body)))) + +(defmacro some-true (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (sys:arith-each nil nil nil ,vars ,*body)))) + +(defmacro each-false (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (sys:arith-each not t t ,vars ,*body)))) + +(defmacro some-false (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (sys:arith-each not nil nil ,vars ,*body)))) diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl index fff64b8a..1148e256 100644 --- a/stdlib/doc-syms.tl +++ b/stdlib/doc-syms.tl @@ -536,10 +536,12 @@ ("eacces" "N-036B1BDB") ("each" "N-0105F01D") ("each*" "N-0105F01D") + ("each-false" "N-016BDF48") ("each-match" "N-01CB9595") ("each-match-product" "N-01CB9595") ("each-prod" "N-02CA3C70") ("each-prod*" "N-02660E4F") + ("each-true" "N-016BDF48") ("eaddrinuse" "N-036B1BDB") ("eaddrnotavail" "N-036B1BDB") ("eafnosupport" "N-036B1BDB") @@ -1821,6 +1823,8 @@ ("socklen-t" "N-01153D9E") ("sol-socket" "N-031C01CB") ("some" "D-0040") + ("some-false" "N-016BDF48") + ("some-true" "N-016BDF48") ("sort" "N-01FE5176") ("sort-group" "N-01E65DDC") ("source-loc" "N-0370CD69") diff --git a/tests/016/arith.tl b/tests/016/arith.tl index 24521921..d740835b 100644 --- a/tests/016/arith.tl +++ b/tests/016/arith.tl @@ -331,3 +331,44 @@ (y (cdr x))) (* x y)) :error) + +(mtest + (each-true ()) t + (each-true ((a ()))) t + (each-true ((a ())) nil) t + (each-true ((a '(1 2 3))) a) 3 + (each-true ((a '(nil 2 3))) a) nil + (each-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t + (each-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) nil) + +(mtest + (some-true ()) nil + (some-true ((a ()))) nil + (some-true ((a ())) nil) nil + (some-true ((a '(1 2 3))) a) 1 + (some-true ((a '(nil 2 3))) a) 2 + (some-true ((a '(nil nil nil))) a) nil + (some-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t + (some-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) t + (some-true ((a '(1 2 3)) (b '(0 1 2))) (< a b)) nil) + +(mtest + (each-false ()) t + (each-false ((a ()))) t + (each-false ((a ())) t) t + (each-false ((a '(1 2 3))) a) nil + (each-false ((a '(nil))) a) t + (each-false ((a '(nil nil))) a) t + (each-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t + (each-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) nil) + +(mtest + (some-false ()) nil + (some-false ((a ()))) nil + (some-false ((a ())) nil) nil + (some-false ((a '(1 2 3))) a) nil + (some-false ((a '(nil 2 3))) a) t + (some-false ((a '(nil nil nil))) a) t + (some-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t + (some-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) t + (some-false ((a '(1 2 3)) (b '(0 1 2))) (> a b)) nil) diff --git a/tests/016/log.tl b/tests/016/log.tl deleted file mode 100644 index 3dcd9056..00000000 --- a/tests/016/log.tl +++ /dev/null @@ -1,42 +0,0 @@ -(load "../common.tl") - -(mtest - (each-true ()) t - (each-true ((a ()))) t - (each-true ((a ())) nil) t - (each-true ((a '(1 2 3))) a) 3 - (each-true ((a '(nil 2 3))) a) nil - (each-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t - (each-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) nil) - -(mtest - (some-true ()) :error - (some-true ((a ()))) nil - (some-true ((a ())) nil) nil - (some-true ((a '(1 2 3))) a) 1 - (some-true ((a '(nil 2 3))) a) 2 - (some-true ((a '(nil nil nil))) a) nil - (some-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t - (some-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) t - (some-true ((a '(1 2 3)) (b '(0 1 2))) (< a b)) nil) - -(mtest - (each-false ()) :error - (each-false ((a ()))) t - (each-false ((a ())) t) t - (each-false ((a '(1 2 3))) a) nil - (each-false ((a '(nil))) a) t - (each-false ((a '(nil nil))) a) t - (each-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t - (each-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) nil) - -(mtest - (some-false ()) :error - (some-false ((a ()))) nil - (some-false ((a ())) nil) nil - (some-false ((a '(1 2 3))) a) nil - (some-false ((a '(nil 2 3))) a) t - (some-false ((a '(nil nil nil))) a) t - (some-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t - (some-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) t - (some-false ((a '(1 2 3)) (b '(0 1 2))) (> a b)) nil) diff --git a/txr.1 b/txr.1 index a697a47c..992f2743 100644 --- a/txr.1 +++ b/txr.1 @@ -17765,6 +17765,132 @@ Note that this behavior differs from and its closely-related operators, which loop infinitely when no variables are specified. +It is unspecified whether +.code mul-each +and +.code mul-each* +continue iterating when the accumulator takes on a value satisfying the +.code zerop +predicate. + +.coNP Macros @, each-true @, some-true @ each-false and @ some-false +.synb +.mets (each-true >> ({( sym << init-form )}*) << body-form *) +.mets (some-true >> ({( sym << init-form )}*) << body-form *) +.mets (each-false >> ({( sym << init-form )}*) << body-form *) +.mets (some-false >> ({( sym << init-form )}*) << body-form *) +.syne +.desc +These macros iterate zero or more variables over sequences, similarly to the +.code each +operator and calculate logical results, with short-circuiting semantics. + +The +.code each-true +macro initializes an internal result variable to the +.code t +value. It then evaluates the +.metn body-form s +for each tuple of variable values, replacing the result variable with +the value produced by these forms. If that value is +.codn nil , +the iteration stops. When the iteration terminates normally, the +value of the result variable is returned. + +If no variables are specified, termination occurs immediately. +Note that this is different from the +.code each +operator, which iterates infinitely if no variables are specified. + +The +.metn body-form s +are surrounded by an implicit anonymous block, making it possible +to terminate via +.code return +or +.codn return-from . +In these cases, the form terminates with +.code nil +or the specified return value. The internal result is ignored. + +The +.code some-true +macro is similar to +.codn each-true , +with these differences. The internal result variable is initialized to +.code nil +rather than +.codn t . +The iteration stops whenever the +.metn body-form s +produce a true value, and that value is returned. + +The +.code each-false +and +.code some-false +macros are, respectively, similar to +.code each-true +and +.codn some-true , +with one difference. After each iteration, the value produced by the +.metn body-form s +is logically inverted using the +.code not +function prior to being assigned to the result variable. + +.TP* Examples: + +.verb + (each-true ()) -> t + (each-true ((a ()))) -> t + (each-true ((a '(1 2 3))) a) -> 3 + + (each-true ((a '(1 2 3)) + (b '(4 5 6))) + (< a b)) + -> t + + (each-true ((a '(1 2 3)) + (b '(4 0 6))) + (< a b)) + -> nil + + (some-true ((a '(1 2 3))) a) -> 1 + (some-true ((a '(nil 2 3))) a) -> 2 + (some-true ((a '(nil nil nil))) a) -> nil + + (some-true ((a '(1 2 3)) + (b '(4 0 6))) + (< a b)) + -> t + + (some-true ((a '(1 2 3)) + (b '(0 1 2))) + (< a b)) + -> nil + + (each-false ((a '(1 2 3)) + (b '(4 5 6))) + (> a b)) + -> t + + (each-false ((a '(1 2 3)) + (b '(4 0 6))) + (> a b)) + -> nil + + (some-false ((a '(1 2 3)) + (b '(4 0 6))) + (> a b)) + -> t + + (some-false ((a '(1 2 3)) + (b '(0 1 2))) + (> a b)) + -> nil +.brev + .coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod .synb .mets (each-prod >> ({( sym << init-form )}*) << body-form *) -- cgit v1.2.3