>From upstream commit 62504e3b5b01615297cf65c33ca76a474bd61dd3.

* module/srfi/srfi-128.scm
* module/srfi/srfi-128/128.body1.scm
* module/srfi/srfi-128/128.body2.scm
* test-suite/tests/srfi-128-test.scm
* test-suite/tests/srfi-128.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-128.scm.
(NOCOMP_SOURCES): Register 128.body1.scm and 128.body2.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI Support): Document it.

---

Changes in v2:
 - Remove string-hash and symbol-hash from exports (they are already
 listed in #:rename)

 am/bootstrap.am                    |   3 +
 doc/ref/srfi-modules.texi          | 552 ++++++++++++++++++++++++++++-
 module/srfi/srfi-128.scm           |  45 +++
 module/srfi/srfi-128/128.body1.scm | 361 +++++++++++++++++++
 module/srfi/srfi-128/128.body2.scm | 146 ++++++++
 test-suite/Makefile.am             |   2 +
 test-suite/tests/srfi-128-test.scm | 321 +++++++++++++++++
 test-suite/tests/srfi-128.test     |  47 +++
 8 files changed, 1476 insertions(+), 1 deletion(-)
 create mode 100644 module/srfi/srfi-128.scm
 create mode 100644 module/srfi/srfi-128/128.body1.scm
 create mode 100644 module/srfi/srfi-128/128.body2.scm
 create mode 100644 test-suite/tests/srfi-128-test.scm
 create mode 100644 test-suite/tests/srfi-128.test

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 04ae9049c..1bf867924 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -348,6 +348,7 @@ SOURCES =                                   \
   srfi/srfi-98.scm                             \
   srfi/srfi-111.scm                            \
   srfi/srfi-126.scm                            \
+  srfi/srfi-128.scm                            \
   srfi/srfi-171.scm                             \
   srfi/srfi-171/gnu.scm                         \
   srfi/srfi-171/meta.scm                        \
@@ -437,6 +438,8 @@ NOCOMP_SOURCES =                            \
   srfi/srfi-42/ec.scm                          \
   srfi/srfi-64/testing.scm                     \
   srfi/srfi-67/compare.scm                     \
+  srfi/srfi-128/128.body1.scm                  \
+  srfi/srfi-128/128.body2.scm                  \
   system/base/lalr.upstream.scm                        \
   system/repl/describe.scm                     \
   sxml/sxml-match.ss                           \
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index e9e012c0e..a6267bd82 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -65,7 +65,8 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-105::                    Curly-infix expressions.
 * SRFI-111::                    Boxes.
 * SRFI-126::                    R6RS-based hash tables.
-* SRFI-171::                    Transducers
+* SRFI-128::                    Comparators.
+* SRFI-171::                    Transducers.
 @end menu
 
 
@@ -6261,6 +6262,555 @@ contents, ignoring case.  This hash function is 
suitable for use with
 Return an integer hash value for @var{symbol}.
 @end deffn
 
+@node SRFI-128
+@subsection Comparators
+@cindex SRFI-128
+@cindex comparators
+
+@uref{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI-128}
+provides comparators, which bundle a @emph{type test predicate}, an
+@emph{equality predicate}, an @emph{ordering predicate}, and a @emph{hash
+function} into a single Scheme object.  By packaging these procedures
+together, they can be treated as a single item for use in the
+implementation of data structures.
+
+@noindent
+The four procedures above have complex dependencies on one another, and
+it is inconvenient to have to pass them individually to other procedures
+that might or might not make use of all of them.  For example, a set
+implementation by its nature requires only an equality predicate, but if
+it is implemented using a hash table, an appropriate hash function is
+also required if the implementation does not provide one; alternatively,
+if it is implemented using a tree, procedures specifying a total order
+are required.  By passing a comparator rather than a bare equality
+predicate, the set implementation can make use of whatever procedures
+are available and useful to it.
+
+@subheading Definitions
+
+A comparator is an object of a disjoint type.  It is a bundle of
+procedures that are useful for comparing two objects in a total order.
+It is an error if any of the procedures have side effects.  There are
+four procedures in the bundle:
+
+@enumerate
+@item
+The @emph{type test predicate} returns @code{#t} if its argument has the
+correct type to be passed as an argument to the other three procedures,
+and @code{#f} otherwise.
+
+@item
+The @emph{equality predicate} returns @code{#t} if the two objects are the
+same in the sense of the comparator, and @code{#f} otherwise.  It is the
+programmer's responsibility to ensure that it is reflexive, symmetric,
+transitive, and can handle any arguments that satisfy the type test
+predicate.
+
+@item
+The @emph{ordering predicate} returns @code{#t} if the first object
+precedes the second in a total order, and @code{#f} otherwise.  Note
+that if it is true, the equality predicate must be false.  It is the
+programmer's responsibility to ensure that it is irreflexive,
+anti-symmetric, transitive, and can handle any arguments that satisfy
+the type test predicate.
+
+@item
+The @emph{hash function} takes an object and returns an exact non-negative
+integer.  It is the programmer's responsibility to ensure that it can
+handle any argument that satisfies the type test predicate, and that it
+returns the same value on two objects if the equality predicate says
+they are the same (but not necessarily the converse).
+@end enumerate
+
+It is also the programmer's responsibility to ensure that all four
+procedures provide the same result whenever they are applied to the same
+object(s) (in the sense of @code{eqv?}), unless the object(s) have been
+mutated since the last invocation.
+
+@subheading Limitations
+
+The comparator objects defined in SRFI 128 are not applicable to
+circular structures or to NaNs, or to objects containing any of these.
+Attempts to pass any such objects to any procedure defined here, or to
+any procedure that is part of a comparator defined here, is an error
+except as otherwise noted.
+
+@menu
+* SRFI-128 Predicates::
+* SRFI-128 Constructors::
+* SRFI-128 Standard hash functions::
+* SRFI-128 Bounds and salt::
+* SRFI-128 Default comparators::
+* SRFI-128 Accessors and Invokers::
+* SRFI-128 Comparison predicates::
+* SRFI-128 Syntax::
+@end menu
+
+@node SRFI-128 Predicates
+@subsubsection SRFI-128 Predicates
+
+@deffn {Scheme Procedure} comparator? obj
+
+Return @code{#t} if @var{obj} is a comparator, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-ordered? comparator
+
+Return @code{#t} if @var{comparator} has a supplied ordering predicate,
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-hashable? comparator
+Return @code{#t} if @var{comparator} has a supplied hash function, and
+@code{#f} otherwise.
+@end deffn
+
+@node SRFI-128 Constructors
+@subsubsection SRFI-128 Constructors
+
+The following comparator constructors all supply appropriate type test
+predicates, equality predicates, ordering predicates, and hash functions
+based on the supplied arguments.  They are allowed to cache their
+results: they need not return a newly allocated object, since
+comparators are pure and functional.  In addition, the procedures in a
+comparator are likewise pure and functional.
+
+@deffn {Scheme Procedure} make-comparator type-test equality ordering hash
+
+Return a comparator which bundles the @var{type-test}, @var{equality},
+@var{ordering}, and @var{hash} procedures provided.  However, if
+@var{ordering} or @var{hash} is @code{#f}, a procedure is provided that
+signals an error on application.  The predicates
+@code{comparator-ordered?}  and/or @code{comparator-hashable?},
+respectively, will return @code{#f} in these cases.
+
+Here are calls on @code{make-comparator} that will return useful
+comparators for standard Scheme types:
+
+@itemize
+@item
+@samp{(make-comparator boolean? boolean=? (lambda (x y) (and (not x) y))
+boolean-hash)} will return a comparator for booleans, expressing the
+ordering @samp{#f < #t} and the standard hash function for booleans.
+
+@item
+@samp{(make-comparator real? = < (lambda (x) (exact (abs x))))} will
+return a comparator expressing the natural ordering of real numbers and
+a plausible (but not optimal) hash function.
+
+@item
+@samp{(make-comparator string? string=? string<? string-hash)} will
+return a comparator expressing the ordering of strings and the standard
+hash function.
+
+@item
+@samp{(make-comparator string? string-ci=? string-ci<? string-ci-hash)}
+will return a comparator expressing the case-insensitive ordering of
+strings and the standard case-insensitive hash function.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-pair-comparator car-comparator cdr-comparator
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument is a pair, if the car
+satisfies the type test predicate of @var{car-comparator}, and the cdr
+satisfies the type test predicate of @var{cdr-comparator}.
+
+@item
+The equality function returns @code{#t} if the cars are equal according
+to @var{car-comparator} and the cdrs are equal according to
+@var{cdr-comparator}, and @code{#f} otherwise.
+
+@item
+The ordering function first compares the cars of its pairs using the
+equality predicate of @var{car-comparator}.  If they are not equal, then
+the ordering predicate of @var{car-comparator} is applied to the cars
+and its value is returned.  Otherwise, the predicate compares the cdrs
+using the equality predicate of @var{cdr-comparator}. If they are not
+equal, then the ordering predicate of @var{cdr-comparator} is applied to
+the cdrs and its value is returned.
+
+@item
+The hash function computes the hash values of the car and the cdr using
+the hash functions of @var{car-comparator} and @var{cdr-comparator}
+respectively and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-list-comparator element-comparator type-test 
empty? head tail
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The total order defined by the equality and ordering functions is as
+follows (known as lexicographic order):
+
+@itemize
+@item
+The empty sequence, as determined by calling @code{empty?}, compares
+equal to itself.
+@item
+The empty sequence compares less than any non-empty sequence.
+@item
+Two non-empty sequences are compared by calling the @var{head} procedure
+on each.  If the heads are not equal when compared using
+@var{element-comparator}, the result is the result of that comparison.
+Otherwise, the results of calling the @var{tail} procedure are compared
+recursively.
+@end itemize
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-vector-comparator element-comparator type-test 
length ref
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The equality predicate returns @code{#t} if both of the following tests
+are satisfied in order: the lengths of the vectors are the same in the
+sense of @code{=}, and the elements of the vectors are the same in the
+sense of the equality predicate of @var{element-comparator}.
+
+@item
+The ordering predicate returns @code{#t} if the results of applying
+@var{length} to the first vector is less than the result of applying
+length to the second vector.  If the lengths are equal, then the
+elements are examined pairwise using the ordering predicate of
+@var{element-comparator}.  If any pair of elements returns @code{#t},
+then that is the result of the list comparator's ordering predicate;
+otherwise the result is @code{#f}.
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+
+Here is an example, which returns a comparator for byte vectors:
+
+@lisp
+(make-vector-comparator
+  (make-comparator exact-integer? = < number-hash)
+  bytevector?
+  bytevector-length
+  bytevector-u8-ref)
+@end lisp
+@end deffn
+
+@deffn  {Scheme Procedure} make-eq-comparator
+@deffnx {Scheme Procedure} make-eqv-comparator
+@deffnx {Scheme Procedure} make-equal-comparator
+
+These procedures return comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} in all cases.
+
+@item
+The equality functions are @code{eq?}, @code{eqv?}, and @code{equal?},
+respectively.
+
+@item
+The ordering function is set @code{#f}, and attempting to use it will
+cause an error with the message @code{"ordering is not supported"}.
+
+@item
+The hash function is @code{default-hash}.
+@end itemize
+@end deffn
+
+@node SRFI-128 Standard hash functions
+@subsubsection SRFI-128 Standard hash functions
+
+These are hash functions for some standard Scheme types, suitable for
+passing to @code{make-comparator}.  Users may write their own hash
+functions with the same signature.  However, if programmers wish their
+hash functions to be backward compatible with the reference
+implementation of @uref{https://srfi.schemers.org/srfi-69/srfi-69.html,
+SRFI 69}, they are advised to write their hash functions to accept a
+second argument and ignore it.
+
+@deffn  {Scheme Procedure} boolean-hash obj
+@deffnx {Scheme Procedure} char-hash obj
+@deffnx {Scheme Procedure} string-hash obj
+@deffnx {Scheme Procedure} string-ci-hash obj
+@deffnx {Scheme Procedure} symbol-hash obj
+@deffnx {Scheme Procedure} number-hash obj
+@end deffn
+
+These are suitable hash functions for the specified types.  The hash
+functions @code{char-ci-hash} and @code{string-ci-hash} treat their
+argument case-insensitively.  Note that while @code{symbol-hash} may
+return the hashed value of applying @code{symbol->string} and then
+@code{string-hash} to the symbol, this is not a requirement.
+
+@node SRFI-128 Bounds and salt
+@subsubsection SRFI-128 Bounds and salt
+
+The following macros allow the callers of hash functions to affect their
+behavior without interfering with the calling signature of a hash
+function, which accepts a single argument (the object to be hashed) and
+returns its hash value.
+
+@deffn {Scheme Syntax} hash-bound
+
+Hash functions should be written so as to return a number between
+@code{0} and the largest reasonable number of elements (such as hash
+buckets) a data structure in the implementation might have.  This value
+is defined as @math{2^25-1} or @code{33554432} in the reference
+implementation used by Guile.  This value provides the current bound as
+a positive exact integer, typically for use by user-written hash
+functions.  However, they are not required to bound their results in
+this way.
+@end deffn
+
+@deffn {Scheme Syntax} hash-salt
+
+A salt is random data in the form of a non-negative exact integer used
+as an additional input to a hash function in order to defend against
+dictionary attacks, or (when used in hash tables) against
+denial-of-service attacks that overcrowd certain hash buckets,
+increasing the amortized O(1) lookup time to O(n).  Salt can also be
+used to specify which of a family of hash functions should be used for
+purposes such as cuckoo hashing.  This macro provides the current value
+of the salt, typically for use by user-written hash functions.  However,
+they are not required to make use of the current salt.
+
+The initial value is implementation-dependent, but must be less than the
+value of @samp{(hash-bound)}, and should be distinct for distinct runs
+of a program unless otherwise specified by the implementation.  In the
+reference implementation used by Guile, the initial salt value is
+@code{16064047}.
+@end deffn
+
+@node SRFI-128 Default comparators
+@subsubsection SRFI-128 Default comparators
+
+@deffn {Scheme Procedure} make-default-comparator
+
+Return a comparator known as a @emph{default comparator} that accepts
+Scheme values and orders them in a way that respects the following
+conditions:
+
+@itemize
+@item
+Given disjoint types @code{a} and @code{b}, one of three conditions must
+hold:
+@itemize
+@item
+All objects of type @code{a} compare less than all objects of type
+@code{b}.
+@item
+All objects of type @code{a} compare greater than all objects of type
+@code{b}.
+@item
+All objects of both type @code{a} and type @code{b} compare equal to
+each other.  This is not permitted for any of the Scheme types mentioned
+below.
+@end itemize
+
+@item
+The empty list must be ordered before all pairs.
+
+@item
+When comparing booleans, it must use the total order @samp{#f < #t}.
+
+@item
+When comparing characters, @code{char=?} and @code{char<?} are used.
+
+@item
+When comparing pairs, it must behave the same as a comparator returned
+by @code{make-pair-comparator} with default comparators as arguments.
+
+@item
+When comparing symbols, the total order produced with @code{symbol<?}
+and @code{symbol<?} is used.
+
+@item
+When comparing bytevectors, it must behave the same as a comparator
+created by the expression @samp{(make-vector-comparator (make-comparator
+bytevector? = < number-hash) bytevector? bytevector-length
+bytevector-u8-ref)}.
+
+@item
+When comparing numbers where either number is complex, since non-real
+numbers cannot be compared with @code{<}, the following least-surprising
+ordering is defined: If the real parts are @code{<} or @code{>}, so are
+the numbers; otherwise, the numbers are ordered by their imaginary
+parts.  This can still produce somewhat surprising results if one real
+part is exact and the other is inexact.
+
+@item
+When comparing real numbers, it must use @code{=} and @code{<}.
+
+@item
+When comparing strings, it must use @code{string=?} and @code{string<?}.
+
+@item
+When comparing vectors, it must behave the same as a comparator returned
+by @samp{(make-vector-comparator (make-default-comparator) vector?
+vector-length vector-ref)}.
+
+@item
+When comparing members of types registered with
+@code{comparator-register-default!}, it must behave in the same way as
+the comparator registered using that function.
+@end itemize
+
+Default comparators use @code{default-hash} as their hash function.
+@end deffn
+
+@deffn {Scheme Procedure} default-hash obj
+
+This is the hash function used by default comparators, which accepts a
+Scheme value and hashes it in a way that respects the following
+conditions:
+
+@itemize
+@item
+When applied to a pair, it must return the result of hashing together
+the values returned by @code{default-hash} when applied to the car and
+the cdr.
+
+@item
+When applied to a boolean, character, string, symbol, or number, it must
+return the same result as @code{boolean-hash}, @code{char-hash},
+@code{string-hash}, @code{symbol-hash}, or @code{number-hash}
+respectively.
+
+@item
+When applied to a list or vector, it must return the result of hashing
+together the values returned by @code{default-hash} when applied to each
+of the elements.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} comparator-register-default! comparator
+
+Register @var{comparator} for use by default comparators, such that if
+the objects being compared both satisfy the type test predicate of
+@var{comparator}, it will be employed by default comparators to compare
+them.  Return an unspecified value.  It is an error if any value
+satisfies both the type test predicate of @var{comparator} and any of
+the following type test predicates: @code{boolean?}, @code{char?},
+@code{null?}, @code{pair?}, @code{symbol?}, @code{bytevector?},
+@code{number?}, @code{string?}, @code{vector?}, or the type test
+predicate of a comparator that has already been registered.
+
+This procedure is intended only to extend default comparators into
+territory that would otherwise be undefined, not to override their
+existing behavior.  In general, the ordering of calls to
+@code{comparator-register-default!} should be irrelevant.
+
+The comparators available from this library are not registered with the
+@code{comparator-register-default!} procedure, because the default
+comparator is meant to be under the control of the program author rather
+than the library author.  It is the program author's responsibility to
+ensure that the registered comparators do not conflict with each other.
+@end deffn
+
+@node SRFI-128 Accessors and Invokers
+@subsubsection SRFI-128 Accessors and Invokers
+
+@deffn  {Scheme Procedure} comparator-type-test-predicate comparator
+@deffnx {Scheme Procedure} comparator-equality-predicate comparator
+@deffnx {Scheme Procedure} comparator-ordering-predicate comparator
+@deffnx {Scheme Procedure} comparator-hash-function comparator
+@end deffn
+
+Return the four procedures of @var{comparator}.
+
+@deffn  {Scheme Procedure} comparator-test-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return what it returns.  More convenient than
+@code{comparator-type-test-predicate}, but less efficient when the
+predicate is called repeatedly.
+@end deffn
+
+@deffn  {Scheme Procedure} comparator-check-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return true if it returns true, but signal an error otherwise.  More
+convenient than @code{comparator-type-test-predicate}, but less
+efficient when the predicate is called repeatedly.
+@end deffn
+
+@deffn  {Scheme Procedure} comparator-hash comparator obj
+
+Invoke the hash function of @var{comparator} on @var{obj} and return
+what it returns.  More convenient than @code{comparator-hash-function},
+but less efficient when the predicate is called repeatedly.
+
+@quotation note
+No invokers are required for the equality and ordering predicates,
+because the @code{=?} and @code{<?} predicates described after serve
+this function.
+@end quotation
+@end deffn
+
+@node SRFI-128 Comparison predicates
+@subsubsection SRFI-128 Comparison predicates
+
+@deffn  {Scheme Procedure} =? comparator object@sub{1} object@sub{2} 
object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <? comparator object@sub{1} object@sub{2} 
object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >? comparator object@sub{1} object@sub{2} 
object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <=? comparator object@sub{1} object@sub{2} 
object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >=? comparator object@sub{1} object@sub{2} 
object@sub{3} @dots{}
+@end deffn
+
+@noindent
+These procedures are analogous to the number, character, and string
+comparison predicates of Scheme.  They allow the convenient use of
+comparators to handle variable data types.
+
+@noindent
+These procedures apply the equality and ordering predicates of
+@var{comparator} to the objects as follows.  If the specified relation
+returns @code{#t} for all @var{object@sub{i}} and @var{object@sub{j}}
+where @var{n} is the number of objects and @math{1 <= @var{i} < @var{j}
+<= @var{n}}, then the procedures return @code{#t}, but otherwise
+@code{#f}.  Because the relations are transitive, it suffices to compare
+each object with its successor.  The order in which the values are
+compared is unspecified.
+
+@node SRFI-128 Syntax
+@subsubsection SRFI-128 Syntax
+
+@deffn {Scheme Procedure} comparator-if<=> [ comparator ] object@sub{1} 
object@sub{2} less-than equal-to greater-than
+
+It is an error unless @var{comparator} evaluates to a comparator and
+@var{object@sub{1}} and @var{object@sub{2}} evaluate to objects that the
+comparator can handle.  If the ordering predicate returns true when
+applied to the values of @var{object@sub{1}} and @var{object@sub{2}} in
+that order, then @var{less-than} is evaluated and its value returned.
+If the equality predicate returns true when applied in the same way,
+then @var{equal-to} is evaluated and its value returned.  If neither
+returns true, @var{greater-than} is evaluated and its value returned.
+
+If @var{comparator} is omitted, a default comparator is used.
+@end deffn
+
 @node SRFI-171
 @subsection Transducers
 @cindex SRFI-171
diff --git a/module/srfi/srfi-128.scm b/module/srfi/srfi-128.scm
new file mode 100644
index 000000000..c339a9557
--- /dev/null
+++ b/module/srfi/srfi-128.scm
@@ -0,0 +1,45 @@
+;;; srfi-128.scm -- SRFI 128 - Comparators.
+;;; Adapted from srfi-128.sld.
+
+;;      Copyright (C) 2023 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-128)
+  #:use-module ((rnrs base) :version (6) #:hide (error))
+  #:use-module (rnrs bytevectors)
+  #:use-module ((rnrs hashtables) #:select (equal-hash))
+  #:use-module ((rnrs unicode) :version (6))
+  #:use-module (srfi srfi-9)
+
+  #:export (comparator?
+            comparator-ordered? comparator-hashable?
+            make-comparator
+            make-pair-comparator make-list-comparator make-vector-comparator
+            make-eq-comparator make-eqv-comparator make-equal-comparator
+            boolean-hash char-hash char-ci-hash
+            string-ci-hash number-hash
+            make-default-comparator default-hash comparator-register-default!
+            comparator-type-test-predicate comparator-equality-predicate
+            comparator-ordering-predicate comparator-hash-function
+            comparator-test-type comparator-check-type comparator-hash
+            hash-bound hash-salt
+            =? <? >? <=? >=?
+            comparator-if<=>)
+
+  #:replace (string-hash symbol-hash))
+
+(include-from-path "srfi/srfi-128/128.body1.scm")
+(include-from-path "srfi/srfi-128/128.body2.scm")
diff --git a/module/srfi/srfi-128/128.body1.scm 
b/module/srfi/srfi-128/128.body1.scm
new file mode 100644
index 000000000..8cb41a2bf
--- /dev/null
+++ b/module/srfi/srfi-128/128.body1.scm
@@ -0,0 +1,361 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;;; Main part of the SRFI 114 reference implementation
+
+;;; "There are two ways of constructing a software design: One way is to
+;;; make it so simple that there are obviously no deficiencies, and the
+;;; other way is to make it so complicated that there are no *obvious*
+;;; deficiencies." --Tony Hoare
+
+;;; Syntax (because syntax must be defined before it is used, contra Dr. 
Hardcase)
+
+;; Arithmetic if
+(define-syntax comparator-if<=>
+  (syntax-rules ()
+    ((if<=> a b less equal greater)
+     (comparator-if<=> (make-default-comparator) a b less equal greater))
+    ((comparator-if<=> comparator a b less equal greater)
+     (cond
+       ((=? comparator a b) equal)
+       ((<? comparator a b) less)
+       (else greater)))))
+
+;; Upper bound of hash functions is 2^25-1
+(define-syntax hash-bound
+  (syntax-rules ()
+    ((hash-bound) 33554432)))
+
+(define %salt% (make-parameter 16064047))
+
+(define-syntax hash-salt
+   (syntax-rules ()
+     ((hash-salt) (%salt%))))
+
+(define-syntax with-hash-salt
+  (syntax-rules ()
+    ((with-hash-salt new-salt hash-func obj)
+     (parameterize ((%salt% new-salt)) (hash-func obj)))))
+
+;;; Definition of comparator records with accessors and basic comparator
+
+(define-record-type comparator
+  (make-raw-comparator type-test equality ordering hash ordering? hash?)
+  comparator?
+  (type-test comparator-type-test-predicate)
+  (equality comparator-equality-predicate)
+  (ordering comparator-ordering-predicate)
+  (hash comparator-hash-function)
+  (ordering? comparator-ordered?)
+  (hash? comparator-hashable?))
+
+;; Public constructor
+(define (make-comparator type-test equality ordering hash)
+  (make-raw-comparator
+    (if (eq? type-test #t) (lambda (x) #t) type-test)
+    (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
+    (if ordering ordering (lambda (x y) (error "ordering not supported")))
+    (if hash hash (lambda (x y) (error "hashing not supported")))
+    (if ordering #t #f)
+    (if hash #t #f)))
+
+;;; Invokers
+
+;; Invoke the test type
+(define (comparator-test-type comparator obj)
+  ((comparator-type-test-predicate comparator) obj))
+
+;; Invoke the test type and throw an error if it fails
+(define (comparator-check-type comparator obj)
+  (if (comparator-test-type comparator obj)
+    #t
+    (error "comparator type check failed" comparator obj)))
+
+;; Invoke the hash function
+(define (comparator-hash comparator obj)
+  ((comparator-hash-function comparator) obj))
+
+;;; Comparison predicates
+
+;; Binary versions for internal use
+
+(define (binary=? comparator a b)
+  ((comparator-equality-predicate comparator) a b))
+
+(define (binary<? comparator a b)
+  ((comparator-ordering-predicate comparator) a b))
+
+(define (binary>? comparator a b)
+  (binary<? comparator b a))
+
+(define (binary<=? comparator a b)
+  (not (binary>? comparator a b)))
+
+(define (binary>=? comparator a b)
+  (not (binary<? comparator a b)))
+
+;; General versions for export
+
+(define (=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary=? comparator a b)
+        (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary<? comparator a b)
+        (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary>? comparator a b)
+        (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary<=? comparator a b)
+        (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary>=? comparator a b)
+        (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+
+;;; Simple ordering and hash functions
+
+(define (boolean<? a b)
+  ;; #f < #t but not otherwise
+  (and (not a) b))
+
+
+(define (boolean-hash obj)
+  (if obj (%salt%) 0))
+
+(define (char-hash obj)
+  (modulo (* (%salt%) (char->integer obj)) (hash-bound)))
+
+(define (char-ci-hash obj)
+  (modulo (* (%salt%) (char->integer (char-foldcase obj))) (hash-bound)))
+
+(define (number-hash obj)
+  (cond
+    ((nan? obj) (%salt%))
+    ((and (infinite? obj) (positive? obj)) (* 2 (%salt%)))
+    ((infinite? obj) (* (%salt%) 3))
+    ((real? obj) (abs (exact (round obj))))
+    (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj))))))
+
+;; Lexicographic ordering of complex numbers
+(define (complex<? a b)
+  (if (= (real-part a) (real-part b))
+    (< (imag-part a) (imag-part b))
+    (< (real-part a) (real-part b))))
+
+(define (string-ci-hash obj)
+    (string-hash (string-foldcase obj)))
+
+(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
+
+(define (symbol-hash obj)
+  (string-hash (symbol->string obj)))
+
+;;; Wrapped equality predicates
+;;; These comparators don't have ordering functions.
+
+(define (make-eq-comparator)
+  (make-comparator #t eq? #f default-hash))
+
+(define (make-eqv-comparator)
+  (make-comparator #t eqv? #f default-hash))
+
+(define (make-equal-comparator)
+  (make-comparator #t equal? #f default-hash))
+
+;;; Sequence ordering and hash functions
+;; The hash functions are based on djb2, but
+;; modulo 2^25 instead of 2^32 in hopes of sticking to fixnums.
+
+(define (make-hasher)
+  (let ((result (%salt%)))
+    (case-lambda
+     (() result)
+     ((n) (set! result (+ (modulo (* result 33) (hash-bound)) n))
+          result))))
+
+;;; Pair comparator
+(define (make-pair-comparator car-comparator cdr-comparator)
+   (make-comparator
+     (make-pair-type-test car-comparator cdr-comparator)
+     (make-pair=? car-comparator cdr-comparator)
+     (make-pair<? car-comparator cdr-comparator)
+     (make-pair-hash car-comparator cdr-comparator)))
+
+(define (make-pair-type-test car-comparator cdr-comparator)
+  (lambda (obj)
+    (and (pair? obj)
+         (comparator-test-type car-comparator (car obj))
+         (comparator-test-type cdr-comparator (cdr obj)))))
+
+(define (make-pair=? car-comparator cdr-comparator)
+   (lambda (a b)
+     (and ((comparator-equality-predicate car-comparator) (car a) (car b))
+          ((comparator-equality-predicate cdr-comparator) (cdr a) (cdr b)))))
+
+(define (make-pair<? car-comparator cdr-comparator)
+   (lambda (a b)
+      (if (=? car-comparator (car a) (car b))
+        (<? cdr-comparator (cdr a) (cdr b))
+        (<? car-comparator (car a) (car b)))))
+
+(define (make-pair-hash car-comparator cdr-comparator)
+   (lambda (obj)
+     (let ((acc (make-hasher)))
+       (acc (comparator-hash car-comparator (car obj)))
+       (acc (comparator-hash cdr-comparator (cdr obj)))
+       (acc))))
+
+;;; List comparator
+
+;; Cheap test for listness
+(define (norp? obj) (or (null? obj) (pair? obj)))
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+   (make-comparator
+     (make-list-type-test element-comparator type-test empty? head tail)
+     (make-list=? element-comparator type-test empty? head tail)
+     (make-list<? element-comparator type-test empty? head tail)
+     (make-list-hash element-comparator type-test empty? head tail)))
+
+
+(define (make-list-type-test element-comparator type-test empty? head tail)
+  (lambda (obj)
+    (and
+      (type-test obj)
+      (let ((elem-type-test (comparator-type-test-predicate 
element-comparator)))
+        (let loop ((obj obj))
+          (cond
+            ((empty? obj) #t)
+            ((not (elem-type-test (head obj))) #f)
+            (else (loop (tail obj)))))))))
+
+(define (make-list=? element-comparator type-test empty? head tail)
+  (lambda (a b)
+    (let ((elem=? (comparator-equality-predicate element-comparator)))
+      (let loop ((a a) (b b))
+        (cond
+          ((and (empty? a) (empty? b) #t))
+          ((empty? a) #f)
+          ((empty? b) #f)
+          ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+          (else #f))))))
+
+(define (make-list<? element-comparator type-test empty? head tail)
+  (lambda (a b)
+    (let ((elem=? (comparator-equality-predicate element-comparator))
+          (elem<? (comparator-ordering-predicate element-comparator)))
+      (let loop ((a a) (b b))
+        (cond
+          ((and (empty? a) (empty? b) #f))
+          ((empty? a) #t)
+          ((empty? b) #f)
+          ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+          ((elem<? (head a) (head b)) #t)
+          (else #f))))))
+
+(define (make-list-hash element-comparator type-test empty? head tail)
+  (lambda (obj)
+    (let ((elem-hash (comparator-hash-function element-comparator))
+          (acc (make-hasher)))
+      (let loop ((obj obj))
+        (cond
+          ((empty? obj) (acc))
+          (else (acc (elem-hash (head obj))) (loop (tail obj))))))))
+
+
+;;; Vector comparator
+
+(define (make-vector-comparator element-comparator type-test length ref)
+     (make-comparator
+       (make-vector-type-test element-comparator type-test length ref)
+       (make-vector=? element-comparator type-test length ref)
+       (make-vector<? element-comparator type-test length ref)
+       (make-vector-hash element-comparator type-test length ref)))
+
+(define (make-vector-type-test element-comparator type-test length ref)
+  (lambda (obj)
+    (and
+      (type-test obj)
+      (let ((elem-type-test (comparator-type-test-predicate 
element-comparator))
+            (len (length obj)))
+        (let loop ((n 0))
+          (cond
+            ((= n len) #t)
+            ((not (elem-type-test (ref obj n))) #f)
+            (else (loop (+ n 1)))))))))
+
+(define (make-vector=? element-comparator type-test length ref)
+   (lambda (a b)
+     (and
+       (= (length a) (length b))
+       (let ((elem=? (comparator-equality-predicate element-comparator))
+             (len (length b)))
+         (let loop ((n 0))
+           (cond
+             ((= n len) #t)
+             ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+             (else #f)))))))
+
+(define (make-vector<? element-comparator type-test length ref)
+   (lambda (a b)
+     (cond
+       ((< (length a) (length b)) #t)
+       ((> (length a) (length b)) #f)
+        (else
+         (let ((elem=? (comparator-equality-predicate element-comparator))
+             (elem<? (comparator-ordering-predicate element-comparator))
+             (len (length a)))
+         (let loop ((n 0))
+           (cond
+             ((= n len) #f)
+             ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+             ((elem<? (ref a n) (ref b n)) #t)
+             (else #f))))))))
+
+(define (make-vector-hash element-comparator type-test length ref)
+  (lambda (obj)
+    (let ((elem-hash (comparator-hash-function element-comparator))
+          (acc (make-hasher))
+          (len (length obj)))
+      (let loop ((n 0))
+        (cond
+          ((= n len) (acc))
+          (else (acc (elem-hash (ref obj n))) (loop (+ n 1))))))))
+
+(define (string-hash obj)
+  (let ((acc (make-hasher))
+        (len (string-length obj)))
+    (let loop ((n 0))
+      (cond
+        ((= n len) (acc))
+        (else (acc (char->integer (string-ref obj n))) (loop (+ n 1)))))))
diff --git a/module/srfi/srfi-128/128.body2.scm 
b/module/srfi/srfi-128/128.body2.scm
new file mode 100644
index 000000000..b424d41b5
--- /dev/null
+++ b/module/srfi/srfi-128/128.body2.scm
@@ -0,0 +1,146 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; The default comparator
+
+;;; Standard comparators and their functions
+
+;; The unknown-object comparator, used as a fallback to everything else
+;; Everything compares exactly the same and hashes to 0
+(define unknown-object-comparator
+  (make-comparator
+    (lambda (obj) #t)
+    (lambda (a b) #t)
+    (lambda (a b) #f)
+    (lambda (obj) 0)))
+
+;; Next index for added comparator
+
+(define first-comparator-index 9)
+(define *next-comparator-index* 9)
+(define *registered-comparators* (list unknown-object-comparator))
+
+;; Register a new comparator for use by the default comparator.
+(define (comparator-register-default! comparator)
+  (set! *registered-comparators* (cons comparator *registered-comparators*))
+  (set! *next-comparator-index* (+ *next-comparator-index* 1)))
+
+;; Return ordinal for object types: null sorts before pairs, which sort
+;; before booleans, etc.  Implementations can extend this.
+;; People who call comparator-register-default! effectively do extend it.
+(define (object-type obj)
+  (cond
+    ((null? obj) 0)
+    ((pair? obj) 1)
+    ((boolean? obj) 2)
+    ((char? obj) 3)
+    ((string? obj) 4)
+    ((symbol? obj) 5)
+    ((number? obj) 6)
+    ((vector? obj) 7)
+    ((bytevector? obj) 8)
+    ; Add more here if you want: be sure to update comparator-index variables
+    (else (registered-index obj))))
+
+;; Return the index for the registered type of obj.
+(define (registered-index obj)
+  (let loop ((i 0) (registry *registered-comparators*))
+    (cond
+      ((null? registry) (+ first-comparator-index i))
+      ((comparator-test-type (car registry) obj) (+ first-comparator-index i))
+      (else (loop (+ i 1) (cdr registry))))))
+
+;; Given an index, retrieve a registered conductor.
+;; Index must be >= first-comparator-index.
+(define (registered-comparator i)
+  (list-ref *registered-comparators* (- i first-comparator-index)))
+
+(define (dispatch-equality type a b)
+  (case type
+    ((0) #t) ; All empty lists are equal
+    ((1) ((make-pair=? (make-default-comparator) (make-default-comparator)) a 
b))
+    ((2) (boolean=? a b))
+    ((3) (char=? a b))
+    ((4) (string=? a b))
+    ((5) (symbol=? a b))
+    ((6) (= a b))
+    ((7) ((make-vector=? (make-default-comparator)
+                         vector? vector-length vector-ref) a b))
+    ((8) ((make-vector=? (make-comparator exact-integer? = < default-hash)
+                         bytevector? bytevector-length bytevector-u8-ref) a b))
+    ; Add more here
+    (else (binary=? (registered-comparator type) a b))))
+
+(define (dispatch-ordering type a b)
+  (case type
+    ((0) 0) ; All empty lists are equal
+    ((1) ((make-pair<? (make-default-comparator) (make-default-comparator)) a 
b))
+    ((2) (boolean<? a b))
+    ((3) (char<? a b))
+    ((4) (string<? a b))
+    ((5) (symbol<? a b))
+    ((6) (complex<? a b))
+    ((7) ((make-vector<? (make-default-comparator) vector? vector-length 
vector-ref) a b))
+    ((8) ((make-vector<? (make-comparator exact-integer? = < default-hash)
+                        bytevector? bytevector-length bytevector-u8-ref) a b))
+    ; Add more here
+    (else (binary<? (registered-comparator type) a b))))
+
+;;; The author of SRFI 128 has suggested a post-finalization note
+;;; saying the first and third bullet items stating "must" requirements
+;;; for default-hash may be weakened.  That allows a much faster hash
+;;; function to be used for lists and vectors.
+
+(define (default-hash obj)
+  (case (object-type obj)
+    ((0 1 7) ; empty list, pair, or vector
+     ((make-hasher) (equal-hash obj)))
+    ((2) (boolean-hash obj))
+    ((3) (char-hash obj))
+    ((4) (string-hash obj))
+    ((5) (symbol-hash obj))
+    ((6) (number-hash obj))
+    ((8) ((make-vector-hash (make-default-comparator)
+                             bytevector? bytevector-length bytevector-u8-ref) 
obj))
+    ; Add more here
+    (else (comparator-hash (registered-comparator (object-type obj)) obj))))
+
+(define (default-ordering a b)
+  (let ((a-type (object-type a))
+        (b-type (object-type b)))
+    (cond
+      ((< a-type b-type) #t)
+      ((> a-type b-type) #f)
+      (else (dispatch-ordering a-type a b)))))
+
+(define (default-equality a b)
+  (let ((a-type (object-type a))
+        (b-type (object-type b)))
+    (if (= a-type b-type) (dispatch-equality a-type a b) #f)))
+
+(define (make-default-comparator)
+  (make-comparator
+    (lambda (obj) #t)
+    default-equality
+    default-ordering
+    default-hash))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index eaa5e1fdb..0fb5827cc 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test               \
            tests/srfi-105.test                 \
            tests/srfi-111.test                 \
             tests/srfi-126.test                        \
+            tests/srfi-128.test                        \
             tests/srfi-171.test                 \
            tests/srfi-4.test                   \
            tests/srfi-9.test                   \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
        tests/rnrs-test-a.scm \
        tests/srfi-64-test.scm \
        tests/srfi-126-test.scm \
+       tests/srfi-128-test.scm \
        ChangeLog-2008
 
 
diff --git a/test-suite/tests/srfi-128-test.scm 
b/test-suite/tests/srfi-128-test.scm
new file mode 100644
index 000000000..2cad04377
--- /dev/null
+++ b/test-suite/tests/srfi-128-test.scm
@@ -0,0 +1,321 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library.  A 'test-begin' call is added.
+(use-modules (rnrs bytevectors)
+             (srfi srfi-64)
+             (srfi srfi-128))
+
+(define-syntax-rule (test arg ...)
+  (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+  (test-end))
+
+(test-begin "comparators")
+;;; END Guile-specific modifications.
+
+(define (print x) (display x) (newline))
+
+(test-group "comparators"
+
+  (define (vector-cdr vec)
+    (let* ((len (vector-length vec))
+           (result (make-vector (- len 1))))
+      (let loop ((n 1))
+        (cond
+          ((= n len) result)
+          (else (vector-set! result (- n 1) (vector-ref vec n))
+                (loop (+ n 1)))))))
+
+  (test '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+  (test '#() (vector-cdr '#(1)))
+
+  (print "default-comparator")
+  (define default-comparator (make-default-comparator))
+  (print "real-comparator")
+  (define real-comparator (make-comparator real? = < number-hash))
+  (print "degenerate comparator")
+  (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+  (print "boolean comparator")
+  (define boolean-comparator
+    (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+  (print "bool-pair-comparator")
+  (define bool-pair-comparator (make-pair-comparator boolean-comparator 
boolean-comparator))
+  (print "num-list-comparator")
+  (define num-list-comparator
+    (make-list-comparator real-comparator list? null? car cdr))
+  (print "num-vector-comparator")
+  (define num-vector-comparator
+    (make-vector-comparator real-comparator vector? vector-length vector-ref))
+  (print "vector-qua-list comparator")
+  (define vector-qua-list-comparator
+    (make-list-comparator
+      real-comparator
+      vector?
+      (lambda (vec) (= 0 (vector-length vec)))
+      (lambda (vec) (vector-ref vec 0))
+      vector-cdr))
+  (print "list-qua-vector-comparator")
+  (define list-qua-vector-comparator
+     (make-vector-comparator default-comparator list? length list-ref))
+  (print "eq-comparator")
+  (define eq-comparator (make-eq-comparator))
+  (print "eqv-comparator")
+  (define eqv-comparator (make-eqv-comparator))
+  (print "equal-comparator")
+  (define equal-comparator (make-equal-comparator))
+  (print "symbol-comparator")
+  (define symbol-comparator
+    (make-comparator
+      symbol?
+      eq?
+      (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+      symbol-hash))
+
+  (test-group "comparators/predicates"
+    (test-assert (comparator? real-comparator))
+    (test-assert (not (comparator? =)))
+    (test-assert (comparator-ordered? real-comparator))
+    (test-assert (comparator-hashable? real-comparator))
+    (test-assert (not (comparator-ordered? degenerate-comparator)))
+    (test-assert (not (comparator-hashable? degenerate-comparator)))
+  ) ; end comparators/predicates
+
+  (test-group "comparators/constructors"
+    (test-assert (=? boolean-comparator #t #t))
+    (test-assert (not (=? boolean-comparator #t #f)))
+    (test-assert (<? boolean-comparator #f #t))
+    (test-assert (not (<? boolean-comparator #t #t)))
+    (test-assert (not (<? boolean-comparator #t #f)))
+
+    (test-assert (comparator-test-type bool-pair-comparator '(#t . #f)))
+    (test-assert (not (comparator-test-type bool-pair-comparator 32)))
+    (test-assert (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+    (test-assert (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+    (test-assert (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+    (test-assert (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+    (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+    (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+    (test-assert (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+    (test-assert (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+    (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+    (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+    (test-assert (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+    (test-assert (comparator-test-type num-vector-comparator '#(1 2 3)))
+    (test-assert (comparator-test-type num-vector-comparator '#()))
+    (test-assert (not (comparator-test-type num-vector-comparator 1)))
+    (test-assert (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+    (test-assert (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+    (test-assert (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+    (test-assert (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+    (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+    (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+    (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+    (test-assert (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+    (test-assert (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+    (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+    (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+    (test-assert (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+    (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+    (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+    (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+    (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+    (test-assert (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+    (test-assert (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+    (define bool-pair (cons #t #f))
+    (define bool-pair-2 (cons #t #f))
+    (define reverse-bool-pair (cons #f #t))
+    (test-assert (=? eq-comparator #t #t))
+    (test-assert (not (=? eq-comparator #f #t)))
+    (test-assert (=? eqv-comparator bool-pair bool-pair))
+    (test-assert (not (=? eqv-comparator bool-pair bool-pair-2)))
+    (test-assert (=? equal-comparator bool-pair bool-pair-2))
+    (test-assert (not (=? equal-comparator bool-pair reverse-bool-pair)))
+  ) ; end comparators/constructors
+
+  (test-group "comparators/hash"
+    (test-assert (exact-integer? (boolean-hash #f)))
+    (test-assert (not (negative? (boolean-hash #t))))
+    (test-assert (exact-integer? (char-hash #\a)))
+    (test-assert (not (negative? (char-hash #\b))))
+    (test-assert (exact-integer? (char-ci-hash #\a)))
+    (test-assert (not (negative? (char-ci-hash #\b))))
+    (test-assert (= (char-ci-hash #\a) (char-ci-hash #\A)))
+    (test-assert (exact-integer? (string-hash "f")))
+    (test-assert (not (negative? (string-hash "g"))))
+    (test-assert (exact-integer? (string-ci-hash "f")))
+    (test-assert (not (negative? (string-ci-hash "g"))))
+    (test-assert (= (string-ci-hash "f") (string-ci-hash "F")))
+    (test-assert (exact-integer? (symbol-hash 'f)))
+    (test-assert (not (negative? (symbol-hash 't))))
+    (test-assert (exact-integer? (number-hash 3)))
+    (test-assert (not (negative? (number-hash 3))))
+    (test-assert (exact-integer? (number-hash -3)))
+    (test-assert (not (negative? (number-hash -3))))
+    (test-assert (exact-integer? (number-hash 3.0)))
+    (test-assert (not (negative? (number-hash 3.0))))
+
+  ) ; end comparators/hash
+
+  (test-group "comparators/default"
+    (test-assert (<? default-comparator '() '(a)))
+    (test-assert (not (=? default-comparator '() '(a))))
+    (test-assert (=? default-comparator #t #t))
+    (test-assert (not (=? default-comparator #t #f)))
+    (test-assert (<? default-comparator #f #t))
+    (test-assert (not (<? default-comparator #t #t)))
+    (test-assert (=? default-comparator #\a #\a))
+    (test-assert (<? default-comparator #\a #\b))
+
+    (test-assert (comparator-test-type default-comparator '()))
+    (test-assert (comparator-test-type default-comparator #t))
+    (test-assert (comparator-test-type default-comparator #\t))
+    (test-assert (comparator-test-type default-comparator '(a)))
+    (test-assert (comparator-test-type default-comparator 'a))
+    (test-assert (comparator-test-type default-comparator (make-bytevector 
10)))
+    (test-assert (comparator-test-type default-comparator 10))
+    (test-assert (comparator-test-type default-comparator 10.0))
+    (test-assert (comparator-test-type default-comparator "10.0"))
+    (test-assert (comparator-test-type default-comparator '#(10)))
+
+    (test-assert (=? default-comparator '(#t . #t) '(#t . #t)))
+    (test-assert (not (=? default-comparator '(#t . #t) '(#f . #t))))
+    (test-assert (not (=? default-comparator '(#t . #t) '(#t . #f))))
+    (test-assert (<? default-comparator '(#f . #t) '(#t . #t)))
+    (test-assert (<? default-comparator '(#t . #f) '(#t . #t)))
+    (test-assert (not (<? default-comparator '(#t . #t) '(#t . #t))))
+    (test-assert (not (<? default-comparator '(#t . #t) '(#f . #t))))
+    (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+    (test-assert (=? default-comparator '#(#t #t) '#(#t #t)))
+    (test-assert (not (=? default-comparator '#(#t #t) '#(#f #t))))
+    (test-assert (not (=? default-comparator '#(#t #t) '#(#t #f))))
+    (test-assert (<? default-comparator '#(#f #t) '#(#t #t)))
+    (test-assert (<? default-comparator '#(#t #f) '#(#t #t)))
+    (test-assert (not (<? default-comparator '#(#t #t) '#(#t #t))))
+    (test-assert (not (<? default-comparator '#(#t #t) '#(#f #t))))
+    (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+    (test-assert (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+    (test-assert (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+    (test-assert (= (comparator-hash default-comparator "t") (string-hash 
"t")))
+    (test-assert (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+    (test-assert (= (comparator-hash default-comparator 10) (number-hash 10)))
+    (test-assert (= (comparator-hash default-comparator 10.0) (number-hash 
10.0)))
+
+    (comparator-register-default!
+      (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda 
(obj) 200)))
+    (test-assert (=? default-comparator (lambda () #t) (lambda () #f)))
+    (test-assert (not (<? default-comparator (lambda () #t) (lambda () #f))))
+    (test 200 (comparator-hash default-comparator (lambda () #t)))
+
+  ) ; end comparators/default
+
+  ;; SRFI 128 does not actually require a comparator's four procedures
+  ;; to be eq? to the procedures originally passed to make-comparator.
+  ;; For interoperability/interchangeability between the comparators
+  ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+  ;; make-comparator may need to be wrapped inside another lambda
+  ;; expression before they're returned by the corresponding accessor.
+  ;;
+  ;; So this next group of tests is incorrect, hence commented out
+  ;; and replaced by a slightly less naive group of tests.
+
+#;
+  (test-group "comparators/accessors"
+    (define ttp (lambda (x) #t))
+    (define eqp (lambda (x y) #t))
+    (define orp (lambda (x y) #t))
+    (define hf (lambda (x) 0))
+    (define comp (make-comparator ttp eqp orp hf))
+    (test ttp (comparator-type-test-predicate comp))
+    (test eqp (comparator-equality-predicate comp))
+    (test orp (comparator-ordering-predicate comp))
+    (test hf (comparator-hash-function comp))
+  ) ; end comparators/accessors
+
+  (test-group "comparators/accessors"
+    (define x1 0)
+    (define x2 0)
+    (define x3 0)
+    (define x4 0)
+    (define ttp (lambda (x) (set! x1 111) #t))
+    (define eqp (lambda (x y) (set! x2 222) #t))
+    (define orp (lambda (x y) (set! x3 333) #t))
+    (define hf (lambda (x) (set! x4 444) 0))
+    (define comp (make-comparator ttp eqp orp hf))
+    (test #t (and ((comparator-type-test-predicate comp) x1)   (= x1 111)))
+    (test #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+    (test #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+    (test #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444)))
+  ) ; end comparators/accessors
+
+  (test-group "comparators/invokers"
+    (test-assert (comparator-test-type real-comparator 3))
+    (test-assert (comparator-test-type real-comparator 3.0))
+    (test-assert (not (comparator-test-type real-comparator "3.0")))
+    (test-assert (comparator-check-type boolean-comparator #t))
+    (test-error (comparator-check-type boolean-comparator 't))
+  ) ; end comparators/invokers
+
+  (test-group "comparators/comparison"
+    (test-assert (=? real-comparator 2 2.0 2))
+    (test-assert (<? real-comparator 2 3.0 4))
+    (test-assert (>? real-comparator 4.0 3.0 2))
+    (test-assert (<=? real-comparator 2.0 2 3.0))
+    (test-assert (>=? real-comparator 3 3.0 2))
+    (test-assert (not (=? real-comparator 1 2 3)))
+    (test-assert (not (<? real-comparator 3 1 2)))
+    (test-assert (not (>? real-comparator 1 2 3)))
+    (test-assert (not (<=? real-comparator 4 3 3)))
+    (test-assert (not (>=? real-comparator 3 4 4.0)))
+
+  ) ; end comparators/comparison
+
+  (test-group "comparators/syntax"
+    (test 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+    (test 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+    (test 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 
'greater))
+    (test 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+    (test 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+    (test 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+  ) ; end comparators/syntax
+
+  (test-group "comparators/bound-salt"
+    (test-assert (exact-integer? (hash-bound)))
+    (test-assert (exact-integer? (hash-salt)))
+    (test-assert (< (hash-salt) (hash-bound)))
+  ) ; end comparators/bound-salt
+
+) ; end comparators
+
+(test-exit)
diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test
new file mode 100644
index 000000000..a6a447767
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,47 @@
+;;;; srfi-128.test --- Test suite for SRFI-128.  -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 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-128)
+  #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-128))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+  (let ((runner (test-runner-null)))
+    (test-runner-on-test-end! runner
+      (lambda (runner)
+        (let* ((result-alist (test-result-alist runner))
+               (result-kind (assq-ref result-alist 'result-kind))
+               (test-name (list (assq-ref result-alist 'test-name))))
+          (case result-kind
+            ((pass)  (report 'pass     test-name))
+            ((xpass) (report 'upass    test-name))
+            ((skip)  (report 'untested test-name))
+            ((fail xfail)
+             (apply report result-kind test-name result-alist))
+            (else #t)))))
+    runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-128-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
-- 
2.41.0


Reply via email to