diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/arith-each.tl | 54 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 8 | ||||
| -rw-r--r-- | stdlib/each-prod.tl | 31 |
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)) |