diff options
| -rw-r--r-- | lisplib.c | 18 | ||||
| -rw-r--r-- | share/txr/stdlib/each-prod.tl | 75 | ||||
| -rw-r--r-- | txr.1 | 172 |
3 files changed, 265 insertions, 0 deletions
@@ -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)) @@ -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 *) |