summaryrefslogtreecommitdiffstats
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/arith-each.tl54
-rw-r--r--stdlib/doc-syms.tl8
-rw-r--r--stdlib/each-prod.tl31
3 files changed, 92 insertions, 1 deletions
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))