summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-09-23 06:21:30 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-09-23 06:21:30 -0700
commit7e36a3f2a6501a0bc6d24836610746f59427b496 (patch)
tree27530ff29c4a99612bac17199dd0c98a2397751a
parentbbd2e86fa76d4afb0ca39a28682f5a0da62aa1a0 (diff)
downloadtxr-7e36a3f2a6501a0bc6d24836610746f59427b496.tar.gz
txr-7e36a3f2a6501a0bc6d24836610746f59427b496.tar.bz2
txr-7e36a3f2a6501a0bc6d24836610746f59427b496.zip
New variants of each operator for sum and product.
* lisplib.c (arith_each_instantiate, arith_each_set_entries): New functions. (each_prod_set_entries): Add sum-each-prod, sum-each-prod*, mul-each-prod and mul-each-prod* as autoload triggers for each-prod.tl, where those macros are now defined. (lisplib_init): Register autoloading of arith-each.tl via the two new functions. * stdlib/arith-each.tl: New file. * stdlib/each-prod.tl (sys:expand-each-prod*): Handle sum-each-prod* and mul-each-prod* in the same way, by mapping to their parallel binding counterparts. (sys:expand-arith-each-prod): New function. (sym-each-prod, mul-each-prod, sum-each-prod*, mul-each-prod*): New macros. * tests/016/arith.tl: New tests. * txr.1: Documented. * stdlib/doc-syms.tl: Updated.
-rw-r--r--lisplib.c20
-rw-r--r--stdlib/arith-each.tl54
-rw-r--r--stdlib/doc-syms.tl8
-rw-r--r--stdlib/each-prod.tl31
-rw-r--r--tests/016/arith.tl58
-rw-r--r--txr.1120
6 files changed, 290 insertions, 1 deletions
diff --git a/lisplib.c b/lisplib.c
index 3a5beb78..17485812 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -835,6 +835,23 @@ static val copy_file_set_entries(val dlt, val fun)
return nil;
}
+static val arith_each_instantiate(val set_fun)
+{
+ funcall1(set_fun, nil);
+ load(scat2(stdlib_path, lit("arith-each")));
+ return nil;
+}
+
+static val arith_each_set_entries(val dlt, val fun)
+{
+ val name[] = {
+ lit("sum-each"), lit("mul-each"), lit("sum-each*"), lit("mul-each*"),
+ nil
+ };
+ set_dlt_entries(dlt, name, fun);
+ return nil;
+}
+
static val each_prod_instantiate(val set_fun)
{
funcall1(set_fun, nil);
@@ -846,7 +863,9 @@ static val each_prod_set_entries(val dlt, val fun)
{
val name[] = {
lit("each-prod"), lit("collect-each-prod"), lit("append-each-prod"),
+ lit("sum-each-prod"), lit("mul-each-prod"),
lit("each-prod*"), lit("collect-each-prod*"), lit("append-each-prod*"),
+ lit("sum-each-prod*"), lit("mul-each-prod*"),
nil
};
set_dlt_entries(dlt, name, fun);
@@ -1009,6 +1028,7 @@ void lisplib_init(void)
dlt_register(dl_table, save_exe_instantiate, save_exe_set_entries);
dlt_register(dl_table, defset_instantiate, defset_set_entries);
dlt_register(dl_table, copy_file_instantiate, copy_file_set_entries);
+ dlt_register(dl_table, arith_each_instantiate, arith_each_set_entries);
dlt_register(dl_table, each_prod_instantiate, each_prod_set_entries);
dlt_register(dl_table, quips_instantiate, quips_set_entries);
dlt_register(dl_table, match_instantiate, match_set_entries);
diff --git a/stdlib/arith-each.tl b/stdlib/arith-each.tl
new file mode 100644
index 00000000..b0be94ab
--- /dev/null
+++ b/stdlib/arith-each.tl
@@ -0,0 +1,54 @@
+;; Copyright 2021
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro sum-each (vars . body)
+ (with-gensyms (accum)
+ ^(let ((,accum 0))
+ (each ,vars
+ (inc ,accum (progn ,*body)))
+ ,accum)))
+
+(defmacro sum-each* (vars . body)
+ (with-gensyms (accum)
+ ^(let ((,accum 0))
+ (each* ,vars
+ (inc ,accum (progn ,*body)))
+ ,accum)))
+
+(defmacro mul-each (vars . body)
+ (with-gensyms (accum)
+ ^(let ((,accum 1))
+ (each ,vars
+ (set ,accum (* ,accum (progn ,*body))))
+ ,accum)))
+
+(defmacro mul-each* (vars . body)
+ (with-gensyms (accum)
+ ^(let ((,accum 1))
+ (each* ,vars
+ (set ,accum (* ,accum (progn ,*body))))
+ ,accum)))
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 60a81501..c9fcf582 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -1283,6 +1283,10 @@
("ms-invalidate" "N-01F782B2")
("ms-sync" "N-01F782B2")
("msync" "N-02805A83")
+ ("mul-each" "N-01C5F219")
+ ("mul-each*" "N-01C5F219")
+ ("mul-each-prod" "N-003CC14A")
+ ("mul-each-prod*" "N-003CC14A")
("multi" "N-034946BA")
("multi-sort" "N-0132852F")
("munmap" "N-00E1BF52")
@@ -1878,6 +1882,10 @@
("subtypep" "N-00699D3B")
("succ" "N-038E636C")
("sum" "N-0163FFE2")
+ ("sum-each" "N-01C5F219")
+ ("sum-each*" "N-01C5F219")
+ ("sum-each-prod" "N-003CC14A")
+ ("sum-each-prod*" "N-003CC14A")
("super" "N-03D8EEEE")
("super-method" "N-02AC8367")
("suspend" "N-02E7852D")
diff --git a/stdlib/each-prod.tl b/stdlib/each-prod.tl
index d1a9c15a..1393b80a 100644
--- a/stdlib/each-prod.tl
+++ b/stdlib/each-prod.tl
@@ -50,12 +50,29 @@
(let* ((each-prod-op (caseq (car form)
(each-prod* 'each-prod)
(collect-each-prod* 'collect-each-prod)
- (append-each-prod* 'append-each-prod)))
+ (append-each-prod* 'append-each-prod)
+ (sum-each-prod* 'sum-each-prod)
+ (mul-each-prod* 'mul-each-prod)))
(syms [mapcar car vars])
(inits [mapcar cadr vars]))
^(let* ,vars
(,each-prod-op ,(zip syms syms) ,*body))))
+(defun sys:expand-arith-each-prod (form vars body)
+ (sys:vars-check form vars)
+ (let ((syms [mapcar car vars])
+ (inits [mapcar cadr vars]))
+ (sys:bindable-check form syms)
+ (let ((op-iv (caseq (car form)
+ (sum-each-prod '(+ . 0))
+ (mul-each-prod '(* . 1)))))
+ (with-gensyms (acc)
+ ^(let ((,acc ,(cdr op-iv)))
+ (maprodo (lambda (,*syms)
+ (set ,acc (,(car op-iv) ,acc (progn ,*body))))
+ ,*inits)
+ ,acc)))))
+
(defmacro each-prod (:form f vars . body)
(sys:expand-each-prod f vars body))
@@ -65,6 +82,12 @@
(defmacro append-each-prod (:form f vars . body)
(sys:expand-each-prod f vars body))
+(defmacro sum-each-prod (:form f vars . body)
+ (sys:expand-arith-each-prod f vars body))
+
+(defmacro mul-each-prod (:form f vars . body)
+ (sys:expand-arith-each-prod f vars body))
+
(defmacro each-prod* (:form f vars . body)
(sys:expand-each-prod* f vars body))
@@ -73,3 +96,9 @@
(defmacro append-each-prod* (:form f vars . body)
(sys:expand-each-prod* f vars body))
+
+(defmacro sum-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
+
+(defmacro mul-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
diff --git a/tests/016/arith.tl b/tests/016/arith.tl
index 34a82c7f..367b0c32 100644
--- a/tests/016/arith.tl
+++ b/tests/016/arith.tl
@@ -253,3 +253,61 @@
3.0 3.0 3.0 3.0 3.0)])
(0.0 0.0 0.0 0.0 0.0
1.5 2.25 2.625 2.8125 2.90625))
+
+(mtest
+ (sum-each ((x '(1 2 3))
+ (y '(4 5 6)))
+ (* x y))
+ 32
+ (mul-each ((x '(1 2 3))
+ (y '(4 5 6)))
+ (+ x y))
+ 315
+ (sum-each* ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ 8
+ (mul-each* ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ 15
+ (sum-each ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ :error
+ (mul-each ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ :error)
+
+(mtest
+ (sum-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (* x y))
+ 54
+ (sum-each-prod* ((x '(1 2 3 4))
+ (y (cdr x)))
+ (* x y))
+ 90
+ (sum-each-prod ((x '(1 2 3 4))
+ (y (cdr x)))
+ (* x y))
+ :error)
+
+(mvtest
+ (mul-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (+ x y))
+ (* (+ 1 4) (+ 1 3) (+ 1 2)
+ (+ 2 4) (+ 2 3) (+ 2 2)
+ (+ 3 4) (+ 3 3) (+ 3 2))
+ (mul-each-prod* ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ (* (+ 1 2) (+ 1 3)
+ (+ 2 2) (+ 2 3)
+ (+ 3 2) (+ 3 3))
+ (sum-each-prod ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ :error)
diff --git a/txr.1 b/txr.1
index 8281de4a..230c20f7 100644
--- a/txr.1
+++ b/txr.1
@@ -17639,6 +17639,84 @@ into the
.meta step-form
position.
+.coNP Macros @, sum-each @, sum-each* @ mul-each and @ mul-each*
+.synb
+.mets (sum-each >> ({( sym << init-form )}*) << body-form *)
+.mets (sum-each* >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn sum-each ,
+and
+.code mul-each
+behave very similarly to the
+.code each
+operator. Whereas the
+.code each
+operator form returns
+.code nil
+as its result, the
+.code sum-each
+and
+.code mul-each
+forms, if they execute to completion and return normally, return
+an accumulated value.
+
+The
+.code sum-each
+macro initializes newly instantiated, hidden accumulator variable
+to the value
+.codn 0 .
+For each iteration of the loop, the
+.metn body-form s
+are evaluated, and are expected to produce a value. This value
+is added to the current value of the hidden accumulator using the
+.code +
+function, and the result is stored into the accumulator. If
+.code sum-each
+returns normally, then the value of this accumulator becomes its
+resulting value.
+
+The
+.code mul-each
+macro similarly initializes a hidden accumulator to the value
+.codn 1 .
+The value from each iteration of the body is multiplied with
+the accumulator using the
+.code *
+function, and the result is stored into the accumulator. If
+.code mul-each
+returns normally, then the value of this accumulator becomes
+its resulting value.
+
+The
+.code sum-each*
+and
+.code mul-each*
+variants of the macros implement the sequential scoping rule for
+the variable bindings, exactly the way
+.code each*
+alters the semantics of
+.codn each .
+
+Note: the following equivalences apply, except that the accumulator
+variable is a named by a unique, generated symbol.
+
+.verb
+ (sum-each (vars ...) <--> (let ((acc 0))
+ body ...) (each vars
+ (inc acc (progn body)))
+ acc)
+
+ (mul-each (vars ...) <--> (let ((acc 1))
+ body) (each vars
+ (set acc (* acc
+ (progn body))))
+ acc)
+.brev
+
.coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod
.synb
.mets (each-prod >> ({( sym << init-form )}*) << body-form *)
@@ -17761,6 +17839,48 @@ stepped by assignment.
--> ("aA" "aB" "aC" "bA" "bB" "bC" "cA" "cB" "cC")
.onom
+.coNP Macros @, sum-each-prod @, sum-each-prod* @ mul-each-prod and @ mul-each-prod*
+.synb
+.mets (sum-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (sum-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.code sum-each-prod
+and
+.code mul-each-prod
+have a similar syntax to
+.code sum-each
+and
+.codn mul-each .
+However, instead of iterating over sequences in parallel, they iterate over
+the Cartesian product of the elements from the sequences.
+
+The macros
+.code sum-each-prod*
+and
+.code mul-each-prod*
+variants perform sequential variable binding when establishing the initial
+values of the variables, similarly to the
+.code each*
+operator.
+
+.TP* Examples:
+
+.verb
+ ;; Inefficiently calculate (+ (* 1 2 3) (* 4 3 2)).
+ ;; Every value from (1 2 3) is paired with every value
+ ;; from (4 3 2) to form a partial products, and
+ ;; sum-each-prod adds these together implicitly:
+
+ (sum-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (* x y))
+ -> 54
+.brev
+
.coNP Operators @ block and @ block*
.synb
.mets (block < name << body-form *)