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
