diff options
| -rw-r--r-- | lisplib.c | 1 | ||||
| -rw-r--r-- | stdlib/arith-each.tl | 50 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 4 | ||||
| -rw-r--r-- | tests/016/arith.tl | 41 | ||||
| -rw-r--r-- | tests/016/log.tl | 42 | ||||
| -rw-r--r-- | txr.1 | 126 |
6 files changed, 212 insertions, 52 deletions
@@ -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) @@ -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 *) |