[PATCH] Add srfi-235: Combinators.

[PATCH] Add srfi-235: Combinators.

[Janneke Nieuwenhuizen]

Imported reference implementation, test, and documentation from
<https://srfi.schemers.org/srfi-235/srfi-235.html>.

* module/srfi/srfi-235.scm: New file.
* am/bootstrap.am (SOURCES): Register it.
* test-suite/tests/srfi-235.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Register it.
* doc/ref/srfi-modules.texi (SRFI-235): Document it.
---
 am/bootstrap.am                |   1 +
 doc/ref/srfi-modules.texi      | 477 +++++++++++++++++++++++++++++++-
 module/srfi/srfi-235.scm       | 311 +++++++++++++++++++++
 test-suite/Makefile.am         |   3 +-
 test-suite/tests/srfi-235.test | 485 +++++++++++++++++++++++++++++++++
 5 files changed, 1274 insertions(+), 3 deletions(-)
 create mode 100644 module/srfi/srfi-235.scm
 create mode 100644 test-suite/tests/srfi-235.test

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 9e5fca0db..74df9e9e6 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -351,6 +351,7 @@ SOURCES =					\
   srfi/srfi-171.scm                             \
   srfi/srfi-171/gnu.scm                         \
   srfi/srfi-171/meta.scm                        \
+  srfi/srfi-235.scm                             \
 						\
   statprof.scm					\
 						\
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 02da3e2f2..9e88a92ad 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
+@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020, 2024
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -65,7 +65,8 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-105::                    Curly-infix expressions.
 * SRFI-111::                    Boxes.
 * SRFI-119::                    Wisp: simpler indentation-sensitive Scheme.
-* SRFI-171::                    Transducers
+* SRFI-171::                    Transducers.
+* SRFI-235::                    Combinators.
 @end menu
 
 
@@ -6179,6 +6180,478 @@ The generator version of list-reduce.  It reduces over @code{gen} until
 it returns the EOF object
 @end deffn
 
+
+@node SRFI-235
+@subsection Combinators
+@cindex SRFI-235
+@cindex combinators
+
+@uref{https://srfi.schemers.org/srfi-235/srfi-235.html, SRFI-235}
+provides various procedures that accept and return procedures, as well
+as a few others, drawn from
+@uref{https://wiki.call-cc.org/eggref/4/combinators,an earlier version
+of Chicken}.  Common Lisp has a few of them too, and more come from
+@uref{https://programmingpraxis.com/contents/standard-prelude/,the
+Standard Prelude from @emph{Programming Praxis}}.  Using these
+procedures helps to keep code terse and reduce the need for ad hoc
+lambdas.
+
+@menu
+* SRFI-235 Rationale::
+* SRFI-235 Specification::
+* SRFI-235 Syntax-like procedures::
+* SRFI-235 Other procedures::
+@end menu
+
+@node SRFI-235 Rationale
+@section Rationale
+@anchor{#rationale}
+Many procedures such as @code{map}, @code{filter}, @code{fold}, and
+their equivalents for data structures other than lists accept an
+argument specifying the behavior to be performed on each element of the
+data structure.  This can be done in one of two ways:
+
+@itemize
+@item
+The code uses a @code{lambda} to describe the needed behavior
+@item
+The code is placed in an internal or external @code{define}, which
+requires finding a good name and splits the action into different
+locations, making the code harder to read.
+@end itemize
+
+Those composition procedures, called @emph{combinators}, have been
+identified by the Scheme and Common Lisp communities as reducing such
+fragmentation while keeping the code dense.
+
+@node SRFI-235 Specification
+@section Specification
+@anchor{#specification}
+
+@deffn {Scheme Procedure} (constantly obj @dots{}) arg @dots{}
+
+Return the @emph{objs} as its values, ignoring @emph{args}.
+
+@example
+(map (constantly 3) '(1 2 3)) => (3 3 3)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} (complement proc) obj
+
+Return @code{#t} when @code{(}@emph{proc obj}@code{)} returns
+@code{#f}, and @code{#f} otherwise.
+
+@example
+(map (complement (lambda (x) #f)) '(1 2 3)) => (#t #t #t)
+(map (complement (lambda (x) 3)) '(1 2 3)) => (#f #f #f)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} (flip proc) . objs
+
+Return what @code{(apply}@ @emph{proc} @code{(reverse}@ @emph{objs}
+@code{)} returns.
+
+@example
+((flip list) 1 2 3) => (3 2 1)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} (swap proc) . obj₁ obj₂ . objs
+
+Return @code{(apply}@ @emph{proc obj₂ obj₁ objs}@code{)}.
+
+@example
+((swap cons) 1 2) => (2 . 1)
+@end example
+@end deffn
+
+@deffn (Scheme Procedure) (on-left proc) obj₁ obj₂
+
+Return (@emph{proc obj₁}).
+
+@example
+(map (on-left list) '(1 2 3) '(4 5 6)) => '((1) (2) (3))
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (on-right proc) obj₁ obj₂
+
+Return (@emph{proc obj₂}).
+
+@example
+(map (on-right list) '(1 2 3) '(4 5 6)) => '((4) (5) (6))
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (conjoin predicate @dots{} arg @dots{}
+
+The @emph{predicates} are applied in turn to the @emph{args} as follows:
+If a call to a predicate returns false, no more predicates are applied
+and @code{#f} is returned.  If all predicates return true, then the last
+value is returned.  If there are no predicates, @code{#t} is returned.
+
+@example
+(map (conjoin even? exact?) '(1.0 1 2.0 2)) => '(#f #f #f #t)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (disjoin predicate @dots{} arg @dots{}
+
+The @emph{predicates} are applied in turn to the @emph{args} as follows:
+If a call to a predicate returns true, no more predicates are applied
+and its value is returned.  If all predicates return false, then the last
+value is returned.  If there are no predicates, @code{#f} is returned.
+
+@example
+(map (disjoin even? exact?) '(1.0 1 2.0 2)) => '(#f #t #t #t)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (each-of proc @dots{} arg @dots{}
+
+Applies each of the @emph{procs} in turn to @emph{args}, discarding the
+results and returning an unspecified value.
+
+@example
+(define (print-sum . numbers)
+  (display
+    (string-join (map number->string numbers)
+                 "+" 'infix))
+  (newline))
+
+(define (print-product . numbers)
+  (display
+    (string-join (map number->string numbers)
+                 "*" 'infix))
+  (newline))
+
+((each-of print-sum print-product) 1 2 3) => undefined ;prints:
+1+2+3
+1*2*3
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (all-of predicate) list
+
+Applies @emph{predicate} to each element of @emph{list} in turn, and
+immediately returns @code{#f} if @emph{predicate} is not satisfied by
+that element.  If every element satisfies @emph{predicate}, returns the
+result of the last call to @emph{predicate}.  If @emph{list} is empty,
+returns @code{#t}.
+
+@example
+((all-of even?) '(2 4 6)) => #t
+((all-of odd?) '(1 2 3)) => #f
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (any-of predicate) list
+
+Applies @emph{predicate} to each element of @emph{list} in turn, and if
+@emph{predicate} is satisfied by that element, immediately returns the
+result of calling @emph{predicate}.  If no element satisfies
+@emph{predicate} returns @code{#f}.  If @emph{list} is empty, returns
+@code{#f}.
+
+@example
+((any-of even?) '(2 4 5)) => #t
+((any-of odd?) '(2 4 6)) => #f
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (on reducer mapper) obj₁ obj @dots{}
+
+Applies @emph{mapper} to each @emph{obj} in any order and then applies
+@emph{reducer} to all of the results in left to right order.
+
+@example
+((on + -) 1 2 3) => -6
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (left-section proc arg @dots{} obj @dots{}
+
+Applies @emph{proc} to @emph{args} concatenated with @emph{objs}.
+
+@example
+(map (left-section - 1) '(1 2 3)) => (0 -1 -2)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (right-section proc arg @dots{} obj @dots{}
+
+Applies @emph{proc} to @emph{objs} concatenated with the value of
+@code{(reverse}@ @emph{args}@code{)}.
+
+@example
+(map (right-section - 1) '(1 2 3)) => (0 1 2)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (apply-chain@ proc₁ proc @dots{} arg @dots{}`
+
+Applies the last @emph{proc} to @emph{args} returning zero or more
+values, then applies the previous @emph{proc} to the values, returning
+more values, until the first proc has been invoked; its values are
+returned.  For example, @code{(apply-chain car cdr)} returns a procedure
+that behaves like @code{cadr}:
+
+@example
+(map (apply-chain car cdr) '((1 2 3) (4 5 6))) => (2 5)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (arguments-drop proc n) arg @dots{}@*
+@deffnx (Scheme procedure) (arguments-drop-right proc n) arg @dots{}@*
+@deffnx (Scheme procedure) (arguments-take proc n) arg @dots{}@*
+@deffnx (Scheme procedure) (arguments-take-right proc n) arg @dots{}
+
+Apply @emph{proc} to the @emph{args} after taking/dropping @emph{n}
+arguments from @emph{args}.
+
+@example
+(apply (arguments-drop + 2) '(1 2 3 4 5)) => 12
+(apply (arguments-drop-right + 2) '(1 2 3 4 5)) => 6
+(apply (arguments-take + 2) '(1 2 3 4 5)) => 3
+(apply (arguments-take-right + 2) '(1 2 3 4 5)) => 9
+@end example
+@end deffn
+
+@deffn (Scheme procedure) (group-by key-proc [=]) list
+
+Takes the elements of @emph{list} and applies @emph{key-proc} to each of
+them to get their keys.  Elements whose keys are the same (in the sense
+of =, which defaults to @code{equal?}) are grouped into newly allocated
+lists, and a list of these lists is returned.  Within each list, the
+elements appear in the same order as they do in @emph{list}; in
+addition, the first elements of each list also appear in the same order
+as they do in @emph{list}.  If @emph{list} is the empty list, it is
+returned.
+
+@example
+((group-by car) '((1 2 3) (2 2 3) (1 4 5))) =>
+  (((1 2 3) (1 4 5))
+   ((2 2 3))
+@end example
+@end deffn
+
+@node SRFI-235 Syntax-like procedures
+@section Syntax-like procedures
+@anchor{#syntax-like-procedures}
+These are Scheme procedures that correspond to basic syntax.  As usual in
+Lisps, @emph{thunk} means a procedure that does not require arguments.
+
+The following procedures are understood to be defined in this section:
+
+@example
+  (define (a) (display #\a))
+  (define (b) (display #\b))
+  (define (c) (display #\c))
+  (define (z) (display #\z))
+@end example
+
+@deffn (Scheme procedure) begin-procedure thunk @dots{}
+
+Invokes @emph{thunks} in order, and returns what the last thunk returns,
+or an unspecified value if there are no thunks.
+
+@example
+(begin-procedure a b c) => unspecified (displays "abc")
+@end example
+@end deffn
+
+@deffn (Scheme procedure) if-procedure value then-thunk else-thunk
+
+If @emph{value} is true, invokes @emph{then-thunk} and returns what it
+returns.  Otherwise, invokes @emph{else-thunk} and returns what it
+returns.
+
+@example
+(if-procedure #t (lambda () 1) (lambda () 2)) => 1
+(if-procedure #f (lambda () 1) (lambda () 2)) => 2
+@end example
+@end deffn
+
+@deffn (Scheme procedure) when-procedure value thunk @dots{}
+@deffnx (Scheme procedure) unless-procedure value thunk @dots{}
+
+If @emph{value} is false/true, immediately returns.  Otherwise, invokes
+each @emph{thunk} in turn and then returns.  In all cases an unspecified
+value is returned.
+
+@example
+(when-procedure #t a b c) => unspecified ;prints "abc"
+(when-procedure #f a b c) => unspecified ;prints nothing
+(unless-procedure #t a b c) => unspecified ;prints nothing
+(unless-procedure #f a b c) => unspecified ;prints "abc"
+@end example
+@end deffn
+
+@deffn (Scheme procedure) value-procedure value then-proc else-thunk
+
+If @emph{value} is true, invokes @emph{then-proc} on it and returns what
+@emph{then-proc} returns.  Otherwise, invokes @emph{else-thunk} and
+returns what it returns.
+
+@example
+(value-procedure 2 (lambda (x) (+ x 1)) (lambda () 0)) => 3)
+(value-procedure #f (lambda (x) (+ x 1)) (lambda () 0)) => 0)
+@end example
+@end deffn
+
+@deffn (Scheme procedure) case-procedure value thunk-alist [ else-thunk
+
+Searches @emph{thunk-alist} for @emph{value} (as if by @code{assv}).  If
+there is a matching entry in @emph{thunk-alist}, its cdr is invoked as a
+thunk, and @code{case-procedure} returns what the thunk returns.  If
+there is no such entry in @emph{thunk-alist}, invokes @emph{else-thunk}
+(if present) and returns what it returns.  If @emph{else-thunk} is not
+present, the result is undefined.
+
+@example
+(case-procedure 0 `((1 . ,a) (2 . ,z) (3 . ,c)) z) => undefined ;displays "z"
+(case-procedure 0 `((1 . ,a) (2 . ,z) (3 . ,c))) => undefined ;displays nothing
+(case-procedure 2 `((1 . ,a) (2 . ,b) (3 . ,c))) => undefined ;displays "b"
+@end example
+@end deffn
+
+@deffn (Scheme procedure) and-procedure thunk @dots{}
+
+The thunks are invoked from left to right, and if any thunk returns
+false, then @code{#f} is returned.  Any remaining thunks are not invoked.
+If all the thunks return true values, the values of the last thunk are
+returned.  If there are no thunks, then @code{#t} is returned.
+
+@example
+(and-procedure
+  (lambda () #t)
+  (lambda () #f)
+  (lambda () (error "fail"))) => #f
+@end example
+@end deffn
+
+@deffn (Scheme procedure) eager-and-procedure@ thunk @dots{}
+
+All the thunks are invoked from left to right.  If any thunk returns
+false, then @code{#f} is returned.  If all the thunks return true values,
+the value of the last thunk is returned.  If there are no thunks, then
+@code{#t} is returned.
+
+@example
+(eager-and-procedure
+  (lambda () #t)
+  (lambda () #f)
+  (lambda () (error "fail"))) => error
+@end example
+@end deffn
+
+@deffn (Scheme procedure) or-procedure thunk @dots{}
+
+The thunks are invoked from left to right, and the first true value is
+returned.  Any remaining thunks are not invoked.  If all thunks return
+@code{#f} or if there are no thunks, then @code{#f} is returned.
+
+@example
+(or-procedure
+  (lambda () #t)
+  (lambda () #f)
+  (lambda () (error "fail"))) => #t
+@end example
+@end deffn
+
+@deffn (Scheme procedure) eager-or-procedure@ thunk @dots{}
+
+All the thunks are invoked from left to right, and then the first true
+value is returned.  If all thunks return @code{#f} or if there are no
+thunks, then @code{#f} is returned.
+
+@example
+(eager-or-procedure
+  (lambda () #t)
+  (lambda () #f)
+  (lambda () (error "fail"))) => error
+@end example
+@end deffn
+
+@deffn (Scheme procedure) funcall-procedure thunk
+
+Invokes @emph{thunk} once, and returns what it returns.  Note that the
+name @code{funcall} is derived from Common Lisp.
+
+@code{(loop-procedure}@ @emph{thunk}@code{)}
+
+Invokes @emph{thunk} repeatedly.  Does not return unless via
+@code{call/cc}.
+
+@example
+(loop-procedure (lambda () (a) (b))) => ; #displays "abab@dots{}" forever
+@end example
+@end deffn
+
+@deffn (Scheme procedure) while-procedure@ thunk
+
+Invokes @emph{thunk} repeatedly until it returns false.  Return an
+unspecified value.
+
+@example
+(let ((i 0))
+    (while-procedure
+      (lambda ()
+    (display i)
+    (set! i (+ i 1))
+    (< i 10)))) => unspecified ;prints "0123456789"
+@end example
+@end deffn
+
+@deffn (Scheme procedure until-procedure thunk
+
+Invokes @emph{thunk} repeatedly until it returns true.  Return an
+unspecified value.
+
+@example
+(let ((i 10))
+  (until-procedure
+    (lambda ()
+      (set! i (- i 1))
+      (display i)
+       (> i 0)))) => unspecified ;prints "9876543210"
+@end example
+@end deffn
+
+@node SRFI-235 Other procedures
+@section Other procedures
+@anchor{#other-procedures}
+
+@deffn (Scheme procedure) always@ obj @dots{}
+
+Ignores its arguments and always returns @code{#t}.
+
+@example
+(always 1 2 3) => #t
+@end example
+@end deffn
+
+@deffn (Scheme procedure never obj @dots{}
+
+Ignores its arguments and always returns @code{#f}.
+
+@example
+(never 1 2 3) => #f
+@end example
+@end deffn
+
+@deffn boolean obj
+
+If @emph{obj} is true, returns @code{#t}; otherwise returns @code{#f}.
+
+@example
+(boolean 3) => #t
+(boolean #f) => #f
+@end example
+@end deffn
+
 @c srfi-modules.texi ends here
 
 @c Local Variables:
diff --git a/module/srfi/srfi-235.scm b/module/srfi/srfi-235.scm
new file mode 100644
index 000000000..25cca6edd
--- /dev/null
+++ b/module/srfi/srfi-235.scm
@@ -0,0 +1,311 @@
+;;; srfi-235.scm -- SRFI 235 Combinators
+
+;;      Copyright (C) 2024 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-235)
+  #:use-module (srfi srfi-1)
+  #:export (constantly
+            complement
+            swap
+            flip
+            on-left
+            on-right
+            conjoin
+            disjoin
+            each-of
+            all-of
+            any-of
+            on
+            left-section
+            right-section
+            apply-chain
+            arguments-drop
+            arguments-drop-right
+            arguments-take
+            arguments-take-right
+            group-by
+
+            begin-procedure
+            if-procedure
+            when-procedure
+            unless-procedure
+            value-procedure
+            case-procedure
+            and-procedure
+            eager-and-procedure
+            or-procedure
+            eager-or-procedure
+            funcall-procedure
+            loop-procedure
+            while-procedure
+            until-procedure
+
+            always
+            never
+            boolean))
+
+(cond-expand-provide (current-module) '(srfi-235))
+
+(define (constantly . args)
+  (lambda ignored-args
+    (apply values args)))
+
+(define (complement proc)
+  (lambda (obj)
+    (not (proc obj))))
+
+(define (swap proc)
+  (lambda (obj1 obj2 . rest)
+    (apply proc obj2 obj1 rest)))
+
+(define (flip proc)
+  (lambda args
+    (apply proc (reverse args))))
+
+(define (on-left proc)
+  (lambda (obj1 obj2)
+    (proc obj1)))
+
+(define (on-right proc)
+  (lambda (obj1 obj2)
+    (proc obj2)))
+
+(define (conjoin . predicates)
+  (case-lambda
+    (() #t)
+    (args (let loop-args ((args args))
+            (or (null? args)
+                (let ((arg (car args)))
+                  (let loop-preds ((predicates predicates))
+                    (cond
+                     ((null? predicates) (loop-args (cdr args)))
+                     ((not ((car predicates) arg)) #f)
+                     (else (loop-preds (cdr predicates)))))))))))
+
+(define (disjoin . predicates)
+  (case-lambda
+    (() #t)
+    (args (let loop-args ((args args))
+            (or (null? args)
+                (let ((arg (car args)))
+                  (let loop-preds ((predicates predicates))
+                    (cond
+                     ((null? predicates) #f)
+                     (((car predicates) arg) (loop-args (cdr args)))
+                     (else (loop-preds (cdr predicates)))))))))))
+
+(define (each-of . procs)
+  (lambda args
+    (for-each
+     (lambda (proc) (apply proc args))
+     procs)))
+
+(define (all-of predicate)
+  (lambda (lst)
+    (let loop ((lst lst)
+               (last #t))
+      (cond
+       ((null? lst) last)
+       ((predicate (car lst)) => (lambda (value)
+                                   (loop (cdr lst) value)))
+       (else #f)))))
+
+(define (any-of predicate)
+  (lambda (lst)
+    (and (not (null? lst))
+         (let loop ((lst lst))
+           (cond
+            ((null? lst) #f)
+            ((predicate (car lst)))
+            (else (loop (cdr lst))))))))
+
+(define (on reducer mapper)
+  (lambda objs
+    (apply reducer (map mapper objs))))
+
+(define (left-section proc . args)
+  (lambda objs
+    (apply proc (append args objs))))
+
+(define (right-section proc . args)
+  (let ((args-reverse (reverse args)))
+    (lambda objs
+      (apply proc (append objs args-reverse)))))
+
+(define (apply-chain . procs)
+  (define procs/rev (reverse procs))
+  (lambda args
+    (let loop ((values-provider (lambda () (apply values args)))
+               (procs procs/rev))
+      (if (null? procs)
+          (values-provider)
+          (loop (lambda ()
+                  (call-with-values
+                    values-provider
+                    (car procs)))
+                (cdr procs))))))
+
+(define (arguments-drop/take proc drop/take n)
+  (lambda args
+    (apply proc (drop/take args n))))
+
+(define (arguments-drop proc n)
+  (arguments-drop/take proc drop n))
+
+(define (arguments-drop-right proc n)
+  (arguments-drop/take proc drop-right n))
+
+(define (arguments-take proc n)
+  (arguments-drop/take proc take n))
+
+(define (arguments-take-right proc n)
+  (arguments-drop/take proc take-right n))
+
+(define group-by
+  (case-lambda
+    ((key-proc) (group-by key-proc equal?))
+    ((key-proc =)
+     (lambda (lst)
+       (let loop ((lst lst)
+                  (mapping-alist '()))
+         (cond
+           ((null? lst)
+            (reverse
+              (map
+                (lambda (entry)
+                  (reverse (cdr entry)))
+                mapping-alist)))
+           (else
+            (let* ((value (car lst))
+                   (key (key-proc value)))
+              (cond
+               ((assoc key mapping-alist =)
+                =>
+                (lambda (entry)
+                  (set-cdr! entry (cons value (cdr entry)))
+                  (loop (cdr lst)
+                        mapping-alist)))
+               (else (loop (cdr lst)
+                           (cons (cons key (list value))
+                                 mapping-alist))))))))))))
+
+(define (begin-procedure . thunks)
+  (let loop ((value (if #f #f))
+             (thunks thunks))
+    (if (null? thunks)
+        value
+        (loop ((car thunks))
+              (cdr thunks)))))
+
+(define (if-procedure value then-thunk else-thunk)
+  (if value
+      (then-thunk)
+      (else-thunk)))
+
+(define (when-procedure value . thunks)
+  (when value
+    (for-each
+     (lambda (fn) (fn))
+     thunks)))
+
+(define (unless-procedure value . thunks)
+  (unless value
+    (for-each
+     (lambda (fn) (fn))
+     thunks)))
+
+(define (value-procedure value then-proc else-thunk)
+  (if value
+      (then-proc value)
+      (else-thunk)))
+
+(define case-procedure
+  (case-lambda
+    ((value thunk-alist)
+     (case-procedure value thunk-alist (lambda args (if #f #f))))
+    ((value thunk-alist else-thunk)
+     (cond
+      ((assv value thunk-alist) => (lambda (entry)
+                                     ((cdr entry))))
+      (else (else-thunk))))))
+
+(define and-procedure
+  (case-lambda
+    (() #t)
+    (thunks (let loop ((thunks thunks))
+              (cond
+               ((null? (cdr thunks)) ((car thunks)))
+               ((not ((car thunks))) #f)
+               (else (loop (cdr thunks))))))))
+
+(define eager-and-procedure
+  (case-lambda
+    (() #t)
+    (thunks (let loop ((thunks thunks)
+                       (result #t))
+              (cond
+               ((null? (cdr thunks)) (let ((r ((car thunks))))
+                                      (and result r)))
+               ((not ((car thunks))) (loop (cdr thunks) #f))
+               (else (loop (cdr thunks) result)))))))
+
+(define or-procedure
+  (case-lambda
+    (() #f)
+    (thunks (let loop ((thunks thunks))
+              (cond
+               ((null? thunks) #f)
+               (((car thunks)) => values)
+               (else (loop (cdr thunks))))))))
+
+(define eager-or-procedure
+  (case-lambda
+    (() #f)
+    (thunks (let loop ((thunks thunks)
+                       (result #f))
+              (cond
+               ((null? thunks) result)
+               (((car thunks)) => (lambda (res)
+                                    (loop (cdr thunks)
+                                          (or result
+                                              res))))
+               (else (loop (cdr thunks) result)))))))
+
+(define (funcall-procedure thunk)
+  (thunk))
+
+(define (loop-procedure thunk)
+  (thunk)
+  (loop-procedure thunk))
+
+(define (while-procedure thunk)
+  (if (thunk)
+      (while-procedure thunk)
+      #f))
+
+(define (until-procedure thunk)
+  (define v (thunk))
+  (if v
+      v
+      (until-procedure thunk)))
+
+(define (always . args) #t)
+
+(define (never . args) #f)
+
+(define (boolean obj)
+  (if obj #t #f))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 247d97746..f83c942d9 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-## Copyright 2001-2020, 2023 Software Foundation, Inc.
+## Copyright 2001-2020, 2023, 2024 Software Foundation, Inc.
 ##
 ## This file is part of GUILE.
 ##
@@ -164,6 +164,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-111.test			\
 	    tests/srfi-119.test			\
 	    tests/srfi-171.test			\
+	    tests/srfi-235.test			\
 	    tests/srfi-4.test			\
 	    tests/srfi-9.test			\
 	    tests/statprof.test			\
diff --git a/test-suite/tests/srfi-235.test b/test-suite/tests/srfi-235.test
new file mode 100644
index 000000000..535488605
--- /dev/null
+++ b/test-suite/tests/srfi-235.test
@@ -0,0 +1,485 @@
+;;;; srfi-235.test --- Test suite for SRFI-235 Combinators. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2024 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-235)
+  ;; #:use-module (test-suite lib)
+  ;; #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-235))
+
+(test-begin "Combinators")
+
+(test-group
+ "constantly"
+
+ (test-equal '(1 2)
+   (call-with-values
+       (lambda () ((constantly 1 2) 'a 'b))
+     list))
+
+ (test-equal '(1)
+   (call-with-values
+       (lambda () ((constantly 1) 'a 'b))
+     list))
+
+ (test-equal '()
+   (call-with-values
+       (lambda () ((constantly) 'a 'b))
+     list)))
+
+
+(test-group
+ "complement"
+
+ (test-equal #f
+   ((complement symbol?) 'a))
+
+ (test-equal #t
+   ((complement symbol?) 1)))
+
+
+(test-group
+ "swap"
+
+ (test-equal '(2 1 3 4)
+   ((swap list) 1 2 3 4)))
+
+
+(test-group
+ "flip"
+
+ (test-equal '(4 3 2 1)
+   ((flip list) 1 2 3 4)))
+
+
+(test-group
+ "on-left"
+
+ (test-equal '(1)
+   ((on-left list) 1 2)))
+
+
+(test-group
+ "on-right"
+
+ (test-equal '(2)
+   ((on-right list) 1 2)))
+
+
+(test-group
+ "conjoin"
+
+ (test-assert
+     ((conjoin number? exact?)))
+
+ (test-assert
+     ((conjoin number? exact?) 1 2))
+
+ (test-assert
+     (not ((conjoin number? exact?) 1 2.)))
+
+ (test-assert
+     ((conjoin) 1 2)))
+
+
+(test-group
+ "disjoin"
+
+ (test-assert
+     ((disjoin number? string?)))
+
+ (test-assert
+     ((disjoin number? string?) 1 "a"))
+
+ (test-assert
+     (not ((disjoin number? string?) 'a 'b)))
+
+ (test-assert
+     (not ((disjoin) 1 2))))
+
+
+(test-group
+ "each-of"
+
+ (let ((r1 #f)
+       (r2 #f))
+   ((each-of
+     (lambda args (set! r1 args))
+     (lambda args (set! r2 args)))
+    1 2)
+   (test-equal r1 '(1 2))
+   (test-equal r2 '(1 2))))
+
+
+(test-group
+ "all-of"
+
+ (test-assert
+     ((all-of string?) '()))
+
+ (test-assert
+     ((all-of string?) '("a" "b")))
+
+ (test-equal
+   "b"
+   ((all-of values) '("a" "b")))
+
+ (test-assert
+     (not ((all-of string?) '("a" b))))
+
+ (test-assert
+     (not ((all-of (lambda (x)
+                     (when (equal? x 'c)
+                       ;; should short circuit before this point
+                       (test-assert #f))
+                     (string? x)))
+           '("a" b c)))))
+
+
+(test-group
+ "any-of"
+
+ (test-assert
+     (not ((any-of string?) '())))
+
+ (test-assert
+     ((any-of string?) '("a" b)))
+
+ (test-equal
+   "a"
+   ((any-of values) '("a" "b")))
+
+ (test-assert
+     (not ((any-of string?) '(a b))))
+
+ (test-assert
+     ((any-of (lambda (x)
+                (when (equal? x 'b)
+                  ;; should short circuit before this point
+                  (test-assert #f))
+                (string? x)))
+      '("a" b))))
+
+
+(test-group
+ "on"
+
+ (test-equal '(2 3 4)
+   ((on list (lambda (x) (+ 1 x))) 1 2 3)))
+
+
+(test-group
+ "left-section"
+
+ (test-equal '(1 2 3 4)
+   ((left-section list 1 2) 3 4)))
+
+
+(test-group
+ "right-section"
+
+ (test-equal '(3 4 2 1)
+   ((right-section list 1 2) 3 4)))
+
+
+(test-group
+  "apply-chain"
+  (define cadr* (apply-chain car cdr))
+  (define factorial ;;test multivalue
+    (apply-chain
+      *
+      (lambda (n) (apply values (cdr (iota (+ 1 n)))))))
+
+  (test-equal 2 (cadr* (list 1 2 3)))
+  (test-equal 120 (factorial 5)))
+
+
+(test-group
+  "arguments-drop"
+
+  (test-equal
+    '(4)
+    ((arguments-drop list 3) 1 2 3 4)))
+
+
+(test-group
+  "arguments-drop-right"
+
+  (test-equal
+    '(1)
+    ((arguments-drop-right list 3) 1 2 3 4)))
+
+
+(test-group
+  "arguments-take"
+
+  (test-equal
+    '(1 2 3)
+    ((arguments-take list 3) 1 2 3 4)))
+
+
+(test-group
+  "arguments-take-right"
+
+  (test-equal
+    '(2 3 4)
+    ((arguments-take-right list 3) 1 2 3 4)))
+
+
+(test-group
+  "group-by"
+
+  (test-equal
+    '((1 3)
+      (2 4))
+    ((group-by odd?) '(1 2 3 4)))
+
+  (test-equal
+    '(("aa" "ab")
+      ("ba" "bb"))
+    ((group-by (lambda (str) (string-ref str 0))
+               char=?)
+     (list "aa" "ba" "bb" "ab"))))
+
+
+(test-group
+ "begin-procedure"
+
+ (test-equal 2
+   (begin-procedure
+    (lambda () 1)
+    (lambda () 2))))
+
+
+(test-group
+ "if-procedure"
+
+ (test-equal 1
+   (if-procedure #t
+                 (lambda () 1)
+                 (lambda () (test-assert #f))))
+
+ (test-equal 2
+   (if-procedure #f
+                 (lambda () (test-assert #f))
+                 (lambda () 2))))
+
+
+(test-group
+ "when-procedure"
+
+ (define lst1 '())
+ (define lst2 '())
+
+ (when-procedure #t
+                 (lambda () (set! lst1 (cons 1 lst1)))
+                 (lambda () (set! lst1 (cons 2 lst1))))
+
+ (when-procedure #f
+                 (lambda () (set! lst2 (cons 1 lst2)))
+                 (lambda () (set! lst2 (cons 2 lst2))))
+
+ (test-equal '(2 1) lst1)
+ (test-equal '() lst2))
+
+
+(test-group
+ "unless-procedure"
+
+ (define lst1 '())
+ (define lst2 '())
+
+ (unless-procedure #t
+                 (lambda () (set! lst1 (cons 1 lst1)))
+                 (lambda () (set! lst1 (cons 2 lst1))))
+
+ (unless-procedure #f
+                 (lambda () (set! lst2 (cons 1 lst2)))
+                 (lambda () (set! lst2 (cons 2 lst2))))
+
+ (test-equal '() lst1)
+ (test-equal '(2 1) lst2))
+
+
+(test-group
+ "value-procedure"
+
+ (test-equal "1"
+   (value-procedure 1
+                    number->string
+                    (lambda () (test-assert #f))))
+
+ (test-equal 2
+   (value-procedure #f
+                    (lambda args (test-assert #f))
+                    (lambda () 2))))
+
+
+(test-group
+ "case-procedure"
+
+ (test-equal 2
+   (case-procedure 'b
+                   `((a . ,(lambda () 1))
+                     (b . ,(lambda () 2)))))
+
+ (test-equal 3
+   (case-procedure 'c
+                   `((a . ,(lambda () 1))
+                     (b . ,(lambda () 2)))
+                   (lambda () 3))))
+
+
+(test-group
+ "and-procedure"
+
+ (test-assert
+     (and-procedure))
+
+ (test-equal 2
+   (and-procedure (lambda () 1)
+                       (lambda () 2)))
+
+ (test-assert
+     (not (and-procedure (lambda () #f)
+                              (lambda () (test-assert #f))))))
+
+
+(test-group
+ "eager-and-procedure"
+
+ (test-assert
+     (eager-and-procedure))
+
+ (test-equal 2
+   (eager-and-procedure (lambda () 1)
+                        (lambda () 2)))
+
+ (let ((second-called? #f))
+  (test-assert
+     (not (eager-and-procedure (lambda () #f)
+                               (lambda ()
+                                 (set! second-called? #t)
+                                 #t))))
+  (test-assert second-called?)))
+
+
+(test-group
+ "or-procedure"
+
+ (test-assert
+     (not (or-procedure)))
+
+ (test-equal 2
+   (or-procedure (lambda () #f)
+                 (lambda () 2)))
+
+ (test-assert
+     (or-procedure (lambda () 1)
+                   (lambda () (test-assert #f)))))
+
+
+(test-group
+ "eager-or-procedure"
+
+ (test-assert
+     (not (eager-or-procedure)))
+
+ (test-equal 2
+   (eager-or-procedure (lambda () #f)
+                       (lambda () 2)))
+
+ (let ((second-called? #f))
+  (test-equal 1
+     (eager-or-procedure (lambda () 1)
+                        (lambda ()
+                          (set! second-called? #t)
+                          #f)))
+  (test-assert second-called?)))
+
+(test-group
+ "funcall-procedure"
+
+ (test-equal 1
+    (funcall-procedure (lambda () 1))))
+
+(test-group
+ "loop-procedure"
+
+ (call/cc (lambda (k)
+            (define v 0)
+            (define (thunk)
+              (when (> v 5)
+                (k #t))
+              (set! v (+ 1 v)))
+            (loop-procedure thunk)
+            (test-assert #t))))
+
+
+(test-group
+ "while-procedure"
+
+ (define v 0)
+ (define (thunk)
+   (set! v (+ 1 v))
+   (< v 5))
+ (while-procedure thunk)
+ (test-equal 5 v))
+
+
+(test-group
+ "until-procedure"
+
+ (define v 0)
+ (define (thunk)
+   (set! v (+ 1 v))
+   (>= v 5))
+ (until-procedure thunk)
+ (test-equal 5 v))
+
+
+(test-group
+ "always"
+
+ (test-assert (always))
+ (test-assert (always 'a)))
+
+
+(test-group
+ "never"
+
+ (test-assert (not (never)))
+ (test-assert (not (never 'a))))
+
+
+
+(test-group
+ "boolean"
+
+ (test-equal #t (boolean 1))
+ (test-equal #f (boolean #f)))
+
+
+(test-group
+ "values"
+
+ (test-equal 1 (values 1))
+ (test-equal 'a (values 'a)))
+
+
+(test-end)
-- 
2.45.1

Re: [PATCH] Add srfi-235: Combinators.

[Janneke Nieuwenhuizen]

Janneke Nieuwenhuizen writes:

I already changed the passive "Returns" to "Return"...

> +Invokes @emph{thunks} in order, and returns what the last thunk returns,
> +or an unspecified value if there are no thunks.

but missed these...

    s/Invokes/Invoke/g
    s/returns/return/g

changed locally.

-- 
Janneke Nieuwenhuizen <janneke@gnu.org>  | GNU LilyPond https://LilyPond.org
Freelance IT https://www.JoyOfSource.com | Avatar® https://AvatarAcademy.com