* 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.
---
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
