unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v8 12/16] module: Add SRFI 125.
Date: Wed,  6 Dec 2023 18:15:08 -0500	[thread overview]
Message-ID: <20231206231512.6505-13-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231206231512.6505-1-maxim.cournoyer@gmail.com>

* module/srfi/srfi-125.scm
* module/srfi/srfi-125/hash-table.scm
* test-suite/tests/srfi-125-test.scm
* test-suite/tests/srfi-125.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-125.scm.
(NOCOMP_SOURCES): Register hash-table.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI-125): Document it.
* NEWS: Update news.

---

(no changes since v7)

Changes in v7:
 - Register prerequisites for srfi/srfi-125.go in am/bootstrap.am

Changes in v5:
 - Update NEWS

Changes in v4:
 - Mention Expat license of SRFI 125 in guile.tex copying section
 - Rename srfi-125.scm to srfi-125.sld and use upstream copy
 - Streamline import of (srfi srfi-125)
 - Use R7RS 'import' for srfi-125-test.scm

Changes in v3:
 - Add menu entries.
 - Rename SRFI-125 to SRFI 125 in text
 - Rename included file to upstream name (125.body.scm)
 - Add copyright/license header 125.body.scm

 NEWS                               |   1 +
 am/bootstrap.am                    |   3 +
 doc/ref/guile.texi                 |   2 +-
 doc/ref/srfi-modules.texi          | 603 +++++++++++++++++++
 module/srfi/srfi-125.sld           |  96 ++++
 module/srfi/srfi-125/125.body.scm  | 589 +++++++++++++++++++
 test-suite/Makefile.am             |   2 +
 test-suite/tests/srfi-125-test.scm | 890 +++++++++++++++++++++++++++++
 test-suite/tests/srfi-125.test     |  45 ++
 9 files changed, 2230 insertions(+), 1 deletion(-)
 create mode 100644 module/srfi/srfi-125.sld
 create mode 100644 module/srfi/srfi-125/125.body.scm
 create mode 100644 test-suite/tests/srfi-125-test.scm
 create mode 100644 test-suite/tests/srfi-125.test

diff --git a/NEWS b/NEWS
index 614a2bc7f..b7099673d 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,7 @@ the compiler reports it as "possibly unused".
 ** Add (srfi 128), a comparators library
 ** Add (scheme comparator)
 ** Add (scheme sort)
+** Add (srfi 125), a mutators library
 
 * Bug fixes
 
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 17e70bff8..8c25500d6 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -67,6 +67,7 @@ srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-9.go srfi/srfi-9/gnu.go \
 		  srfi/srfi-11.go
 srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
 scheme/comparator.go: srfi/srfi-128.go
+srfi/srfi-125.go: srfi/srfi-126.go srfi/srfi-128.go
 
 # All sources.  We can compile these in any order; the order below is
 # designed to hopefully result in the lowest total compile time.
@@ -357,6 +358,7 @@ SOURCES =					\
   srfi/srfi-88.scm				\
   srfi/srfi-98.scm				\
   srfi/srfi-111.scm				\
+  srfi/srfi-125.sld				\
   srfi/srfi-126.scm				\
   srfi/srfi-128.sld				\
   srfi/srfi-171.scm                             \
@@ -450,6 +452,7 @@ NOCOMP_SOURCES =				\
   srfi/srfi-42/ec.scm				\
   srfi/srfi-64/testing.scm			\
   srfi/srfi-67/compare.scm			\
+  srfi/srfi-125/125.body.scm			\
   srfi/srfi-128/128.body1.scm			\
   srfi/srfi-128/128.body2.scm			\
   system/base/lalr.upstream.scm			\
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f71d9a22c..e10916948 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,7 +24,7 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
 copy of the license is included in the section entitled ``GNU Free
 Documentation License.''
 
-Additionally, the documentation of the 126 and 128 SRFI modules is
+Additionally, the documentation of the 125, 126, and 128 SRFI modules is
 adapted from their specification text, which is made available under the
 following Expat license:
 
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 40ca7a2e7..3c276dfb0 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -66,6 +66,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-98::                     Accessing environment variables.
 * SRFI-105::                    Curly-infix expressions.
 * SRFI-111::                    Boxes.
+* SRFI 125::                    Mutators.
 * SRFI 126::                    R6RS-based hash tables.
 * SRFI 128::                    Comparators.
 * SRFI-171::                    Transducers.
@@ -5666,6 +5667,608 @@ Return the current contents of @var{box}.
 Set the contents of @var{box} to @var{value}.
 @end deffn
 
+@node SRFI 125
+@subsection SRFI 125 Intermediate hash tables
+@cindex SRFI 125
+@cindex hash tables
+
+This SRFI defines an interface to hash tables, which are widely
+recognized as a fundamental data structure for a wide variety of
+applications.  A hash table is a data structure that:
+
+@itemize
+@item
+Is disjoint from all other types.
+
+@item
+Provides a mapping from objects known as keys to corresponding objects
+known as values.
+@itemize
+@item
+Keys may be any Scheme objects in some kinds of hash tables, but are
+restricted in other kinds.
+@item
+Values may be any Scheme objects.
+@end itemize
+
+@item
+Has no intrinsic order for the key-value associations it contains.
+
+@item
+Provides an equality predicate which defines when a proposed key is the
+same as an existing key.  No table may contain more than one value for a
+given key.
+
+@item
+Provides a hash function which maps a candidate key into a non-negative
+exact integer.
+
+@item
+Supports mutation as the primary means of setting the contents of a
+table.
+
+@item
+Provides key lookup and destructive update in (expected) amortized
+constant time, provided a satisfactory hash function is available.
+
+@item
+Does not guarantee that whole-table operations work in the presence of
+concurrent mutation of the whole hash table (values may be safely
+mutated).
+@end itemize
+
+@menu
+* SRFI 125 Rationale::
+* SRFI 125 Constructors::
+* SRFI 125 Predicates::
+* SRFI 125 Accessors::
+* SRFI 125 Mutators::
+* SRFI 125 The whole hash table::
+* SRFI 125 Mapping and folding::
+* SRFI 125 Copying and conversion::
+* SRFI 125 Hash tables as sets::
+* SRFI 125 Hash functions and reflectivity::
+@end menu
+
+@node SRFI 125 Rationale
+@subsubsection SRFI 125 Rationale
+
+Hash tables themselves don't really need defending: almost all
+dynamically typed languages, from awk to JavaScript to Lua to Perl to
+Python to Common Lisp, and including many Scheme implementations,
+provide them in some form as a fundamental data structure.  Therefore,
+what needs to be defended is not the data structure but the procedures.
+This SRFI is at an intermediate level.  It supports a great many
+convenience procedures on top of the basic hash table interfaces
+provided by SRFI 69 and R6RS.  Nothing in it adds power to what those
+interfaces provide, but it does add convenience in the form of
+pre-debugged routines to do various common things, and even some things
+not so commonly done but useful.
+
+There is no mandated support for thread safety, immutability, or
+weakness, though there are portable hooks for specifying these features.
+
+While the specification of this SRFI accepts separate equality
+predicates and hash functions for backward compatibility, it strongly
+encourages the use of SRFI 128 comparators, which package a type test,
+an equality predicate, and a hash function into a single bundle.
+
+@subheading SRFI 69 compatibility
+
+This SRFI is downward compatible with SRFI 69.  Some procedures have
+been given new preferred names for compatibility with other SRFIs, but
+in all cases the SRFI 69 names have been retained as deprecated
+synonyms; in Guile, these deprecated procedures have their name prefixed
+with @code{deprecated:}.
+
+There is one absolute incompatibility with SRFI 69: the reflective
+procedure @code{hash-table-hash-function} may return @code{#f}, which is
+not permitted by SRFI 69.
+
+@subheading R6RS compatibility
+
+The relatively few hash table procedures in R6RS are all available in
+this SRFI under somewhat different names.  The only substantive
+difference is that R6RS @code{hashtable-values} and
+@code{hashtable-entries} return vectors, whereas in this SRFI
+@code{hash-table-value} and @code{hash-table-entries} return lists.
+This SRFI adopts SRFI 69's term hash-table rather than R6RS's hashtable,
+because of the universal use of ``hash table'' rather than ``hashtable''
+in other computer languages and in technical prose generally.  Besides,
+the English word hashtable obviously means something that can be@dots{}
+hashted.
+
+In addition, the @code{hashtable-ref} and @code{hashtable-update!} of
+R6RS correspond to the @code{hash-table-ref/default} and
+@code{hash-table-update!/default} of both SRFI 69 and this SRFI.
+
+@subheading Common Lisp compatibility
+
+As usual, the Common Lisp names are completely different from the Scheme
+names.  Common Lisp provides the following capabilities that are
+@emph{not} in this SRFI:
+
+@itemize
+@item
+The constructor allows specifying the rehash size and rehash threshold
+of the new hash table.  There are also accessors and mutators for these
+and for the current capacity (as opposed to size).
+
+@item
+There are hash tables based on @code{equalp} (which does not exist in
+Scheme).
+
+@item
+@code{with-hash-table-iterator} is a hash table external iterator
+implemented as a local macro.
+
+@item
+@code{sxhash} is an implementation-specific hash function for the equal
+predicate.  It has the property that objects in different instantiations
+of the same Lisp implementation that are similar, a concept analogous to
+e@code{qual} but defined across all instantiations, always return the
+same value from @code{sxhash}; for example, the symbol @code{xyz} will
+have the same @code{sxhash} result in all instantiations.
+@end itemize
+
+@subheading Sources
+
+The procedures in this SRFI are drawn primarily from SRFI 69 and
+R6RS.  In addition, the following sources are acknowledged:
+
+@itemize
+@item
+The @code{hash-table-mutable?} procedure and the second argument of
+@code{hash-table-copy} (which allows the creation of immutable hash
+tables) are from R6RS, renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-intern!} procedure is from
+@url{https://docs.racket-lang.org/reference/hashtables.html, Racket},
+renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-find} procedure is a modified version of
+@code{table-search} in Gambit.
+
+@item
+The procedures @code{hash-table-unfold} and @code{hash-table-count} were
+suggested by SRFI-1.
+
+@item
+The procedures @code{hash-table=?} and @code{hash-table-map} were
+suggested by Haskell's @code{Data.Map.Strict} module.
+
+@item
+The procedure @code{hash-table-map->list} is from Guile.
+@end itemize
+
+The procedures @code{hash-table-empty?,} @code{hash-table-empty-copy,
+hash-table-pop!,} @code{hash-table-map!,}
+@code{hash-table-intersection!, hash-table-difference!,} and
+@code{hash-table-xor!} were added for convenience and completeness.
+
+The native hash tables of MIT, SISC, Bigloo, Scheme48, SLIB, RScheme,
+Scheme 7, Scheme 9, Rep, and FemtoLisp were also investigated, but no
+additional procedures were incorporated.
+
+@subheading Pronunciation
+
+The slash in the names of some procedures can be pronounced ``with''.
+
+@node SRFI 125 Constructors
+@subsubsection SRFI 125 Constructors
+
+@deffn {Scheme Procedure}  make-hash-table comparator [ arg @dots{} ]
+@deffnx {Scheme Procedure} make-hash-table equality-predicate [ hash-function ] [ arg @dots{} ])
+
+Return a newly allocated hash table whose equality predicate and hash
+function are extracted from comparator.  Alternatively, for backward
+compatibility with SRFI 69 the equality predicate and hash function can
+be passed as separate arguments; this usage is deprecated.
+
+These procedures relate to R6RS @code{make-eq-hashtable},
+@code{make-eqv-hashtable} and @code{make-hashtable} ones, and
+@code{make-hash-table} from Common Lisp.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table comparator [ key value ] @dots{}
+
+Return a newly allocated hash table, created as if by
+@code{make-hash-table} using @var{comparator}.  For each pair of
+arguments, an association is added to the new hash table with @var{key}
+as its key and @var{value} as its value.  This procedure returns an
+immutable hash table.  If the same key (in the sense of the equality
+predicate) is specified more than once, it is an error.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-unfold stop? mapper successor seed comparator arg @dots{}
+
+Create a new hash table as if by @var{make-hash-table} using
+@var{comparator} and the @var{args}.  If the result of applying the
+predicate @code{stop?} to @var{seed} is true, return the hash table.
+Otherwise, apply the procedure @var{mapper} to @var{seed}.  @var{mapper}
+returns two values, which are inserted into the hash table as the key
+and the value respectively.  Then get a new seed by applying the
+procedure @var{successor} to @var{seed}, and repeat this algorithm.
+@end deffn
+
+@deffn  {Scheme Procedure} alist->hash-table alist comparator arg @dots{}
+@deffnx {Scheme Procedure} alist->hash-table alist equality-predicate [ hash-function ] arg @dots{}
+
+Return a newly allocated hash table as if by @code{make-hash-table}
+using @var{comparator} and the @var{args}.  It is then initialized from
+the associations of @var{alist}.  Associations earlier in the list take
+precedence over those that come later.  The second form is for
+compatibility with SRFI 69, and is deprecated.
+@end deffn
+
+@node SRFI 125 Predicates
+@subsubsection SRFI 125 Predicates
+
+@deffn {Scheme Procedure} hash-table? obj
+
+Return @code{#t} if @var{obj} is a hash table, and @code{#f} otherwise.
+(R6RS @code{hashtable?}; Common Lisp @code{hash-table-p})
+@end deffn
+
+@deffn  {Scheme Procedure} hash-table-contains? hash-table key
+@deffnx {Scheme Procedure} hash-table-exists? hash-table key
+
+Return @code{#t} if there is any association to key in @var{hash-table},
+and @code{#f} otherwise.  Execute in amortized constant time.  The
+@code{hash-table-exists?} procedure is the same as
+@code{hash-table-contains?}; it is provided for backward compatibility
+with SRFI 69, and is deprecated. (R6RS @code{hashtable-contains?})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty? hash-table
+
+Return @code{#t} if @var{hash-table} contains no associations, and
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table=? value-comparator hash-table@sub{1} hash-table@sub{2}
+
+Return @code{#t} if @var{hash-table@sub{1}} and @var{hash-table@sub{2}}
+have the same keys (in the sense of their common equality predicate) and
+each key has the same value (in the sense of @var{value-comparator)},
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-mutable? hash-table
+
+Return @code{#t} if @var{hash-table} is mutable.  (R6RS
+@code{hashtable-mutable?})
+@end deffn
+
+@node SRFI 125 Accessors
+@subsubsection SRFI 125 Accessors
+
+The following procedures, given a key, return the corresponding value.
+
+@deffn {Scheme Procedure} hash-table-ref hash-table key [ failure [ success ] ]
+
+Extract the value associated to key in @var{hash-table}, invoke the
+procedure success on it, and return its result; if @var{success} is not
+provided, then the value itself is returned.  If @var{key} is not
+contained in @var{hash-table} and @var{failure} is supplied, then
+@var{failure} is called with no arguments and its result is returned.
+Otherwise, it is an error.  Execute in expected amortized constant time,
+not counting the time to call the procedures.  SRFI 69 does not support
+the @var{success} procedure.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-ref/default hash-table key default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-ref @var{hash-table} @var{key} (lambda () @var{default}))
+@end lisp
+
+(R6RS @code{hashtable-ref}; Common Lisp @code{gethash})
+@end deffn
+
+@node SRFI 125 Mutators
+@subsubsection SRFI 125 Mutators
+
+The following procedures alter the associations in a hash table either
+unconditionally, or conditionally on the presence or absence of a
+specified key.  It is an error to add an association to a hash table
+whose key does not satisfy the type test predicate of the comparator
+used to create the hash table.
+
+@deffn {Scheme Procedure} hash-table-set! hash-table arg @dots{}
+
+Repeatedly mutates @code{hash-table}, creating new associations in it by
+processing the arguments from left to right.  The @var{args} alternate
+between keys and values.  Whenever there is a previous association for a
+key, it is deleted.  It is an error if the type check procedure of the
+comparator of @var{hash-table}, when invoked on a key, does not return
+@code{#t}.  Likewise, it is an error if a key is not a valid argument to
+the equality predicate of @var{hash-table}.  Return an unspecified
+value.  Execute in expected amortized constant time per key.
+SRFI 69, R6RS @code{hashtable-set!} and Common Lisp (@samp{setf
+gethash}) do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-delete! hash-table key @dots{}
+
+Delete any association to each key in @var{hash-table} and returns the
+number of keys that had associations.  Execute in expected amortized
+constant time per key.  SRFI 69, R6RS @code{hashtable-delete!}, and
+Common Lisp @var{remhash} do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intern! hash-table key failure
+
+Effectively invoke @code{hash-table-ref} with the given arguments and
+return what it returns.  If @var{key} was not found in @var{hash-table},
+its value is set to the result of calling @var{failure}.  Execute in
+expected amortized constant time.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update! hash-table key updater [ failure [ success ] ]
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref @var{hash-table} @var{key} @var{failure} @var{success})))
+@end lisp
+
+Execute in expected amortized constant time.  Return an unspecified
+value.  (SRFI 69 and R6RS @code{hashtable-update!} do not support
+the @var{success} procedure)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update!/default hash-table key updater default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref/default @var{hash-table} @var{key} @var{default})))
+@end lisp
+
+Execute in expected amortized constant time.  Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-pop! hash-table
+
+Choose an arbitrary association from @var{hash-table} and removes it,
+returning the key and value as two values.  It is an error if
+@var{hash-table} is empty.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-clear! hash-table
+Delete all the associations from @var{hash-table}.  (R6RS
+@code{hashtable-clear!}; Common Lisp @code{clrhash}.)
+@end deffn
+
+@node SRFI 125 The whole hash table
+@subsubsection SRFI 125 The whole hash table
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-size hash-table
+
+Return the number of associations in @var{hash-table} as an exact
+integer.  Execute in constant time.  (R6RS @code{hashtable-size}; Common
+Lisp @code{hash-table-count}.)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-keys hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}.  R6RS
+@code{hashtable-keys} returns a vector.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-values hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-entries hash-table
+
+Return two values, a newly allocated list of all the keys in
+@var{hash-table} and a newly allocated list of all the values in
+@var{hash-table} in the corresponding order.  R6RS
+@code{hash-table-entries} returns vectors.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-find proc hash-table failure
+
+For each association of @var{hash-table}, invoke @var{proc} on its key
+and value.  If @var{proc} returns true, then @code{hash-table-find}
+returns what @var{proc} returns.  If all the calls to @var{proc} return
+@code{#f}, return the result of invoking the thunk @var{failure}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-count pred hash-table
+For each association of @var{hash-table}, invoke @var{pred} on its key
+and value.  Return the number of calls to @var{pred} which returned
+true.
+@end deffn
+
+@node SRFI 125 Mapping and folding
+@subsubsection SRFI 125 Mapping and folding
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-map proc comparator hash-table
+
+Return a newly allocated hash table as if by @samp{(make-hash-table
+comparator)}.  Calls @var{proc} for every association in
+@var{hash-table} with the value of the association.  The key of the
+association and the result of invoking @var{proc} are entered into the
+new hash table.  Note that this is not the result of lifting mapping
+over the domain of hash tables, but it is considered more useful.
+
+If @var{comparator} recognizes multiple keys in the @var{hash-table} as
+equivalent, any one of such associations is taken.
+@end deffn
+
+@deffn  {Scheme Procedure} hash-table-for-each proc hash-table
+@deffnx {Scheme Procedure} hash-table-walk hash-table proc
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is discarded.  Return an unspecified
+value.  The @code{hash-table-walk} procedure is equivalent to
+@code{hash-table-for-each} with the arguments reversed, is provided for
+backward compatibility with SRFI 69, and is deprecated.  (Common
+Lisp @code{maphash})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is used to update the value of the
+association.  Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map->list proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The values returned by the invocations of @var{proc} are accumulated
+into a list, which is returned.
+@end deffn
+
+@deffn  {Scheme Procedure} hash-table-fold proc seed hash-table
+@deffnx {Scheme Procedure} hash-table-fold hash-table proc seed
+
+Call @var{proc} for every association in @var{hash-table} with three
+arguments: the key of the association, the value of the association, and
+an accumulated value @var{val}.  @var{val} is the seed for the first
+invocation of @var{proc}, and for subsequent invocations of @var{proc},
+the returned value of the previous invocation.  The value returned by
+@code{hash-table-fold} is the return value of the last invocation of
+@var{proc}.  The order of arguments with @var{hash-table} as the first
+argument is provided for SRFI 69 compatibility, and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-prune! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments, the key and the value of the association, and removes all
+associations from @var{hash-table} for which @var{proc} returns true.
+Return an unspecified value.
+@end deffn
+
+@node SRFI 125 Copying and conversion
+@subsubsection SRFI 125 Copying and conversion
+
+@deffn {Scheme Procedure} hash-table-copy hash-table [ mutable? ]
+
+Return a newly allocated hash table with the same properties and
+associations as @var{hash-table}.  If the second argument is present and
+is true, the new hash table is mutable.  Otherwise it is immutable.
+SRFI 69 @code{hash-table-copy} does not support a second argument.
+(R6RS @code{hashtable-copy})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty-copy hash-table
+
+Return a newly allocated mutable hash table with the same properties as
+@var{hash-table}, but with no associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table->alist hash-table
+
+Return an alist with the same associations as @var{hash-table} in an
+unspecified order.
+@end deffn
+
+@node SRFI 125 Hash tables as sets
+@subsubsection SRFI 125 Hash tables as sets
+
+@deffn  {Scheme Procedure} hash-table-union! hash-table@sub{1} hash-table@sub{2}
+@deffnx {Scheme Procedure} hash-table-merge! hash-table@sub{1} hash-table@sub{2}
+
+Add the associations of @var{hash-table@sub{2}} to
+@var{hash-table@sub{1}} and return @var{hash-table@sub{1}}.  If a key
+appears in both hash tables, its value is set to the value appearing in
+@var{hash-table@sub{1}}.  Return @var{hash-table@sub{1}}.  The
+@code{hash-table-merge!} procedure is the same as
+@code{hash-table-union!}, is provided for compatibility with SRFI 69,
+and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intersection! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations from @var{hash-table@sub{1}} whose keys don't
+also appear in @var{hash-table@sub{2}} and return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-difference! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}} and return @var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-xor! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}}, and then adds the associations of
+@var{hash-table@sub{2}} whose keys are not present in
+@var{hash-table@sub{1}} to @var{hash-table@sub{1}}.  Return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@node SRFI 125 Hash functions and reflectivity
+@subsubsection SRFI 125 Hash functions and reflectivity
+
+These functions are made part of this SRFI solely for compatibility with
+SRFI 69, and are deprecated.
+
+@quotation note
+While the SRFI 125 specifies that these deprecated procedures should be
+exported using their original names, which forces its users to rename
+these procedures to something else to avoid clashing with the SRFI 126
+and SRFI 128 variants that should be preferred instead, Guile exports
+them with the @code{deprecated:} prefix.
+@end quotation
+
+@deffn {Scheme Procedure} deprecated:hash obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:string-hash obj [ arg ]
+
+Similar to SRFI 128's @code{string-hash} procedure, except that it must
+accept (and should ignore) an optional second argument.  It is
+incompatible with the procedure of the same name exported by SRFI 128
+and SRFI 126.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-by-identity obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-equivalence-function hash-table
+
+Return the equivalence procedure used to create @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-hash-function hash-table
+
+Return the hash function used to create @var{hash-table}.
+@end deffn
+
 @node SRFI 126
 @subsection SRFI 126 R6RS-based hash tables
 @cindex SRFI 126
diff --git a/module/srfi/srfi-125.sld b/module/srfi/srfi-125.sld
new file mode 100644
index 000000000..a07cb33a5
--- /dev/null
+++ b/module/srfi/srfi-125.sld
@@ -0,0 +1,96 @@
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-library (srfi 125)
+
+  (export
+
+   make-hash-table
+   hash-table
+   hash-table-unfold
+   alist->hash-table
+
+   hash-table?
+   hash-table-contains?
+   hash-table-empty?
+   hash-table=?
+   hash-table-mutable?
+
+   hash-table-ref
+   hash-table-ref/default
+
+   hash-table-set!
+   hash-table-delete!
+   hash-table-intern!
+   hash-table-update!
+   hash-table-update!/default
+   hash-table-pop!
+   hash-table-clear!
+
+   hash-table-size
+   hash-table-keys
+   hash-table-values
+   hash-table-entries
+   hash-table-find
+   hash-table-count
+
+   hash-table-map
+   hash-table-for-each
+   hash-table-map!
+   hash-table-map->list
+   hash-table-fold
+   hash-table-prune!
+
+   hash-table-copy
+   hash-table-empty-copy
+   hash-table->alist
+
+   hash-table-union!
+   hash-table-intersection!
+   hash-table-difference!
+   hash-table-xor!
+
+   ;; The following procedures are deprecated by SRFI 125:
+
+   (rename deprecated:hash                     hash)
+   (rename deprecated:string-hash              string-hash)
+   (rename deprecated:string-ci-hash           string-ci-hash)
+   (rename deprecated:hash-by-identity         hash-by-identity)
+
+   (rename deprecated:hash-table-equivalence-function
+                                               hash-table-equivalence-function)
+   (rename deprecated:hash-table-hash-function hash-table-hash-function)
+   (rename deprecated:hash-table-exists?       hash-table-exists?)
+   (rename deprecated:hash-table-walk          hash-table-walk)
+   (rename deprecated:hash-table-merge!        hash-table-merge!)
+
+   )
+
+  (import (scheme base)
+          (scheme write) ; for warnings about deprecated features
+          (srfi 126)
+          (except (srfi 128)
+                  hash-salt      ; exported by (srfi 126)
+                  string-hash    ; exported by (srfi 126)
+                  string-ci-hash ; exported by (srfi 126)
+                  ))
+
+  (cond-expand
+   ((library (scheme char))
+    (import (scheme char)))
+   (else
+    (begin (define string-ci=? string=?))))
+
+  (include "srfi-125/125.body.scm")
+
+  ) ; eof
diff --git a/module/srfi/srfi-125/125.body.scm b/module/srfi/srfi-125/125.body.scm
new file mode 100644
index 000000000..32e9f3a06
--- /dev/null
+++ b/module/srfi/srfi-125/125.body.scm
@@ -0,0 +1,589 @@
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Private stuff, not exported.
+
+;;; Ten of the SRFI 125 procedures are deprecated, and another
+;;; two allow alternative arguments that are deprecated.
+
+(define (issue-deprecated-warnings?) #t)
+
+(define (issue-warning-deprecated name-of-deprecated-misfeature)
+  (if (not (memq name-of-deprecated-misfeature already-warned))
+      (begin
+       (set! already-warned
+             (cons name-of-deprecated-misfeature already-warned))
+       (if (issue-deprecated-warnings?)
+           (let ((out (current-error-port)))
+             (display "WARNING: " out)
+             (display name-of-deprecated-misfeature out)
+             (newline out)
+             (display "    is deprecated by SRFI 125.  See" out)
+             (newline out)
+             (display "    " out)
+             (display url:deprecated out)
+             (newline out))))))
+
+(define url:deprecated
+  "http://srfi.schemers.org/srfi-125/srfi-125.html")
+
+; List of deprecated features for which a warning has already
+; been issued.
+
+(define already-warned '())
+
+;;; Comparators contain a type test predicate, which implementations
+;;; of the hash-table-set! procedure can use to reject invalid keys.
+;;; That's hard to do without sacrificing interoperability with R6RS
+;;; and/or SRFI 69 and/or SRFI 126 hash tables.
+;;;
+;;; Full interoperability means the hash tables implemented here are
+;;; interchangeable with the SRFI 126 hashtables used to implement them.
+;;; SRFI 69 and R6RS and SRFI 126 hashtables don't contain comparators,
+;;; so any association between a hash table and its comparator would have
+;;; to be maintained outside the representation of hash tables themselves,
+;;; which is problematic unless weak pointers are available.
+;;;
+;;; Not all of the hash tables implemented here will have comparators
+;;; associated with them anyway, because an equivalence procedure
+;;; and hash function can be used to create a hash table instead of
+;;; a comparator (although that usage is deprecated by SRFI 125).
+;;;
+;;; One way to preserve interoperability while enforcing a comparator's
+;;; type test is to incorporate that test into a hash table's hash
+;;; function.  The advantage of doing that should be weighed against
+;;; these disadvantages:
+;;;
+;;;     If the type test is slow, then hashing would also be slower.
+;;;
+;;;     The R6RS, SRFI 69, and SRFI 126 APIs allow extraction of
+;;;     a hash function from some hash tables.
+;;;     Some programmers might expect that hash function to be the
+;;;     hash function encapsulated by the comparator (in the sense
+;;;     of eq?, perhaps) even though this API makes no such guarantee
+;;;     (and extraction of that hash function from an existing hash
+;;;     table can only be done by calling a deprecated procedure).
+
+;;; If %enforce-comparator-type-tests is true, then make-hash-table,
+;;; when passed a comparator, will use a hash function that enforces
+;;; the comparator's type test.
+
+(define %enforce-comparator-type-tests #t)
+
+;;; Given a comparator, return its hash function, possibly augmented
+;;; by the comparator's type test.
+
+(define (%comparator-hash-function comparator)
+  (let ((okay? (comparator-type-test-predicate comparator))
+        (hash-function (comparator-hash-function comparator)))
+    (if %enforce-comparator-type-tests
+        (lambda (x . rest)
+          (cond ((not (okay? x))
+                 (error "key rejected by hash-table comparator"
+                        x
+                        comparator))
+                ((null? rest)
+                 (hash-function x))
+                (else
+                 (apply hash-function x rest))))
+        hash-function)))
+
+;;; A unique (in the sense of eq?) value that will never be found
+;;; within a hash-table.
+
+(define %not-found (list '%not-found))
+
+;;; A unique (in the sense of eq?) value that escapes only as an irritant
+;;; when a hash-table key is not found.
+
+(define %not-found-irritant (list 'not-found))
+
+;;; The error message used when a hash-table key is not found.
+
+(define %not-found-message "hash-table key not found")
+
+;;; FIXME: thread-safe, weak-keys, ephemeral-keys, weak-values,
+;;; and ephemeral-values are not supported by this portable
+;;; reference implementation.
+
+(define (%check-optional-arguments procname args)
+  (if (or (memq 'thread-safe args)
+          (memq 'weak-keys args)
+          (memq 'weak-values args)
+          (memq 'ephemeral-keys args)
+          (memq 'ephemeral-values args))
+      (error (string-append (symbol->string procname)
+                            ": unsupported optional argument(s)")
+             args)))
+
+;;; This was exported by an earlier draft of SRFI 125,
+;;; and is still used by hash-table=?
+
+(define (hash-table-every proc ht)
+  (call-with-values
+   (lambda () (hash-table-entries ht))
+   (lambda (keys vals)
+     (let loop ((keys keys)
+                (vals vals))
+       (if (null? keys)
+           #t
+           (let* ((key (car keys))
+                  (val (car vals))
+                  (x   (proc key val)))
+             (and x
+                  (loop (cdr keys)
+                        (cdr vals)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Exported procedures
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+;;; The first argument can be a comparator or an equality predicate.
+;;;
+;;; If the first argument is a comparator, any remaining arguments
+;;; are implementation-dependent, but a non-negative exact integer
+;;; should be interpreted as an initial capacity and the symbols
+;;; thread-safe, weak-keys, ephemeral-keys, weak-values, and
+;;; emphemeral-values should be interpreted specially.  (These
+;;; special symbols are distinct from the analogous special symbols
+;;; in SRFI 126.)
+;;;
+;;; If the first argument is not a comparator, then it had better
+;;; be an equality predicate (which is deprecated by SRFI 125).
+;;; If a second argument is present and is a procedure, then it's
+;;; a hash function (which is allowed only for the deprecated case
+;;; in which the first argument is an equality predicate).  If a
+;;; second argument is not a procedure, then it's some kind of
+;;; implementation-dependent optional argument, as are all arguments
+;;; beyond the second.
+;;;
+;;; SRFI 128 defines make-eq-comparator, make-eqv-comparator, and
+;;; make-equal-comparator procedures whose hash function is the
+;;; default-hash procedure of SRFI 128, which is inappropriate
+;;; for use with eq? and eqv? unless the object being hashed is
+;;; never mutated.  Neither SRFI 125 nor 128 provide any way to
+;;; define a comparator whose hash function is truly compatible
+;;; with the use of eq? or eqv? as an equality predicate.
+;;;
+;;; That would make SRFI 125 almost as bad as SRFI 69 if not for
+;;; the following paragraph of SRFI 125:
+;;;
+;;;     Implementations are permitted to ignore user-specified
+;;;     hash functions in certain circumstances. Specifically,
+;;;     if the equality predicate, whether passed as part of a
+;;;     comparator or explicitly, is more fine-grained (in the
+;;;     sense of R7RS-small section 6.1) than equal?, the
+;;;     implementation is free — indeed, is encouraged — to
+;;;     ignore the user-specified hash function and use something
+;;;     implementation-dependent. This allows the use of addresses
+;;;     as hashes, in which case the keys must be rehashed if
+;;;     they are moved by the garbage collector. Such a hash
+;;;     function is unsafe to use outside the context of
+;;;     implementation-provided hash tables. It can of course be
+;;;     exposed by an implementation as an extension, with
+;;;     suitable warnings against inappropriate uses.
+;;;
+;;; That gives implementations permission to do something more
+;;; useful, but when should implementations take advantage of
+;;; that permission?  This implementation uses the superior
+;;; solution provided by SRFI 126 whenever:
+;;;
+;;;     A comparator is passed as first argument and its equality
+;;;     predicate is eq? or eqv?.
+;;;
+;;;     The eq? or eqv? procedure is passed as first argument
+;;;     (which is a deprecated usage).
+
+(define (make-hash-table comparator/equiv . rest)
+  (if (comparator? comparator/equiv)
+      (let ((equiv (comparator-equality-predicate comparator/equiv))
+            (hash-function (%comparator-hash-function comparator/equiv)))
+        (%make-hash-table equiv hash-function rest))
+      (let* ((equiv comparator/equiv)
+             (hash-function (if (and (not (null? rest))
+                                     (procedure? (car rest)))
+                                (car rest)
+                                #f))
+             (rest (if hash-function (cdr rest) rest)))
+        (issue-warning-deprecated 'srfi-69-style:make-hash-table)
+        (%make-hash-table equiv hash-function rest))))
+
+(define (%make-hash-table equiv hash-function opts)
+  (%check-optional-arguments 'make-hash-table opts)
+  (cond ((equal? equiv eq?)
+         (make-eq-hashtable))
+        ((equal? equiv eqv?)
+         (make-eqv-hashtable))
+        (hash-function
+         (make-hashtable hash-function equiv))
+        ((equal? equiv equal?)
+         (make-hashtable equal-hash equiv))
+        ((equal? equiv string=?)
+         (make-hashtable string-hash equiv))
+        ((equal? equiv string-ci=?)
+         (make-hashtable string-ci-hash equiv))
+        ((equal? equiv symbol=?)
+         (make-hashtable symbol-hash equiv))
+        (else
+         (error "make-hash-table: unable to infer hash function"
+                equiv))))
+
+(define (hash-table comparator . rest)
+  (let ((ht (apply make-hash-table comparator rest)))
+    (let loop ((kvs rest))
+      (cond
+       ((null? kvs) #f)
+       ((null? (cdr kvs)) (error "hash-table: wrong number of arguments"))
+       ((hashtable-contains? ht (car kvs))
+        (error "hash-table: two equivalent keys were provided"
+               (car kvs)))
+       (else (hashtable-set! ht (car kvs) (cadr kvs))
+             (loop (cddr kvs)))))
+    (hashtable-copy ht #f)))
+
+(define (hash-table-unfold stop? mapper successor seed comparator . rest)
+  (let ((ht (apply make-hash-table comparator rest)))
+    (let loop ((seed seed))
+      (if (stop? seed)
+          ht
+          (call-with-values
+           (lambda () (mapper seed))
+           (lambda (key val)
+             (hash-table-set! ht key val)
+             (loop (successor seed))))))))
+
+(define (alist->hash-table alist comparator/equiv . rest)
+  (if (and (not (null? rest))
+           (procedure? (car rest)))
+      (issue-warning-deprecated 'srfi-69-style:alist->hash-table))
+  (let ((ht (apply make-hash-table comparator/equiv rest))
+        (entries (reverse alist)))
+    (for-each (lambda (entry)
+                (hash-table-set! ht (car entry) (cdr entry)))
+              entries)
+    ht))
+
+;;; Predicates.
+
+(define (hash-table? obj)
+  (hashtable? obj))
+
+(define (hash-table-contains? ht key)
+  (hashtable-contains? ht key))
+
+(define (hash-table-empty? ht)
+  (= 0 (hashtable-size ht)))
+
+;;; FIXME: walks both hash tables because their key comparators
+;;; might be different
+
+(define (hash-table=? value-comparator ht1 ht2)
+  (let ((val=? (comparator-equality-predicate value-comparator))
+        (n1 (hash-table-size ht1))
+        (n2 (hash-table-size ht2)))
+    (and (= n1 n2)
+         (hash-table-every (lambda (key val1)
+                             (and (hashtable-contains? ht2 key)
+                                  (val=? val1
+                                         (hashtable-ref ht2 key 'ignored))))
+                           ht1)
+         (hash-table-every (lambda (key val2)
+                             (and (hashtable-contains? ht1 key)
+                                  (val=? val2
+                                         (hashtable-ref ht1 key 'ignored))))
+                           ht2))))
+
+(define (hash-table-mutable? ht)
+  (hashtable-mutable? ht))
+
+;;; Accessors.
+
+(define (hash-table-ref ht key . rest)
+  (let ((failure (if (null? rest) #f (car rest)))
+        (success (if (or (null? rest) (null? (cdr rest))) #f (cadr rest)))
+        (val (hashtable-ref ht key %not-found)))
+    (cond ((eq? val %not-found)
+           (if (and failure (procedure? failure))
+               (failure)
+               (error %not-found-message ht key %not-found-irritant)))
+          (success
+           (success val))
+          (else
+           val))))
+
+(define (hash-table-ref/default ht key default)
+  (hashtable-ref ht key default))
+
+;;; Mutators.
+
+(define (hash-table-set! ht . rest)
+  (if (= 2 (length rest))
+      (hashtable-set! ht (car rest) (cadr rest))
+      (let loop ((kvs rest))
+        (cond ((and (not (null? kvs))
+                    (not (null? (cdr kvs))))
+               (hashtable-set! ht (car kvs) (cadr kvs))
+               (loop (cddr kvs)))
+              ((not (null? kvs))
+               (error "hash-table-set!: wrong number of arguments"
+                      (cons ht rest)))))))
+
+(define (hash-table-delete! ht . keys)
+  (let loop ((keys keys) (cnt 0))
+    (cond ((null? keys) cnt)
+	  ((hash-table-contains? ht (car keys))
+	   (hashtable-delete! ht (car keys))
+	   (loop (cdr keys) (+ cnt 1)))
+	  (else
+	   (loop (cdr keys) cnt)))))
+
+(define (hash-table-intern! ht key failure)
+  (if (hashtable-contains? ht key)
+      (hash-table-ref ht key)
+      (let ((val (failure)))
+        (hash-table-set! ht key val)
+        val)))
+
+(define (hash-table-update! ht key updater . rest)
+  (hash-table-set! ht
+                   key
+                   (updater (apply hash-table-ref ht key rest))))
+
+(define (hash-table-update!/default ht key updater default)
+  (hash-table-set! ht key (updater (hashtable-ref ht key default))))
+
+(define (hash-table-pop! ht)
+  (call/cc
+    (lambda (return)
+      (hash-table-for-each
+        (lambda (key value)
+          (hash-table-delete! ht key)
+          (return key value))
+        ht)
+      (error "hash-table-pop!: hash table is empty" ht))))
+
+(define (hash-table-clear! ht)
+  (hashtable-clear! ht))
+
+;;; The whole hash table.
+
+(define (hash-table-size ht)
+  (hashtable-size ht))
+
+(define (hash-table-keys ht)
+  (vector->list (hashtable-keys ht)))
+
+(define (hash-table-values ht)
+  (call-with-values
+   (lambda () (hashtable-entries ht))
+   (lambda (keys vals)
+     (vector->list vals))))
+
+(define (hash-table-entries ht)
+  (call-with-values
+   (lambda () (hashtable-entries ht))
+   (lambda (keys vals)
+     (values (vector->list keys)
+             (vector->list vals)))))
+
+(define (hash-table-find proc ht failure)
+  (call-with-values
+   (lambda () (hash-table-entries ht))
+   (lambda (keys vals)
+     (let loop ((keys keys)
+                (vals vals))
+       (if (null? keys)
+           (failure)
+           (let* ((key (car keys))
+                  (val (car vals))
+                  (x   (proc key val)))
+             (or x
+                 (loop (cdr keys)
+                       (cdr vals)))))))))
+
+(define (hash-table-count pred ht)
+  (call-with-values
+   (lambda () (hash-table-entries ht))
+   (lambda (keys vals)
+     (let loop ((keys keys)
+                (vals vals)
+                (n 0))
+       (if (null? keys)
+           n
+           (let* ((key (car keys))
+                  (val (car vals))
+                  (x   (pred key val)))
+             (loop (cdr keys)
+                   (cdr vals)
+                   (if x (+ n 1) n))))))))
+
+;;; Mapping and folding.
+
+(define (hash-table-map proc comparator ht)
+  (let ((result (make-hash-table comparator)))
+    (hash-table-for-each
+     (lambda (key val)
+       (hash-table-set! result key (proc val)))
+     ht)
+    result))
+
+(define (hash-table-map->list proc ht)
+  (call-with-values
+   (lambda () (hash-table-entries ht))
+   (lambda (keys vals)
+     (map proc keys vals))))
+
+;;; With this particular implementation, the proc can safely mutate ht.
+;;; That property is not guaranteed by the specification, but can be
+;;; relied upon by procedures defined in this file.
+
+(define (hash-table-for-each proc ht)
+  (call-with-values
+   (lambda () (hashtable-entries ht))
+   (lambda (keys vals)
+     (vector-for-each proc keys vals))))
+
+(define (hash-table-map! proc ht)
+  (hash-table-for-each (lambda (key val)
+                         (hashtable-set! ht key (proc key val)))
+                       ht))
+
+(define (hash-table-fold proc init ht)
+  (if (hashtable? proc)
+      (deprecated:hash-table-fold proc init ht)
+      (call-with-values
+       (lambda () (hash-table-entries ht))
+       (lambda (keys vals)
+         (let loop ((keys keys)
+                    (vals vals)
+                    (x    init))
+           (if (null? keys)
+               x
+               (loop (cdr keys)
+                     (cdr vals)
+                     (proc (car keys) (car vals) x))))))))
+
+(define (hash-table-prune! proc ht)
+  (hash-table-for-each (lambda (key val)
+                         (if (proc key val)
+                             (hashtable-delete! ht key)))
+                       ht))
+
+;;; Copying and conversion.
+
+(define (hash-table-copy ht . rest)
+  (apply hashtable-copy ht rest))
+
+(define (hash-table-empty-copy ht)
+  (let* ((ht2 (hashtable-copy ht #t))
+         (ignored (hashtable-clear! ht2)))
+     ht2))
+
+(define (hash-table->alist ht)
+  (call-with-values
+   (lambda () (hash-table-entries ht))
+   (lambda (keys vals)
+     (map cons keys vals))))
+
+;;; Hash tables as sets.
+
+(define (hash-table-union! ht1 ht2)
+  (hash-table-for-each
+   (lambda (key2 val2)
+     (if (not (hashtable-contains? ht1 key2))
+         (hashtable-set! ht1 key2 val2)))
+   ht2)
+  ht1)
+
+(define (hash-table-intersection! ht1 ht2)
+  (hash-table-for-each
+   (lambda (key1 val1)
+     (if (not (hashtable-contains? ht2 key1))
+         (hashtable-delete! ht1 key1)))
+   ht1)
+  ht1)
+
+(define (hash-table-difference! ht1 ht2)
+  (hash-table-for-each
+   (lambda (key1 val1)
+     (if (hashtable-contains? ht2 key1)
+         (hashtable-delete! ht1 key1)))
+   ht1)
+  ht1)
+
+(define (hash-table-xor! ht1 ht2)
+  (hash-table-for-each
+   (lambda (key2 val2)
+     (if (hashtable-contains? ht1 key2)
+         (hashtable-delete! ht1 key2)
+         (hashtable-set! ht1 key2 val2)))
+   ht2)
+  ht1)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The following procedures are deprecated by SRFI 125, but must
+;;; be exported nonetheless.
+;;;
+;;; Programs that import the (srfi 125) library must rename the
+;;; deprecated string-hash and string-ci-hash procedures to avoid
+;;; conflict with the string-hash and string-ci-hash procedures
+;;; exported by SRFI 126 and SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (deprecated:hash obj . rest)
+  (issue-warning-deprecated 'hash)
+  (default-hash obj))
+
+(define (deprecated:string-hash obj . rest)
+  (issue-warning-deprecated 'srfi-125:string-hash)
+  (string-hash obj))
+
+(define (deprecated:string-ci-hash obj . rest)
+  (issue-warning-deprecated 'srfi-125:string-ci-hash)
+  (string-ci-hash obj))
+
+(define (deprecated:hash-by-identity obj . rest)
+  (issue-warning-deprecated 'hash-by-identity)
+  (deprecated:hash obj))
+
+(define (deprecated:hash-table-equivalence-function ht)
+  (issue-warning-deprecated 'hash-table-equivalence-function)
+  (hashtable-equivalence-function ht))
+
+(define (deprecated:hash-table-hash-function ht)
+  (issue-warning-deprecated 'hash-table-hash-function)
+  (hashtable-hash-function ht))
+
+(define (deprecated:hash-table-exists? ht key)
+  (issue-warning-deprecated 'hash-table-exists?)
+  (hash-table-contains? ht key))
+
+(define (deprecated:hash-table-walk ht proc)
+  (issue-warning-deprecated 'hash-table-walk)
+  (hash-table-for-each proc ht))
+
+(define (deprecated:hash-table-fold ht proc seed)
+  (issue-warning-deprecated 'srfi-69-style:hash-table-fold)
+  (hash-table-fold proc seed ht))
+
+(define (deprecated:hash-table-merge! ht1 ht2)
+  (issue-warning-deprecated 'hash-table-merge!)
+  (hash-table-union! ht1 ht2))
+
+; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0fb5827cc..13eb1f24f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-98.test			\
 	    tests/srfi-105.test			\
 	    tests/srfi-111.test			\
+            tests/srfi-125.test			\
             tests/srfi-126.test			\
             tests/srfi-128.test			\
             tests/srfi-171.test                 \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
 	$(SCM_TESTS) \
 	tests/rnrs-test-a.scm \
 	tests/srfi-64-test.scm \
+	tests/srfi-125-test.scm \
 	tests/srfi-126-test.scm \
 	tests/srfi-128-test.scm \
 	ChangeLog-2008
diff --git a/test-suite/tests/srfi-125-test.scm b/test-suite/tests/srfi-125-test.scm
new file mode 100644
index 000000000..7816b0c20
--- /dev/null
+++ b/test-suite/tests/srfi-125-test.scm
@@ -0,0 +1,890 @@
+;;; Copyright (C) William D Clinger 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.
+
+;;; This is a very shallow sanity test for hash tables.
+;;;
+;;; Tests marked by a "FIXME: glass-box" comment test behavior of the
+;;; reference implementation that is not required by the specification.
+
+(import (scheme base)
+        (scheme char)
+        (scheme write)
+        (only (scheme process-context) exit)
+        (scheme comparator)            ; was (srfi 128)
+        (only (scheme sort) list-sort) ; was (r6rs sorting)
+        (only (srfi 126) hashtable-copy)
+        (rename (srfi 125)
+                (string-hash    deprecated:string-hash)
+                (string-ci-hash deprecated:string-ci-hash)))
+
+;;; Commentary:
+
+;;; The test suite was slightly adjusted to use SRFI 64, for better
+;;; integration with the Guile test suite.
+
+;;; Code:
+
+(test-begin "srfi-125")
+
+;;; FIXME: when debugging catastrophic failures, printing every expression
+;;; before it's executed may help.
+
+(define-syntax test
+  (syntax-rules ()
+    ((_ expr expected)
+     (test-equal expr expected))))
+
+(define-syntax test-deny
+  (syntax-rules ()
+   ((_ expr)
+    (test-assert (not expr)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from SRFI 114 to SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define default-comparator (make-default-comparator))
+
+;;; SRFI 128 says the following definition will work, but that's
+;;; an error in SRFI 128; the hash function produce non-integers.
+
+#;
+(define number-comparator
+  (make-comparator real? = < (lambda (x) (exact (abs x)))))
+
+(define number-comparator
+  (make-comparator real? = < (lambda (x) (exact (abs (round x))))))
+
+(define string-comparator
+  (make-comparator string? string=? string<? string-hash))
+
+(define string-ci-comparator
+  (make-comparator string? string-ci=? string-ci<? string-ci-hash))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from earlier draft of SRFI 125 to this draft.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Returns an immutable hash table.
+
+(define (hash-table-tabulate comparator n proc)
+  (let ((ht (make-hash-table comparator)))
+    (do ((i 0 (+ i 1)))
+        ((= i n)
+         (hash-table-copy ht))
+      (call-with-values
+       (lambda ()
+         (proc i))
+       (lambda (key val)
+         (hash-table-set! ht key val))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+(define ht-default (make-hash-table default-comparator))
+
+(define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
+
+(define ht-eqv (make-hash-table eqv-comparator))
+
+(define ht-eq2 (make-hash-table eq?))
+
+(define ht-eqv2 (make-hash-table eqv?))
+
+(define ht-equal (make-hash-table equal?))
+
+(define ht-string (make-hash-table string=?))
+
+(define ht-string-ci (make-hash-table string-ci=?))
+
+(define ht-symbol (make-hash-table symbol=?))    ; FIXME: glass-box
+
+(define ht-fixnum (make-hash-table = abs))
+
+(define ht-default2
+  (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#()))
+
+(define ht-fixnum2
+  (hash-table-tabulate number-comparator
+                       10
+                       (lambda (i) (values (* i i) i))))
+
+(define ht-string2
+  (hash-table-unfold (lambda (s) (= 0 (string-length s)))
+                     (lambda (s) (values s (string-length s)))
+                     (lambda (s) (substring s 0 (- (string-length s) 1)))
+                     "prefixes"
+                     string-comparator
+                     'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
+
+(define ht-string-ci2
+  (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
+                     string-ci-comparator
+                     "ignored1" 'ignored2))
+
+(define ht-symbol2
+  (alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow))
+                     eq?))
+
+(define ht-equal2
+  (alist->hash-table '(((edward) . abbey)
+                       ((dashiell) . hammett)
+                       ((edward) . teach)
+                       ((mark) . twain))
+                     equal?
+                     (comparator-hash-function default-comparator)))
+
+(define test-tables
+  (list ht-default   ht-default2   ; initial keys: foo, 101.3, (x y z)
+        ht-eq        ht-eq2        ; initially empty
+        ht-eqv       ht-eqv2       ; initially empty
+        ht-equal     ht-equal2     ; initial keys: (edward), (dashiell), (mark)
+        ht-string    ht-string2    ; initial keys: "p, "pr", ..., "prefixes"
+        ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
+        ht-symbol    ht-symbol2    ; initial keys: mary, noel, peter
+        ht-fixnum    ht-fixnum2))  ; initial keys: 0, 1, 4, 9, ..., 81
+
+;;; Predicates
+
+(test (map hash-table?
+           (cons '#()
+                 (cons default-comparator
+                       test-tables)))
+      (append '(#f #f) (map (lambda (x) #t) test-tables)))
+
+(test (map hash-table-contains?
+           test-tables
+           '(foo 101.3
+             x "y"
+             (14 15) #\newline
+             (edward) (mark)
+             "p" "pref"
+             "mike" "PAUL"
+             jane noel
+             0 4))
+      '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t))
+
+(test (map hash-table-contains?
+           test-tables
+           '(#u8() 47.9
+             '#() '()
+             foo bar
+             19 (henry)
+             "p" "perp"
+             "mike" "Noel"
+             jane paul
+             0 5))
+      (map (lambda (x) #f) test-tables))
+
+(test (map hash-table-empty? test-tables)
+      '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+           test-tables
+           test-tables)
+      (map (lambda (x) #t) test-tables))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+           test-tables
+           (do ((tables (reverse test-tables) (cddr tables))
+                (rev '() (cons (car tables) (cons (cadr tables) rev))))
+               ((null? tables)
+                rev)))
+      '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f))
+
+(test (map hash-table-mutable? test-tables)
+      '(#t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #f))
+
+;;; FIXME: glass-box
+
+(test (map hash-table-mutable? (map hash-table-copy test-tables))
+      (map (lambda (x) #f) test-tables))
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t))
+      #t)
+
+;;; Accessors.
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht 'not-a-key)))
+           test-tables)
+      (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht 'not-a-key (lambda () 'err))))
+           test-tables)
+      (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
+           test-tables)
+      (map (lambda (ht) 'err) test-tables))
+
+(test (map (lambda (ht key)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht key)))
+           test-tables
+           '(foo 101.3
+             x "y"
+             (14 15) #\newline
+             (edward) (mark)
+             "p" "pref"
+             "mike" "PAUL"
+             jane noel
+             0 4))
+      '(err "fever" err err err err err twain err 4 err 4 err stookey err 2))
+
+(test (map (lambda (ht key)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht key (lambda () 'eh))))
+           test-tables
+           '(foo 101.3
+             x "y"
+             (14 15) #\newline
+             (edward) (mark)
+             "p" "pref"
+             "mike" "PAUL"
+             jane noel
+             0 4))
+      '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (map (lambda (ht key)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref ht key (lambda () 'eh) list)))
+           test-tables
+           '(foo 101.3
+             x "y"
+             (14 15) #\newline
+             (edward) (mark)
+             "p" "pref"
+             "mike" "PAUL"
+             jane noel
+             0 4))
+      '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2)))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+             (guard (exn
+                     (else 'eh))
+              (hash-table-ref/default ht 'not-a-key 'eh)))
+           test-tables)
+      (map (lambda (ht) 'eh) test-tables))
+
+(test (map (lambda (ht key)
+             (guard (exn
+                     (else 'err))
+              (hash-table-ref/default ht key 'eh)))
+           test-tables
+           '(foo 101.3
+             x "y"
+             (14 15) #\newline
+             (edward) (mark)
+             "p" "pref"
+             "mike" "PAUL"
+             jane noel
+             0 4))
+      '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (begin (hash-table-set! ht-fixnum)
+             (list-sort < (hash-table-keys ht-fixnum)))
+      '())
+
+(test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
+             (list-sort < (hash-table-keys ht-fixnum)))
+      '(121 144 169))
+
+(test (begin (hash-table-set! ht-fixnum
+                              0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
+             (list-sort < (hash-table-keys ht-fixnum)))
+      '(0 1 4 9 16 25 36 49 64 81 121 144 169))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+           '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+      '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1))
+
+(test (begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+             (hash-table-intern! ht-fixnum 121 (lambda () 11))
+             (hash-table-intern! ht-fixnum   0 (lambda ()  0))
+             (hash-table-intern! ht-fixnum   1 (lambda ()  1))
+             (hash-table-intern! ht-fixnum   1 (lambda () 99))
+             (hash-table-intern! ht-fixnum 121 (lambda () 66))
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
+                 (hash-table-map->list vector ht-fixnum))
+      '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13)))
+
+(test (begin (hash-table-prune! (lambda (key val)
+                                  (and (odd? key) (> val 10)))
+                                ht-fixnum)
+             (list-sort (lambda (l1 l2)
+                          (< (car l1) (car l2)))
+                        (hash-table-map->list list ht-fixnum)))
+      '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13)))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+             (hash-table-intern! ht-fixnum 144 (lambda () 9999))
+             (hash-table-intern! ht-fixnum 121 (lambda () 11))
+             (list-sort (lambda (l1 l2)
+                          (< (car l1) (car l2)))
+                        (hash-table-map->list list ht-fixnum)))
+      '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13)))
+
+(test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 -)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 - abs)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 5)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 999)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (let* ((n0 (hash-table-size ht-fixnum))
+             (ht (hash-table-copy ht-fixnum #t)))
+        (call-with-values
+         (lambda () (hash-table-pop! ht))
+         (lambda (key val)
+           (list (= key (* val val))
+                 (= (- n0 1) (hash-table-size ht))))))
+      '(#t #t))
+
+(test (begin (hash-table-delete! ht-fixnum 75)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 75 81)))
+      '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1))
+
+(let ((ht-eg (hashtable-copy (hash-table number-comparator
+                                         1 1 4 2 9 3 16 4 25 5 64 8)
+                             #t)))
+  (test (hash-table-delete! ht-eg)
+        0)
+  (test (hash-table-delete! ht-eg 2 7 2000)
+        0)
+  (test (hash-table-delete! ht-eg 1 2 4 7 64 2000)
+        3)
+  (test-assert (= 3 (length (hash-table-keys ht-eg)))))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+           '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+      '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (begin (hash-table-set! ht-fixnum 36 6)
+             (hash-table-set! ht-fixnum 81 9)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+      '(13 12 11 0 1 2 3 4 5 6 -1 8 9))
+
+(test (begin (hash-table-clear! ht-eq)
+             (hash-table-size ht-eq))
+      0)
+
+;;; The whole hash table.
+
+(test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
+             (hash-table-size ht-eq))
+      3)
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+             (n0 (hash-table-size ht))
+             (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
+             (n1 (hash-table-size ht)))
+        (list n0 n1 (hash-table=? default-comparator ht ht-eq)))
+      '(0 3 #t))
+
+(test (begin (hash-table-clear! ht-eq)
+             (hash-table-size ht-eq))
+      0)
+
+(test (hash-table-find (lambda (key val)
+                         (if (= 144 key (* val val))
+                             (list key val)
+                             #f))
+                       ht-fixnum
+                       (lambda () 99))
+      '(144 12))
+
+(test (hash-table-find (lambda (key val)
+                         (if (= 144 key val)
+                             (list key val)
+                             #f))
+                       ht-fixnum
+                       (lambda () 99))
+      99)
+
+(test (hash-table-count <= ht-fixnum)
+      2)
+
+;;; Mapping and folding.
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+           '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))
+      '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))
+
+(test (let ((ht (hash-table-map (lambda (val) (* val val))
+                                eqv-comparator
+                                ht-fixnum)))
+        (map (lambda (i) (hash-table-ref/default ht i -1))
+             '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+      '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1))
+
+(test (let ((keys (make-vector 15 -1))
+            (vals (make-vector 15 -1)))
+        (hash-table-for-each (lambda (key val)
+                               (vector-set! keys val key)
+                               (vector-set! vals val val))
+                             ht-fixnum)
+        (list keys vals))
+      '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+        #(0 1 2 3  4  5  6 -1  8  9 -1  11  12  13 -1)))
+
+(test (begin (hash-table-map! (lambda (key val)
+                                (if (<= 10 key)
+                                    (- val)
+                                    val))
+                              ht-fixnum)
+             (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+                  '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+      '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1))
+
+(test (hash-table-fold (lambda (key val acc)
+                         (+ val acc))
+                       0
+                       ht-string-ci2)
+      13)
+
+(test (list-sort < (hash-table-fold (lambda (key val acc)
+                                      (cons key acc))
+                                    '()
+                                    ht-fixnum))
+      '(0 1 4 9 16 25 36 64 81 121 144 169))
+
+;;; Copying and conversion.
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum))
+      #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f))
+      #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t))
+      #t)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum))
+      #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #f))
+      #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #t))
+      #t)
+
+(test (hash-table->alist ht-eq)
+      '())
+
+(test (list-sort (lambda (x y) (< (car x) (car y)))
+                 (hash-table->alist ht-fixnum))
+      '((0 . 0)
+        (1 . 1)
+        (4 . 2)
+        (9 . 3)
+        (16 . -4)
+        (25 . -5)
+        (36 . -6)
+        (64 . -8)
+        (81 . -9)
+        (121 . -11)
+        (144 . -12)
+        (169 . -13)))
+
+;;; Hash tables as sets.
+
+(test (begin (hash-table-union! ht-fixnum ht-fixnum2)
+             (list-sort (lambda (x y) (< (car x) (car y)))
+                        (hash-table->alist ht-fixnum)))
+      '((0 . 0)
+        (1 . 1)
+        (4 . 2)
+        (9 . 3)
+        (16 . -4)
+        (25 . -5)
+        (36 . -6)
+        (49 . 7)
+        (64 . -8)
+        (81 . -9)
+        (121 . -11)
+        (144 . -12)
+        (169 . -13)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+        (hash-table-union! ht ht-fixnum)
+        (list-sort (lambda (x y) (< (car x) (car y)))
+                   (hash-table->alist ht)))
+      '((0 . 0)
+        (1 . 1)
+        (4 . 2)
+        (9 . 3)
+        (16 . 4)
+        (25 . 5)
+        (36 . 6)
+        (49 . 7)
+        (64 . 8)
+        (81 . 9)
+        (121 . -11)
+        (144 . -12)
+        (169 . -13)))
+
+(test (begin (hash-table-union! ht-eqv2 ht-fixnum)
+             (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+      #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-fixnum)
+             (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+      #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-eqv)
+             (hash-table-empty? ht-eqv2))
+      #t)
+
+(test (begin (hash-table-intersection! ht-fixnum ht-fixnum2)
+             (list-sort (lambda (x y) (< (car x) (car y)))
+                        (hash-table->alist ht-fixnum)))
+      '((0 . 0)
+        (1 . 1)
+        (4 . 2)
+        (9 . 3)
+        (16 . -4)
+        (25 . -5)
+        (36 . -6)
+        (49 . 7)
+        (64 . -8)
+        (81 . -9)))
+
+(test (begin (hash-table-intersection!
+              ht-fixnum
+              (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                                 number-comparator))
+             (list-sort (lambda (x y) (< (car x) (car y)))
+                        (hash-table->alist ht-fixnum)))
+      '((4 . 2)
+        (25 . -5)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+        (hash-table-difference!
+         ht
+         (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                            number-comparator))
+        (list-sort (lambda (x y) (< (car x) (car y)))
+                   (hash-table->alist ht)))
+      '((0 . 0)
+        (1 . 1)
+        (9 . 3)
+        (16 . 4)
+        (36 . 6)
+        (49 . 7)
+        (64 . 8)
+        (81 . 9)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+        (hash-table-xor!
+         ht
+         (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+                            number-comparator))
+        (list-sort (lambda (x y) (< (car x) (car y)))
+                   (hash-table->alist ht)))
+      '((-1 . -1)
+        (0 . 0)
+        (1 . 1)
+        (9 . 3)
+        (16 . 4)
+        (36 . 6)
+        (49 . 7)
+        (64 . 8)
+        (81 . 9)
+        (100 . 10)))
+
+(test (guard (exn
+              (else 'key-not-found))
+       (hash-table-ref ht-default "this key won't be present"))
+      'key-not-found)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Desultory tests of deprecated procedures and usages.
+;;; Deprecated usage of make-hash-table and alist->hash-table
+;;; has already been tested above.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test (let* ((x (list 1 2 3))
+             (y (cons 1 (cdr x)))
+             (h1 (hash x))
+             (h2 (hash y)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x "abcd")
+             (y (string-append "ab" "cd"))
+             (h1 (deprecated:string-hash x))
+             (h2 (deprecated:string-hash y)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+             (y "hello THERE!")
+             (h1 (deprecated:string-ci-hash x))
+             (h2 (deprecated:string-ci-hash y)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+             (y x)
+             (h1 (hash-by-identity x))
+             (h2 (hash-by-identity y)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x (list 1 2 3))
+             (y (cons 1 (cdr x)))
+             (h1 (hash x 60))
+             (h2 (hash y 60)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x "abcd")
+             (y (string-append "ab" "cd"))
+             (h1 (deprecated:string-hash x 97))
+             (h2 (deprecated:string-hash y 97)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+             (y "hello THERE!")
+             (h1 (deprecated:string-ci-hash x 101))
+             (h2 (deprecated:string-ci-hash y 101)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+             (y x)
+             (h1 (hash-by-identity x 102))
+             (h2 (hash-by-identity y 102)))
+        (list (exact-integer? h1)
+              (exact-integer? h2)
+              (= h1 h2)))
+      '(#t #t #t))
+
+(test (let ((f (hash-table-equivalence-function ht-fixnum)))
+        (if (procedure? f)
+            (f 34 34)
+            #t))
+      #t)
+
+(test (let ((f (hash-table-hash-function ht-fixnum)))
+        (if (procedure? f)
+            (= (f 34) (f 34))
+            #t))
+      #t)
+
+(test (map (lambda (key) (hash-table-exists? ht-fixnum2 key))
+           '(0 1 2 3 4 5 6 7 8 9 10))
+      '(#t #t #f #f #t #f #f #f #f #t #f))
+
+(test (let ((n 0))
+        (hash-table-walk ht-fixnum2
+                         (lambda (key val) (set! n (+ n key))))
+        n)
+      (apply +
+             (map (lambda (x) (* x x))
+                  '(0 1 2 3 4 5 6 7 8 9))))
+
+(test (list-sort < (hash-table-fold ht-fixnum2
+                                    (lambda (key val acc)
+                                      (cons key acc))
+                                    '()))
+      '(0 1 4 9 16 25 36 49 64 81))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t))
+            (ht2 (hash-table number-comparator
+                             .25 .5 64 9999 81 9998 121 -11 144 -12)))
+        (hash-table-merge! ht ht2)
+        (list-sort (lambda (x y) (< (car x) (car y)))
+                   (hash-table->alist ht)))
+      '((0 . 0)
+        (.25 . .5)
+        (1 . 1)
+        (4 . 2)
+        (9 . 3)
+        (16 . 4)
+        (25 . 5)
+        (36 . 6)
+        (49 . 7)
+        (64 . 8)
+        (81 . 9)
+        (121 . -11)
+        (144 . -12)))
+
+;;; Bugs reported on 5 January 2019 by Jéssica Milaré
+;;; ( https://srfi-email.schemers.org/srfi-125/msg/10177551 )
+
+;;; Spec says hash-table returns an immutable hash table (if that
+;;; is supported) and signal an error if there are duplicate keys,
+;;; but standard implementation returns a mutable hash table and
+;;; signals no error with duplicate keys.
+;;;
+;;; Comment by Will Clinger: the spec says specifying a duplicate
+;;; key "is an error", so hash-table is not required to signal an
+;;; error when there are duplicate keys.  That part of the spec
+;;; was added on 8 May 2016, which is why it was not implemented
+;;; by the sample implementation of 2 May 2016.  Because a duplicate
+;;; key "is an error" rather than "signals an error", testing for
+;;; that situation is glass-box, as is testing for immutability.
+
+;;; FIXME: glass-box
+
+(test (hash-table-mutable?
+       (hash-table number-comparator
+                   .25 .5 64 9999 81 9998 121 -11 144 -12))
+      #f)
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (guard (exn
+              (else 'eh))
+       (hash-table number-comparator .25 .5 .25 -.5))
+      'eh)
+
+;;; Spec says hash-table-set! must go left to right, but in
+;;; standard implementation it goes right to left.
+;;;
+;;; Comment by Will Clinger: the left-to-right requirement was
+;;; added to the spec on 8 May 2016, which is why it was not
+;;; implemented by the sample implementation of 2 May 2016.
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+             (ignored (hash-table-set! ht 'foo 13 'bar 14 'foo 18)))
+        (hash-table-ref ht 'foo))
+      18)
+
+;;; Spec says hash-table-empty-copy returns a mutable hash table,
+;;; but in standard implementation it returns an immutable hash
+;;; table if the given hash table is immutable.
+
+;;; FIXME: glass-box (immutable tables need not be supported)
+
+(test (hash-table-mutable?
+       (hash-table number-comparator))
+      #f)
+
+(test (hash-table-mutable?
+       (hash-table-empty-copy
+        (hash-table-copy (hash-table number-comparator) #f)))
+      #t)
+
+;;; hash-table-delete! seems to loop infinitely once it finds a key.
+;;;
+;;; Comment by Will Clinger: that bug was added by
+;;; commit e17c15203a934ab741300e59619f880f363c2b2f
+;;; on 26 September 2018.  I do not understand the purpose of that
+;;; commit, as its one change appears to have had no substantive
+;;; effect apart from inserting this bug.
+
+(test (let* ((ht
+              (hash-table default-comparator 'foo 1 'bar 2 'baz 3))
+             (ht (hash-table-copy ht #t)))
+        (hash-table-delete! ht 'foo)
+        (hash-table-size ht))
+      2)
+
+(test-end "srfi-125")
+
+; eof
diff --git a/test-suite/tests/srfi-125.test b/test-suite/tests/srfi-125.test
new file mode 100644
index 000000000..32580f0b6
--- /dev/null
+++ b/test-suite/tests/srfi-125.test
@@ -0,0 +1,45 @@
+;;;; srfi-125.test --- Test suite for SRFI-125.  -*- 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
+
+(import (srfi 64))
+
+(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-125-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
-- 
2.41.0




  parent reply	other threads:[~2023-12-06 23:15 UTC|newest]

Thread overview: 17+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-12-06 23:14 [PATCH v8 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 08/16] module: Add SRFI 126 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 09/16] module: Add SRFI 128 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 10/16] module: Add (scheme comparator) Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 11/16] module: Add (scheme sort) Maxim Cournoyer
2023-12-06 23:15 ` Maxim Cournoyer [this message]
2023-12-06 23:15 ` [PATCH v8 13/16] module: Add SRFI 151 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 14/16] module: Add SRFI 160 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 15/16] module: Add SRFI 178 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 16/16] module: Add SRFI 209 Maxim Cournoyer

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20231206231512.6505-13-maxim.cournoyer@gmail.com \
    --to=maxim.cournoyer@gmail.com \
    --cc=guile-devel@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).