diff options
| -rw-r--r-- | stdlib/arith-each.tl | 63 | ||||
| -rw-r--r-- | stdlib/each-prod.tl | 22 | ||||
| -rw-r--r-- | txr.1 | 69 |
3 files changed, 91 insertions, 63 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)) @@ -17714,21 +17714,11 @@ the variable bindings, exactly the way 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 +The +.metn body-form s +are enclosed in an implicit anonymous block. If the forms terminate +by returning from the anonymous block then these macros terminate +with the specified value. .coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod .synb @@ -17758,24 +17748,36 @@ is analogous to that between the functions and .codn maprod . -These macros can be understood as providing syntactic sugar according to the -pattern established by the following equivalences: +Like in the +.code each +operator family, the +.metn body-form s +are surrounded by an anonymous block. If these forms execute a return from +this block, then these macros terminate with the specified return value. + +With one caveat noted below, these macros can be understood as providing +syntactic sugar according to the pattern established by the following +equivalences: .mono - (each-prod (maprodo (lambda (x y) - ((x xinit) body) - (y yinit)) <--> xinit - body) yinit) - - (collect-each-prod (maprod (lambda (x y) - ((x xinit) body) - (y yinit)) <--> xinit - body) yinit) - - (append-each-prod (maprend (lambda (x y) - ((x xinit) body) - (y yinit)) <--> xinit - body) yinit) + (each-prod (block nil + ((x xinit) (let ((#:gx xinit) (#:gy yinit)) + (y yinit)) <--> (maprodo (lambda (x y) + body) body) + #:gx #:gy)) + + (collect-each-prod (block nil + ((x xinit) (let ((#:gx xinit) (#:gy yinit)) + (y yinit)) <--> (maprod (lambda (x y) + body) body) + #:gx #:gy)) + + + (append-each-prod (block nil + ((x xinit) (let ((#:gx xinit) (#:gy yinit)) + (y yinit)) <--> (maprend (lambda (x y) + body) body) + #:gx #:gy)) .onom However, note that each invocation of the @@ -17880,6 +17882,11 @@ values of the variables, similarly to the .code each* operator. +The +.metn body-form s +are surrounded by an implicit anonymous block. If these forms execute a return +from this block, then these macros terminate with the specified return value. + .TP* Examples: .verb |