From 75b1508c61d3805d1678a8dabf8d48b9e76c8d37 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 20 Dec 2021 20:46:59 -0800 Subject: product/arithmetic each: missing block nil. * stdlib/arith-each.tl (sys:vars-check): New function, copy and pasted from each-prod.tl. (sys:arith-each): New macro. (sum-each, sum-each*, mul-each, mul-each*): Reworked using sys:arith-each macro. This macro uses logic borrowed from a stripped-down expand-each in the compiler. * stdlib/each-prod.tl (sys:expand-each-prod, sys:expand-arith-each-prod*): Add the block nil around the mapping call, taking care that the initialization forms are evaluated outside of the block, and their values bound to gensyms that then form the function arguments. * txr.1: Document the missing requirements for all the affected macros that there must be an anonymous block around the body, which, if used, determines the return value. --- stdlib/each-prod.tl | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) (limited to 'stdlib/each-prod.tl') 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)) -- cgit v1.2.3