New producting each operator family.

* lisplib.c (each_prod_instantiate, each_prod_set_entries):
New static functions.
(lisplib_init): Register autoload of each-prod.tl via new
functions.

* share/txr/stdlib/each-prod.tl: New file.

* txr.1: Documented. Also, under the existing collect-each
family of operators, added the equivalence to mapping with
lambda to help clarify the semantics.

3 files changed, 265 insertions, 0 deletions

diff --git a/lisplib.c b/lisplib.c
index be28a180..3478cd1c 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -821,6 +821,23 @@ static val copy_file_set_entries(val dlt, val fun)
   return nil;
 }
 
+static val each_prod_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(scat2(stdlib_path, lit("each-prod")));
+  return nil;
+}
+
+static val each_prod_set_entries(val dlt, val fun)
+{
+  val name[] = {
+    lit("each-prod"), lit("collect-each-prod"), lit("append-each-prod"),
+    lit("each-prod*"), lit("collect-each-prod*"), lit("append-each-prod*"),
+    nil
+  };
+  set_dlt_entries(dlt, name, fun);
+  return nil;
+}
 
 val dlt_register(val dlt,
                  val (*instantiate)(val),
@@ -874,6 +891,7 @@ void lisplib_init(void)
   dlt_register(dl_table, save_exe_instantiate, save_exe_set_entries);
   dlt_register(dl_table, defset_instantiate, defset_set_entries);
   dlt_register(dl_table, copy_file_instantiate, copy_file_set_entries);
+  dlt_register(dl_table, each_prod_instantiate, each_prod_set_entries);
 
   reg_fun(intern(lit("try-load"), system_package), func_n1(lisplib_try_load));
 }
diff --git a/share/txr/stdlib/each-prod.tl b/share/txr/stdlib/each-prod.tl
new file mode 100644
index 00000000..67420771
--- /dev/null
+++ b/share/txr/stdlib/each-prod.tl
@@ -0,0 +1,75 @@
+;; Copyright 2020
+;; 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.
+
+(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)))
+
+(defun sys:bindable-check (form syms)
+  (whenlet ((bad (find-if [notf bindable] syms)))
+    (compile-error form "~s isn't a bindable symbol" bad)))
+
+(defun sys:expand-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 ((fun (caseq (car form)
+                 (each-prod 'maprodo)
+                 (collect-each-prod 'maprod)
+                 (append-each-prod 'maprend))))
+      ^(,fun (lambda (,*syms) ,*body) ,*inits))))
+
+(defun sys:expand-each-prod* (form vars body)
+  (sys:vars-check form vars)
+  (let* ((each-prod-op (caseq (car form)
+                         (each-prod* 'each-prod)
+                         (collect-each-prod* 'collect-each-prod)
+                         (append-each-prod* 'append-each-prod)))
+         (syms [mapcar car vars])
+         (inits [mapcar cadr vars]))
+    ^(let* ,vars
+       (,each-prod-op ,(zip syms syms) ,*body))))
+
+(defmacro each-prod (:form f vars . body)
+  (sys:expand-each-prod f vars body))
+
+(defmacro collect-each-prod (:form f vars . body)
+  (sys:expand-each-prod f vars body))
+
+(defmacro append-each-prod (:form f vars . body)
+  (sys:expand-each-prod f vars body))
+
+(defmacro each-prod* (:form f vars . body)
+  (sys:expand-each-prod* f vars body))
+
+(defmacro collect-each-prod* (:form f vars . body)
+  (sys:expand-each-prod* f vars body))
+
+(defmacro append-each-prod* (:form f vars . body)
+  (sys:expand-each-prod* f vars body))
diff --git a/txr.1 b/txr.1
index 5a5c0017..accc3a7c 100644
--- a/txr.1
+++ b/txr.1
@@ -16211,6 +16211,56 @@ iteration, however, the
 variables are assigned the first item from each
 of their lists.
 
+.TP* Note:
+The semantics of
+.code collect-each
+may be understood in terms of an equivalence to a code pattern involving
+.codn mapcar :
+
+.mono
+  (collect-each ((x xinit)        (mapcar (lambda (x y)
+                 (y yinit))  <-->           body)
+    body)                                 xinit yinit)
+.onom
+
+The
+.code collect-each*
+variant may be understood in terms of the following equivalence involving
+.code let*
+for sequential binding and
+.codn mapcar :
+
+.mono
+  (collect-each* ((x xinit)        (let* ((x xinit)
+                  (y yinit))  <-->        (y yinit))
+    body)                            (mapcar (lambda (x y)
+                                                body)
+                                             x y))
+.onom
+
+However, note that the
+.code let*
+as well as each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are permitted
+to bind a single instance of the variables, which are first initialized with
+the initializing expressions, and then re-used as iteration variables which are
+stepped by assignment.
+
+The other operators may be understood likewise, with the substitution
+of the
+.code mapdo
+function in the case of
+.code each
+and
+.code each*
+and of the
+.code mappend
+function in the case of
+.code append-each
+and
+.codn append-each* .
+
 .TP* Example:
 .mono
  ;; print numbers from 1 to 10 and whether they are even or odd
@@ -16500,6 +16550,128 @@ into the
 .meta step-form
 position.
 
+.coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod
+.synb
+.mets (each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (collect-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (append-each-prod >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn each-prod ,
+.code collect-each-prod
+and
+.code append-each-prod
+have a similar syntax to
+.codn each ,
+.code collect-each
+and
+.codn collect-each-prod .
+However, instead of iterating over sequences in parallel, they iterate over
+the Cartesian product of the elements from the sequences.
+The difference between
+.code collect-each
+and
+.code collect-each-prod
+is analogous to that between the functions
+.code mapcar
+and
+.codn maprod .
+
+These macros can be understood as providing syntactic sugar according to the
+pattern established by the following equivalences:
+
+.mono
+  (each-prod               (mapdo (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)
+.onom
+
+However, note that each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are
+permitted to bind a single instance of the variables, which are then stepped by
+assignment.
+
+.TP* Example:
+
+.mono
+  (collect-each-prod ((a '(a b c))
+                      (n #(1 2)))
+    (cons a n))
+
+ --> ((a . 1) (a . 2) (b . 1) (b . 2) (c . 1) (c . 2))
+.onom
+
+.coNP Macros @, each-prod* @ collect-each-prod* and @ append-each-prod*
+.synb
+.mets (each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (collect-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (append-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn each-prod* ,
+.code collect-each-prod*
+and
+.code append-each-prod*
+are variants of
+.codn each-prod* ,
+.code collect-each-prod*
+and
+.code append-each-prod*
+with sequential binding.
+
+These macros can be understood as providing syntactic sugar according to the
+pattern established by the following equivalences:
+
+.mono
+  (each-prod*              (let* ((x xinit)
+    ((x xinit)                    (y yinit))
+     (y yinit))       <-->   (mapdo (lambda (x y) body)
+    body)                           x y)
+
+  (collect-each-prod*      (let* ((x xinit)
+    ((x xinit)                    (y yinit))
+     (y yinit))       <-->   (maprod (lambda (x y) body)
+    body)                            x y)
+
+  (append-each-prod*       (let* ((x xinit)
+    ((x xinit)                    (y yinit))
+     (y yinit))       <-->   (maprend (lambda (x y) body)
+    body)                             x y)
+.onom
+
+However, note that the
+.code let*
+as well as each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are permitted
+to bind a single instance of the variables, which are first initialized with
+the initializing expressions, and then re-used as iteration variables which are
+stepped by assignment.
+
+.TP* Example:
+
+.mono
+  (collect-each-prod* ((a "abc")
+                       (b (upcase-str a)))
+    `@a@b`)
+
+  --> ("aA" "aB" "aC" "bA" "bB" "bC" "cA" "cB" "cC")
+.onom
+
 .coNP Operators @ block and @ block*
 .synb
 .mets (block < name << body-form *)