diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/arith-each.tl | 63 | ||||
| -rw-r--r-- | stdlib/each-prod.tl | 22 |
2 files changed, 53 insertions, 32 deletions
diff --git a/stdlib/arith-each.tl b/stdlib/arith-each.tl index b0be94ab..edae748f 100644 --- a/stdlib/arith-each.tl +++ b/stdlib/arith-each.tl @@ -25,30 +25,45 @@ ;; 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))) +(defun sys:vars-check (form vars) + (unless (listp vars) + (compile-error form "~s is expected to be variable binding syntax" vars)) + (whenlet ((bad (find-if [notf consp] vars))) + (compile-error form "~s isn't a var-initform pair" bad))) -(defmacro sum-each* (vars . body) - (with-gensyms (accum) - ^(let ((,accum 0)) - (each* ,vars - (inc ,accum (progn ,*body))) - ,accum))) +(defmacro sys:arith-each (:form f op-iv vars . body) + (let* ((gens (mapcar (ret (gensym)) vars)) + (syms [mapcar car vars]) + (accum (gensym))) + ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens syms) + (,accum ,(cdr op-iv))) + (block nil + (sys:for-op () + ((and ,*(mapcar (op list 'iter-more) gens)) ,accum) + (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens)) + ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) syms gens) + (set ,accum (,(car op-iv) ,accum (progn ,*body)))))))) -(defmacro mul-each (vars . body) - (with-gensyms (accum) - ^(let ((,accum 1)) - (each ,vars - (set ,accum (* ,accum (progn ,*body)))) - ,accum))) +(defmacro sum-each (:form f vars . body) + (sys:vars-check f vars) + ^(let ,vars + (block nil + (sys:arith-each (+ . 0) ,vars ,*body)))) -(defmacro mul-each* (vars . body) - (with-gensyms (accum) - ^(let ((,accum 1)) - (each* ,vars - (set ,accum (* ,accum (progn ,*body)))) - ,accum))) +(defmacro sum-each* (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (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)))) + +(defmacro mul-each* (:form f vars . body) + (sys:vars-check f vars) + ^(let* ,vars + (block nil + (sys:arith-each (* . 1) ,vars ,*body)))) diff --git a/stdlib/each-prod.tl b/stdlib/each-prod.tl index 1393b80a..d48263f6 100644 --- a/stdlib/each-prod.tl +++ b/stdlib/each-prod.tl @@ -37,13 +37,16 @@ (defun sys:expand-each-prod (form vars body) (sys:vars-check form vars) (let ((syms [mapcar car vars]) - (inits [mapcar cadr vars])) + (inits [mapcar cadr vars]) + (gens [mapcar (ret (gensym)) vars])) (sys:bindable-check form syms) (let ((fun (caseq (car form) (each-prod 'maprodo) (collect-each-prod 'maprod) (append-each-prod 'maprend)))) - ^(,fun (lambda (,*syms) ,*body) ,*inits)))) + ^(let ,(zip gens inits) + (block nil + (,fun (lambda (,*syms) ,*body) ,*gens)))))) (defun sys:expand-each-prod* (form vars body) (sys:vars-check form vars) @@ -61,17 +64,20 @@ (defun sys:expand-arith-each-prod (form vars body) (sys:vars-check form vars) (let ((syms [mapcar car vars]) - (inits [mapcar cadr vars])) + (inits [mapcar cadr vars]) + (gens [mapcar (ret (gensym)) 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))))) + ^(let ((,acc ,(cdr op-iv)) + ,*(zip gens inits)) + (block nil + (maprodo (lambda (,*syms) + (set ,acc (,(car op-iv) ,acc (progn ,*body)))) + ,*gens) + ,acc)))))) (defmacro each-prod (:form f vars . body) (sys:expand-each-prod f vars body)) |