This is not original work: it merely integrates and formats the work of
Taylan Ulrich Bayırlı/Kammer into Guile, with a few adjustments to avoid
warnings/fix missing imports. Thank you!
* module/srfi/srfi-126.sld: New file.
* test-suite/tests/srfi-126.test: New file.
* test-suite/tests/srfi-126-test.scm: Likewise.
* am/bootstrap.am (SOURCES): Register srfi-126 module.
* test-suite/Makefile.am (SCM_TESTS): Register test.
(EXTRA_DIST): Register test suite implementation.
* doc/ref/srfi-modules.texi (SRFI Support): Document new module.
* NEWS: Mention new interface.
* LICENSE: Mention extra licenses in use can be found...
* LICENSES: ... in this directory.
---
Changes in v9:
- Use R7RS library
- Add LICENSES/MIT.txt, for REUSE compliance
- Clarify extra licenses used in LICENSE file
Changes in v7:
- Register prerequisites for srfi/srfi-126.scm in am/bootstrap.am
Changes in v5:
- Update NEWS
Changes in v4:
- Mention Expat license of SRFI 126 in guile.tex copying section
Changes in v3:
- Rename SRFI-126 to SRFI 126 in text
Changes in v2:
- Remove extraneous (ice-9 hash-table) import
- Rename SRFI-69 to SRFI 69, SRFI-125 to SRFI 125 in text
LICENSE | 5 +
LICENSES/MIT.txt | 9 +
NEWS | 2 +
am/bootstrap.am | 3 +
doc/ref/guile.texi | 25 +-
doc/ref/srfi-modules.texi | 600 +++++++++++++++++++++++++++++
module/srfi/srfi-126.sld | 44 +++
module/srfi/srfi-126/126.body.scm | 286 ++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-126-test.scm | 271 +++++++++++++
test-suite/tests/srfi-126.test | 37 ++
11 files changed, 1283 insertions(+), 1 deletion(-)
create mode 100644 LICENSES/MIT.txt
create mode 100644 module/srfi/srfi-126.sld
create mode 100644 module/srfi/srfi-126/126.body.scm
create mode 100644 test-suite/tests/srfi-126-test.scm
create mode 100644 test-suite/tests/srfi-126.test
diff --git a/LICENSE b/LICENSE
index 3961579b8..e6713742c 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,2 +1,7 @@
Guile is covered under the terms of the GNU Lesser General Public
License, version 3 or later. See COPYING.LESSER and COPYING.
+
+Some third party libraries integrated into Guile, such as SRFI sample
+implementations, may carry their own license, identified via SPDX
+metadata. All the extra licences in use can be found under the
+LICENSES directory.
diff --git a/LICENSES/MIT.txt b/LICENSES/MIT.txt
new file mode 100644
index 000000000..2071b23b0
--- /dev/null
+++ b/LICENSES/MIT.txt
@@ -0,0 +1,9 @@
+MIT License
+
+Copyright (c) <year> <copyright holders>
+
+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.
diff --git a/NEWS b/NEWS
index e5cc3c7aa..8a0c77eb5 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,8 @@ definitely unused---this is notably the case for modules that
are only
used at macro-expansion time, such as (srfi srfi-26). In those cases,
the compiler reports it as "possibly unused".
+** Add (srfi 126), a hash tables library
+
* Bug fixes
** (ice-9 suspendable-ports) incorrect UTF-8 decoding
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 68d4b3334..7f62854cd 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -62,6 +62,8 @@ srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
$(COMPILE) -o "$@" "$<"
+# Register inter-modules dependencies.
+srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
SOURCES = \
@@ -349,6 +351,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-126.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 8414c3e2d..0540d2aab 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -23,8 +23,31 @@ any later version published by the Free Software Foundation;
with no
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.''
-@end copying
+Additionally, the documentation of the SRFI 126 module is adapted from
+its specification text, which is made available under the following
+Expat license:
+
+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.
+
+@end copying
@c Notes
@c
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 0cdf56923..8b3315180 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -2,6 +2,7 @@
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
@c Free Software Foundation, Inc.
+@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -64,6 +65,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 126:: R6RS-based hash tables.
* SRFI-171:: Transducers
@end menu
@@ -5662,6 +5664,604 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI 126
+@subsection SRFI 126 R6RS-based hash tables
+@cindex SRFI 126
+@cindex hash tables, r6rs-based
+
+@uref{http://srfi.schemers.org/srfi-126/srfi-126.html, SRFI 126}
+provides hash tables API that takes the R6RS hash tables API as a basis
+and makes backwards compatible additions such as support for weak hash
+tables, external representation, API support for double hashing
+implementations, and utility procedures. As an alternative to SRFI 125,
+it builds on the R6RS hash tables API instead of SRFI 69, with only
+fully backwards compatible additions such as weak and ephemeral hash
+tables, an external representation, and API support for hashing
+strategies that require a pair of hash functions. This SRFI does not
+attempt to specify thread-safety because typical multi-threaded
+use-cases will most likely involve locking more than just accesses and
+mutations of hash tables.
+
+@noindent
+The R6RS hash tables API is favored over SRFI 69 because the latter
+contains a crucial flaw: exposing the hash functions for the @code{eq?}
+and @code{eqv?} procedures is a hindrance for Scheme implementations
+with a moving garbage collector. SRFI 125 works around this by allowing
+the user-provided hash function passed to @code{make-hash-table} to be
+ignored by the implementation, and allowing the
+@code{hash-table-hash-function} procedure to return @code{#f} instead of
+the hash function passed to @code{make-hash-table}. R6RS avoids the
+issue by providing dedicated constructors for @code{eq?} and @code{eqv?}
+based hash tables, and returning @code{#f} when their hash function is
+queried.
+
+While the SRFI is based on the R6RS hash tables API instead of SRFI 69,
+the provided utility procedures nevertheless make it relatively
+straightforward to change code written for SRFI 69 to use the API
+specified herein. The utility procedures provided by this SRFI in
+addition to the R6RS API may be categorized as follows:
+
+@table @asis
+@item Constructors
+alist->eq-hashtable, alist->eqv-hashtable, alist->hashtable
+
+@item Access and mutation
+hashtable-lookup, hashtable-intern!
+
+@item Copying
+hashtable-empty-copy
+
+@item Key/value collections
+hashtable-values, hashtable-key-list, hashtable-value-list,
+hashtable-entry-lists
+
+@item Iteration
+hashtable-walk, hashtable-update-all!, hashtable-prune!,
+hashtable-merge!, hashtable-sum, hashtable-map->lset, hashtable-find
+
+@item Miscellaneous
+hashtable-empty?, hashtable-pop!, hashtable-inc!, hashtable-dec!
+@end table
+
+Additionally, this specification adheres to the R7RS rule of specifying
+a single return value for procedures which don't have meaningful return
+values.
+
+@menu
+* SRFI 126 API::
+* SRFI 126 Constructors::
+* SRFI 126 Procedures::
+* SRFI 126 Inspection::
+* SRFI 126 Hash functions::
+@end menu
+
+@node SRFI 126 API
+@subsubsection SRFI 126 API
+
+The @code{(srfi srfi-126)} library provides a set of operations on hash
+tables. A hash table is of a disjoint type that associates keys with
+values. Any object can be used as a key, provided a hash function or a
+pair of hash functions, and a suitable equivalence function, are
+available. A hash function is a procedure that maps keys to
+non-negative exact integer objects. It is the programmer's
+responsibility to ensure that the hash functions are compatible with the
+equivalence function, which is a procedure that accepts two keys and
+returns true if they are equivalent and @code{#f} otherwise. Standard
+hash tables for arbitrary objects based on the @code{eq?} and
+@code{eqv?} predicates (see R7RS section on “Equivalence predicates”)
+are provided. Also, hash functions for arbitrary objects, strings, and
+symbols are provided.
+
+Hash tables can store their key, value, or key and value weakly.
+Storing an object weakly means that the storage location of the object
+does not count towards the total storage locations in the program which
+refer to the object, meaning the object can be reclaimed as soon as no
+non-weak storage locations referring to the object remain. Weakly
+stored objects referring to each other in a cycle will be reclaimed as
+well if none of them are referred to from outside the cycle. When a
+weakly stored object is reclaimed, associations in the hash table which
+have the object as their key or value are deleted.
+
+Hash tables can also store their key and value in ephemeral storage
+pairs. The objects in an ephemeral storage pair are stored weakly, but
+both protected from reclamation as long as there remain non-weak
+references to the first object from outside the ephemeral storage pair.
+In particular, an @code{ephemeral-key} hash table (where the keys are
+the first objects in the ephemeral storage pairs), with an association
+mapping an element of a vector to the vector itself, may delete said
+association when no non-weak references remain to the vector nor its
+element in the rest of the program. If it were a @code{weak-key} hash
+table, the reference to the key from within the vector would cyclically
+protect the key and value from reclamation, even when no non-weak
+references to the key and value remained from outside the hash table.
+At the absence of such references between the key and value,
+@code{ephemeral-key} and @code{ephemeral-value} hash tables behave
+effectively equivalent to @code{weak-key} and @code{weak-value} hash
+tables.
+
+@code{ephemeral-key-and-value} hash tables use a pair of ephemeral
+storage pairs for each association: one where the key is the first
+object and one where the value is. This means that the key and value
+are protected from reclamation until no references remain to neither the
+key nor value from outside the hash table. In contrast, a
+@code{weak-key-and-value} hash table will delete an association as soon
+as either the key or value is reclaimed.
+
+This document uses the @var{hashtable} parameter name for arguments that
+must be hash tables, and the @var{key} parameter name for arguments that
+must be hash table keys.
+
+@node SRFI 126 Constructors
+@subsubsection SRFI 126 Constructors
+
+@deffn {Scheme Procedure} make-eq-hashtable
+@deffnx {Scheme Procedure} make-eq-hashtable capacity
+@deffnx {Scheme Procedure} make-eq-hashtable capacity weakness
+
+Return a newly allocated mutable hash table that accepts arbitrary
+objects as keys, and compares those keys with @code{eq?}. If the
+@var{capacity} argument is provided and not @code{#f}, it must be an
+exact non-negative integer and the initial capacity of the hash table is
+set to approximately @var{capacity} elements. The @var{weakness}
+argument, if provided, must be one of: @code{#f}, @code{weak-key},
+@code{weak-value}, @code{weak-key-and-value}, @code{ephemeral-key},
+@code{ephemeral-value}, and @code{ephemeral-key-and-value}, and
+determines the weakness or ephemeral status for the keys and values in
+the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} make-eqv-hashtable
+@deffnx {Scheme Procedure} make-eqv-hashtable capacity
+@deffnx {Scheme Procedure} make-eqv-hashtable capacity weakness
+
+Return a newly allocated mutable hash table that accepts arbitrary
+objects as keys, and compares those keys with @code{eqv?}. The
+semantics of the optional arguments are as in @code{make-eq-hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} make-hashtable hash equiv
+@deffnx {Scheme Procedure} make-hashtable hash equiv capacity
+@deffnx {Scheme Procedure} make-hashtable hash equiv capacity weakness
+
+If @var{hash} is @code{#f} and @var{equiv} is the @code{eq?} procedure,
+the semantics of @code{make-eq-hashtable} apply to the rest of the
+arguments. If @var{hash} is @code{#f} and @var{equiv} is the
+@code{eqv?} procedure, the semantics of @code{make-eqv-hashtable} apply
+to the rest of the arguments.
+
+Otherwise, @var{hash} must be a pair of hash functions or a hash
+function, and @var{equiv} must be a procedure. @var{equiv} should
+accept two keys as arguments and return a single value. None of the
+procedures should mutate the hash table returned by
+@code{make-hashtable}. The @code{make-hashtable} procedure returns a
+newly allocated mutable hash table using the function(s) specified by
+@var{hash} as its hash function(s), and @var{equiv} as the equivalence
+function used to compare keys. The semantics of the remaining arguments
+are as in @code{make-eq-hashtable} and @code{make-eqv-hashtable}.
+
+The @var{hash} functions and @var{equiv} should behave like pure
+functions on the domain of keys. For example, the @code{string-hash}
+and @code{string=?} procedures are permissible only if all keys are
+strings and the contents of those strings are never changed so long as
+any of them continues to serve as a key in the hash table. Furthermore,
+any pair of keys for which @var{equiv} returns true should be hashed to
+the same exact integer objects by the given @var{hash} function(s).
+
+@quotation Note
+Hash tables are allowed to cache the results of calling a hash function
+and equivalence function, so programs cannot rely on a hash function
+being called for every lookup or update. Furthermore any hash table
+operation may call a hash function more than once.
+@end quotation
+@end deffn
+
+@deffn {Scheme Procedure} alist->eq-hashtable alist
+@deffnx {Scheme Procedure} alist->eq-hashtable capacity alist
+@deffnx {Scheme Procedure} alist->eq-hashtable capacity weakness alist
+
+The semantics of this procedure can be described as:
+
+@lisp
+(let ((ht (make-eq-hashtable @var{capacity} @var{weakness})))
+ (for-each (lambda (entry)
+ (hashtable-set! ht (car entry) (cdr entry)))
+ (reverse alist))
+ ht)
+@end lisp
+
+where omission of the @var{capacity} and/or @var{weakness} arguments
+corresponds to their omission in the call to @code{make-eq-hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} alist->eqv-hashtable alist
+@deffnx {Scheme Procedure} alist->eqv-hashtable capacity alist
+@deffnx {Scheme Procedure} alist->eqv-hashtable capacity weakness alist
+
+This procedure is equivalent to @code{alist->eq-hashtable} except that
+@code{make-eqv-hashtable} is used to construct the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} alist->hashtable hash equiv alist
+@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity alist
+@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity weakness alist
+
+This procedure is equivalent to @code{alist->eq-hashtable} except that
+@code{make-hashtable} is used to construct the hash table, with the
+given @var{hash} and @var{equiv} arguments.
+@end deffn
+
+@deffn {Scheme Syntax} weakness weakness-symbol
+
+The @var{weakness-symbol} must correspond to one of the non-#f values
+accepted for the @var{weakness} argument of the constructor procedures,
+that is, @code{'weak-key}, @code{'weak-value},
+@code{'weak-key-and-value}, @code{'ephemeral-key},
+@code{'ephemeral-value}, or @code{'ephemeral-key-and-value}. Given such
+a symbol, it is returned as a datum. Passing any other argument is an
+error.
+@end deffn
+
+@node SRFI 126 Procedures
+@subsubsection SRFI 126 Procedures
+
+@deffn {Scheme Procedure} hashtable? obj
+
+Return @code{#t} if @var{obj} is a hash table, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-size hashtable
+
+Return the number of keys contained in @var{hashtable} as an exact
+integer object.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-ref hashtable key
+@deffnx {Scheme Procedure} hashtable-ref hashtable key default
+
+Return the value in @var{hashtable} associated with @var{key}. If
+@var{hashtable} does not contain an association for key, @var{default}
+is returned. If @var{hashtable} does not contain an association for key
+and the @var{default} argument is not provided, an error is signaled.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-set! hashtable key obj
+
+Change @var{hashtable} to associate @var{key} with @var{obj}, adding a
+new association or replacing any existing association for @var{key}, and
+return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-delete! hashtable key
+
+Remove any association for @var{key} within @var{hashtable} and return
+an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-contains? hashtable key
+
+Return @code{#t} if @var{hashtable} contains an association for
+@var{key}, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-lookup hashtable key
+
+Return two values: the value in @var{hashtable} associated with
+@var{key} or an unspecified value if there is none, and a boolean
+indicating whether an association was found.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-update! hashtable key proc
+@deffnx {Scheme Procedure} hashtable-update! hashtable key proc default
+
+@var{proc} should accept one argument, should return a single value, and
+should not mutate hashtable. The @code{hashtable-update!} procedure
+applies @var{proc} to the value in @var{hashtable} associated with
+@var{key}, or to @var{default} if @var{hashtable} does not contain an
+association for @var{key}. The @var{hashtable} is then changed to
+associate @var{key} with the value returned by @var{proc}. If
+@var{hashtable} does not contain an association for @var{key} and the
+@var{default} argument is not provided, an error should be signaled.
+@var{hashtable-update!} returns the value of the new association for
+@var{key} in @var{hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-intern! hashtable key default-proc
+
+@var{default-proc} should accept zero arguments, should return a single
+value, and should not mutate @var{hashtable}. The
+@code{hashtable-intern!} procedure returns the association for key in
+@var{hashtable} if there is one, otherwise it calls @var{default-proc}
+with zero arguments, associates its return value with @var{key} in
+@var{hashtable}, and returns that value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-copy hashtable
+@deffnx {Scheme Procedure} hashtable-copy hashtable mutable
+@deffnx {Scheme Procedure} hashtable-copy hashtable mutable weakness
+
+Return a copy of @var{hashtable}. If the @var{mutable} argument is
+provided and is true, the returned @var{hashtable} is mutable; otherwise
+it is immutable. If the optional @var{weakness} argument is provided,
+it determines the weakness of the copy, otherwise the weakness attribute
+of @var{hashtable} is used.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-clear! hashtable
+@deffnx {Scheme Procedure} hashtable-clear! hashtable capacity
+
+Remove all associations from @var{hashtable} and return an unspecified
+value. If @var{capacity} is provided and not @code{#f}, it must be an
+exact non-negative integer and the current capacity of the
+@var{hashtable} is reset to approximately @var{capacity} elements.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-empty-copy hashtable
+@deffnx {Scheme Procedure} hashtable-empty-copy hashtable capacity
+
+Return a newly allocated mutable @var{hashtable} that has the same hash
+and equivalence functions and weakness attribute as @var{hashtable}.
+The @var{capacity} argument may be @code{#t} to set the initial capacity
+of the copy to approximately @samp{(hashtable-size @var{hashtable})}
+elements; otherwise the semantics of @code{make-eq-hashtable} apply to
+the @var{capacity} argument.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-keys hashtable
+
+Return a vector of all keys in @var{hashtable}. The order of the vector
+is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-values hashtable
+
+Return a vector of all values in @var{hashtable}. The order of the
+vector is unspecified, and is not guaranteed to match the order of keys
+in the result of @code{hashtable-keys}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-entries hashtable
+
+Return two values, a vector of the keys in @var{hashtable}, and a vector
+of the corresponding values.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-key-list hashtable
+
+Return a list of all keys in @var{hashtable}. The order of the list is
+unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-value-list hashtable
+
+Return a list of all values in @var{hashtable}. The order of the list
+is unspecified, and is not guaranteed to match the order of keys in the
+result of @code{hashtable-key-list}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-entry-lists hashtable
+
+Return two values, a list of the keys in @var{hashtable}, and a list of
+the corresponding values.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-walk hashtable proc
+
+@var{proc} should accept two arguments, and should not mutate
+@var{hashtable}. The @code{hashtable-walk} procedure applies @var{proc}
+once for every association in @var{hashtable}, passing it the key and
+value as arguments. The order in which @var{proc} is applied to the
+associations is unspecified. Return values of @var{proc} are ignored.
+@code{hashtable-walk} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-update-all! hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-update-all!}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and changes
+the value of the association to the return value of @var{proc}. The
+order in which @var{proc} is applied to the associations is unspecified.
+@code{hashtable-update-all!} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-prune! hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-prune!}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and deletes
+the association if @var{proc} returns a true value. The order in which
+@var{proc} is applied to the associations is unspecified.
+@code{hashtable-prune!} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-merge! hashtable-dest hashtable-source
+
+Effectively equivalent to:
+
+@lisp
+(begin
+ (hashtable-walk @var{hashtable-source}
+ (lambda (key value)
+ (hashtable-set! @var{hashtable-dest} key value)))
+ hashtable-dest)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-sum hashtable init proc
+
+@var{proc} should accept three arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-sum}
+procedure accumulates a result by applying @var{proc} once for every
+association in @var{hashtable}, passing it as arguments: the key, the
+value, and the result of the previous application or @var{init} at the
+first application. The order in which @var{proc} is applied to the
+associations is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-map->lset hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-map->lset}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and
+accumulates the returned values into a list. The order in which
+@var{proc} is applied to the associations, and the order of the results
+in the returned list, are unspecified.
+
+@quotation note
+This procedure can trivially imitate @code{hashtable->alist}:
+@samp{(hashtable-map->lset @var{hashtable} cons)}.
+@end quotation
+
+@quotation warning
+Since the order of the results is unspecified, the returned list should
+be treated as a set or multi-set. Relying on the order of results will
+produce unpredictable programs.
+@end quotation
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-find hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-find}
+procedure applies @var{proc} to associations in @var{hashtable} in an
+unspecified order until one of the applications returns a true value or
+the associations are exhausted. Three values are returned: the key and
+value of the matching association or two unspecified values if none
+matched, and a boolean indicating whether any association matched.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-empty? hashtable
+
+Effectively equivalent to @samp{(zero? (hashtable-size @var{hashtable}))}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-pop! hashtable
+
+Effectively equivalent to:
+
+@lisp
+(let-values (((key value found?)
+ (hashtable-find @var{hashtable} (lambda (k v) #t))))
+ (when (not found?)
+ (error))
+ (hashtable-delete! @var{hashtable} key)
+ (values key value))
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-inc! hashtable key
+@deffnx {Scheme Procedure} hashtable-inc! hashtable key number
+
+Effectively equivalent to:
+
+@lisp
+(hashtable-update! @var{hashtable} @var{key} (lambda (v) (+ v @var{number})) 0)
+@end lisp
+
+where @var{number} is 1 when not provided.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-dec! hashtable key
+@deffnx {Scheme Procedure} hashtable-dec! hashtable key number
+
+Effectively equivalent to:
+
+@lisp
+(hashtable-update! @var{hashtable} @var{key} (lambda (v) (- v @var{number})) 0)
+@end lisp
+
+where @var{number} is 1 when not provided.
+@end deffn
+
+@node SRFI 126 Inspection
+@subsubsection SRFI 126 Inspection
+
+@deffn {Scheme Procedure} hashtable-equivalence-function hashtable
+
+Return the equivalence function used by @var{hashtable} to compare
+keys. For hash tables created with @code{make-eq-hashtable} and
+@code{make-eqv-hashtable}, returns @code{eq?} and @code{eqv?}
+respectively.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-hash-function hashtable
+
+Return the hash function(s) used by @var{hashtable}, that is, either a
+procedure, or a pair of procedures. For hash tables created by
+@code{make-eq-hashtable} or @code{make-eqv-hashtable}, @code{#f} is
+returned.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-weakness hashtable
+
+Return the weakness attribute of @var{hashtable}. The same values that
+are accepted as the weakness argument in the constructor procedures are
+returned. This procedure may expose the fact that @code{weak-key} and
+@code{weak-value} hash tables are implemented as @var{ephemeral-key} and
+@var{ephemeral-value} hash tables, returning symbols indicating the
+latter even when the former were used to construct the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-mutable? hashtable
+
+Return @code{#t} if @var{hashtable} is mutable, otherwise @code{#f}.
+@end deffn
+
+@node SRFI 126 Hash functions
+@subsubsection SRFI 126 Hash functions
+
+The @code{equal-hash}, @code{string-hash}, and @code{string-ci-hash}
+procedures of this section are acceptable as the hash functions of a
+hash table only if the keys on which they are called are not mutated
+while they remain in use as keys in the hash table.
+
+An implementation may initialize its hash functions with a random salt
+value at program startup, meaning they are not guaranteed to return the
+same values for the same inputs across multiple runs of a program. If
+however the environment variable @env{SRFI_126_HASH_SEED} is set to a
+non-empty string before program startup, then the salt value is derived
+from that string in a deterministic manner.
+
+@deffn {Scheme Syntax} hash-salt
+
+Expand to a form evaluating to an exact non-negative integer that lies
+within the fixnum range of the implementation. The value the expanded
+form evaluates to remains constant throughout the execution of the
+program. It is random for every run of the program, except when the
+environment variable @env{SRFI_126_HASH_SEED} is set to a non-empty
+string before program startup, in which case it is derived from the
+value of that environment variable in a deterministic manner.
+@end deffn
+
+@deffn {Scheme Procedure} equal-hash obj
+
+Return an integer hash value for @var{obj}, based on its structure and
+current contents. This hash function is suitable for use with
+@code{equal?} as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} string-hash string
+
+Return an integer hash value for @var{string}, based on its current
+contents. This hash function is suitable for use with @code{string=?}
+as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci-hash string
+
+Return an integer hash value for @var{string} based on its current
+contents, ignoring case. This hash function is suitable for use with
+@code{string-ci=?} as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-hash symbol
+
+Return an integer hash value for @var{symbol}.
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-126.sld b/module/srfi/srfi-126.sld
new file mode 100644
index 000000000..34276199f
--- /dev/null
+++ b/module/srfi/srfi-126.sld
@@ -0,0 +1,44 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kam...@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 126)
+ (export
+ make-eq-hashtable make-eqv-hashtable make-hashtable
+ alist->eq-hashtable alist->eqv-hashtable alist->hashtable
+ weakness
+ hashtable?
+ hashtable-size
+ hashtable-ref hashtable-set! hashtable-delete!
+ hashtable-contains?
+ hashtable-lookup hashtable-update! hashtable-intern!
+ hashtable-copy hashtable-clear! hashtable-empty-copy
+ hashtable-keys hashtable-values hashtable-entries
+ hashtable-key-list hashtable-value-list hashtable-entry-lists
+ hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge!
+ hashtable-sum hashtable-map->lset hashtable-find
+ hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec!
+ hashtable-equivalence-function hashtable-hash-function hashtable-weakness
+ hashtable-mutable?
+ hash-salt equal-hash string-hash string-ci-hash symbol-hash)
+ (import
+ (scheme base)
+ (scheme case-lambda)
+ (scheme process-context)
+ (srfi 1)
+ (srfi 27))
+ (cond-expand
+ (guile
+ ;; Guile doesn't have (r6rs ...) prefixed R6RS library modules,
+ ;; and it can use its own R6RS hashtables implementation instead
+ ;; of the bundled Larceny-licensed r6rs/hashtables.sld library,
+ ;; which is non-free due to restricting use to "lawful purposes".
+ (import (rnrs enums (6)))
+ (import (prefix (rnrs hashtables (6)) rnrs-)))
+ (else
+ (import (r6rs enums))
+ (import (prefix (r6rs hashtables) rnrs-))))
+ (begin
+ ;; Smallest allowed in R6RS.
+ (define (greatest-fixnum) (expt 23 2)))
+ (include "srfi-126/126.body.scm"))
diff --git a/module/srfi/srfi-126/126.body.scm
b/module/srfi/srfi-126/126.body.scm
new file mode 100644
index 000000000..51dc55790
--- /dev/null
+++ b/module/srfi/srfi-126/126.body.scm
@@ -0,0 +1,286 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kam...@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define make-eq-hashtable
+ (case-lambda
+ (() (make-eq-hashtable #f #f))
+ ((capacity) (make-eq-hashtable capacity #f))
+ ((capacity weakness)
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (if capacity
+ (rnrs-make-eq-hashtable capacity)
+ (rnrs-make-eq-hashtable)))))
+
+(define make-eqv-hashtable
+ (case-lambda
+ (() (make-eqv-hashtable #f #f))
+ ((capacity) (make-eqv-hashtable capacity #f))
+ ((capacity weakness)
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (if capacity
+ (rnrs-make-eqv-hashtable capacity)
+ (rnrs-make-eqv-hashtable)))))
+
+(define make-hashtable
+ (case-lambda
+ ((hash equiv) (make-hashtable hash equiv #f #f))
+ ((hash equiv capacity) (make-hashtable hash equiv capacity #f))
+ ((hash equiv capacity weakness)
+ (cond
+ ((and (not hash) (eq? equiv eq?))
+ (make-eq-hashtable capacity weakness))
+ ((and (not hash) (eq? equiv eqv?))
+ (make-eqv-hashtable capacity weakness))
+ (else
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (let ((hash (if (pair? hash)
+ (car hash)
+ hash)))
+ (if capacity
+ (rnrs-make-hashtable hash equiv capacity)
+ (rnrs-make-hashtable hash equiv))))))))
+
+(define (alist->eq-hashtable . args)
+ (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+ (apply alist->hashtable #f eqv? args))
+
+(define alist->hashtable
+ (case-lambda
+ ((hash equiv alist)
+ (alist->hashtable hash equiv #f #f alist))
+ ((hash equiv capacity alist)
+ (alist->hashtable hash equiv capacity #f alist))
+ ((hash equiv capacity weakness alist)
+ (let ((hashtable (make-hashtable hash equiv capacity weakness)))
+ (for-each (lambda (entry)
+ (hashtable-set! hashtable (car entry) (cdr entry)))
+ (reverse alist))
+ hashtable))))
+
+(define-enumeration weakness
+ (weak-key
+ weak-value
+ weak-key-and-value
+ ephemeral-key
+ ephemeral-value
+ ephemeral-key-and-value)
+ weakness-set)
+
+(define hashtable? rnrs-hashtable?)
+
+(define hashtable-size rnrs-hashtable-size)
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define hashtable-ref
+ (case-lambda
+ ((hashtable key)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (error "No such key in hashtable." hashtable key)
+ value)))
+ ((hashtable key default)
+ (rnrs-hashtable-ref hashtable key default))))
+
+(define hashtable-set! rnrs-hashtable-set!)
+
+(define hashtable-delete! rnrs-hashtable-delete!)
+
+(define hashtable-contains? rnrs-hashtable-contains?)
+
+(define (hashtable-lookup hashtable key)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (values #f #f)
+ (values value #t))))
+
+(define hashtable-update!
+ (case-lambda
+ ((hashtable key proc) (hashtable-update! hashtable key proc nil))
+ ((hashtable key proc default)
+ (rnrs-hashtable-update!
+ hashtable key
+ (lambda (value)
+ (if (nil? value)
+ (error "No such key in hashtable." hashtable key)
+ (proc value)))
+ default))))
+
+;;; XXX This could be implemented at the platform level to eliminate the second
+;;; lookup for the key.
+(define (hashtable-intern! hashtable key default-proc)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (let ((value (default-proc)))
+ (hashtable-set! hashtable key value)
+ value)
+ value)))
+
+(define hashtable-copy
+ (case-lambda
+ ((hashtable) (hashtable-copy hashtable #f #f))
+ ((hashtable mutable) (hashtable-copy hashtable mutable #f))
+ ((hashtable mutable weakness)
+ (when weakness
+ (error "No weak or ephemeral tables supported."))
+ (rnrs-hashtable-copy hashtable mutable))))
+
+(define hashtable-clear!
+ (case-lambda
+ ((hashtable) (rnrs-hashtable-clear! hashtable))
+ ((hashtable capacity)
+ (if capacity
+ (rnrs-hashtable-clear! hashtable capacity)
+ (rnrs-hashtable-clear! hashtable)))))
+
+(define hashtable-empty-copy
+ (case-lambda
+ ((hashtable) (hashtable-empty-copy hashtable #f))
+ ((hashtable capacity)
+ (make-hashtable (hashtable-hash-function hashtable)
+ (hashtable-equivalence-function hashtable)
+ (if (eq? #t capacity)
+ (hashtable-size hashtable)
+ capacity)
+ (hashtable-weakness hashtable)))))
+
+(define hashtable-keys rnrs-hashtable-keys)
+
+(define (hashtable-values hashtable)
+ (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+ values))
+
+(define hashtable-entries rnrs-hashtable-entries)
+
+(define (hashtable-key-list hashtable)
+ (hashtable-map->lset hashtable (lambda (key value) key)))
+
+(define (hashtable-value-list hashtable)
+ (hashtable-map->lset hashtable (lambda (key value) value)))
+
+(define (hashtable-entry-lists hashtable)
+ (let ((keys '())
+ (vals '()))
+ (hashtable-walk hashtable
+ (lambda (key val)
+ (set! keys (cons key keys))
+ (set! vals (cons val vals))))
+ (values keys vals)))
+
+;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!,
+;;; and hashtable-sum should be implemented more efficiently at the platform
+;;; level. In particular, they should not allocate intermediate vectors or
+;;; lists to hold the keys or values that are being operated on.
+
+(define (hashtable-walk hashtable proc)
+ (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+ (vector-for-each proc keys values)))
+
+(define (hashtable-update-all! hashtable proc)
+ (let-values (((keys values) (hashtable-entries hashtable)))
+ (vector-for-each (lambda (key value)
+ (hashtable-set! hashtable key (proc key value)))
+ keys values)))
+
+(define (hashtable-prune! hashtable proc)
+ (let-values (((keys values) (hashtable-entries hashtable)))
+ (vector-for-each (lambda (key value)
+ (when (proc key value)
+ (hashtable-delete! hashtable key)))
+ keys values)))
+
+(define (hashtable-merge! hashtable-dest hashtable-source)
+ (hashtable-walk hashtable-source
+ (lambda (key value)
+ (hashtable-set! hashtable-dest key value)))
+ hashtable-dest)
+
+(define (hashtable-sum hashtable init proc)
+ (let-values (((keys vals) (hashtable-entry-lists hashtable)))
+ (fold proc init keys vals)))
+
+(define (hashtable-map->lset hashtable proc)
+ (hashtable-sum hashtable '()
+ (lambda (key value accumulator)
+ (cons (proc key value) accumulator))))
+
+;;; XXX If available, let-escape-continuation might be more efficient than
+;;; call/cc here.
+(define (hashtable-find hashtable proc)
+ (call/cc
+ (lambda (return)
+ (hashtable-walk hashtable
+ (lambda (key value)
+ (when (proc key value)
+ (return key value #t))))
+ (return #f #f #f))))
+
+(define (hashtable-empty? hashtable)
+ (zero? (hashtable-size hashtable)))
+
+;;; XXX A platform-level implementation could avoid allocating the constant
true
+;;; function and the lookup for the key in the delete operation.
+(define (hashtable-pop! hashtable)
+ (if (hashtable-empty? hashtable)
+ (error "Cannot pop from empty hashtable." hashtable)
+ (let-values (((key value found?)
+ (hashtable-find hashtable (lambda (k v) #t))))
+ (hashtable-delete! hashtable key)
+ (values key value))))
+
+(define hashtable-inc!
+ (case-lambda
+ ((hashtable key) (hashtable-inc! hashtable key 1))
+ ((hashtable key number)
+ (hashtable-update! hashtable key (lambda (v) (+ v number)) 0))))
+
+(define hashtable-dec!
+ (case-lambda
+ ((hashtable key) (hashtable-dec! hashtable key 1))
+ ((hashtable key number)
+ (hashtable-update! hashtable key (lambda (v) (- v number)) 0))))
+
+(define hashtable-equivalence-function rnrs-hashtable-equivalence-function)
+
+(define hashtable-hash-function rnrs-hashtable-hash-function)
+
+(define (hashtable-weakness hashtable) #f)
+
+(define hashtable-mutable? rnrs-hashtable-mutable?)
+
+(define *hash-salt*
+ (let ((seed (get-environment-variable "SRFI_126_HASH_SEED")))
+ (if (or (not seed) (string=? seed ""))
+ (random-integer (greatest-fixnum))
+ (modulo
+ (fold (lambda (char result)
+ (+ (char->integer char) result))
+ 0
+ (string->list seed))
+ (greatest-fixnum)))))
+
+(define (hash-salt) *hash-salt*)
+
+(define equal-hash rnrs-equal-hash)
+
+(define string-hash rnrs-string-hash)
+
+(define string-ci-hash rnrs-string-ci-hash)
+
+(define symbol-hash rnrs-symbol-hash)
+
+;; Local Variables:
+;; eval: (put 'hashtable-walk 'scheme-indent-function 1)
+;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-prune! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-sum 'scheme-indent-function 2)
+;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1)
+;; eval: (put 'hashtable-find 'scheme-indent-function 1)
+;; End:
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 81e63bce2..eaa5e1fdb 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-126.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -208,6 +209,7 @@ EXTRA_DIST = \
$(SCM_TESTS) \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
+ tests/srfi-126-test.scm \
ChangeLog-2008
diff --git a/test-suite/tests/srfi-126-test.scm
b/test-suite/tests/srfi-126-test.scm
new file mode 100644
index 000000000..69d8ac62d
--- /dev/null
+++ b/test-suite/tests/srfi-126-test.scm
@@ -0,0 +1,271 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kam...@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; This doesn't test weakness, external representation, and quasiquote.
+
+(test-begin "SRFI-126")
+
+(test-group "constructors & inspection"
+ (test-group "eq"
+ (let ((tables (list (make-eq-hashtable)
+ (make-eq-hashtable 10)
+ (make-eq-hashtable #f #f)
+ (make-hashtable #f eq?)
+ (alist->eq-hashtable '((a . b) (c . d)))
+ (alist->eq-hashtable 10 '((a . b) (c . d)))
+ (alist->eq-hashtable #f #f '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label #f (hashtable-hash-function table))
+ (test-eq label eq? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))))
+ (test-group "eqv"
+ (let ((tables (list (make-eqv-hashtable)
+ (make-eqv-hashtable 10)
+ (make-eqv-hashtable #f #f)
+ (make-hashtable #f eqv?)
+ (alist->eqv-hashtable '((a . b) (c . d)))
+ (alist->eqv-hashtable 10 '((a . b) (c . d)))
+ (alist->eqv-hashtable #f #f '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label #f (hashtable-hash-function table))
+ (test-eq label eqv? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))))
+ (test-group "equal"
+ (let ((tables (list (make-hashtable equal-hash equal?)
+ (make-hashtable equal-hash equal? 10)
+ (make-hashtable equal-hash equal? #f #f)
+ (alist->hashtable equal-hash equal?
+ '((a . b) (c . d)))
+ (alist->hashtable equal-hash equal? 10
+ '((a . b) (c . d)))
+ (alist->hashtable equal-hash equal? #f #f
+ '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label equal-hash (hashtable-hash-function table))
+ (test-eq label equal? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))
+ (let ((table (make-hashtable (cons equal-hash equal-hash) equal?)))
+ (let ((hash (hashtable-hash-function table)))
+ (test-assert (or (eq? equal-hash hash)
+ (and (eq? equal-hash (car hash))
+ (eq? equal-hash (cdr hash)))))))))
+ (test-group "alist"
+ (let ((tables (list (alist->eq-hashtable '((a . b) (a . c)))
+ (alist->eqv-hashtable '((a . b) (a . c)))
+ (alist->hashtable equal-hash equal?
+ '((a . b) (a . c))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-eq label 'b (hashtable-ref table 'a)))))))
+
+(test-group "procedures"
+ (test-group "basics"
+ (let ((table (make-eq-hashtable)))
+ (test-group "ref"
+ (test-error (hashtable-ref table 'a))
+ (test-eq 'b (hashtable-ref table 'a 'b))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-eqv 0 (hashtable-size table)))
+ (test-group "set"
+ (hashtable-set! table 'a 'c)
+ (test-eq 'c (hashtable-ref table 'a))
+ (test-eq 'c (hashtable-ref table 'a 'b))
+ (test-assert (hashtable-contains? table 'a))
+ (test-eqv 1 (hashtable-size table)))
+ (test-group "delete"
+ (hashtable-delete! table 'a)
+ (test-error (hashtable-ref table 'a))
+ (test-eq 'b (hashtable-ref table 'a 'b))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-eqv 0 (hashtable-size table)))))
+ (test-group "advanced"
+ (let ((table (make-eq-hashtable)))
+ (test-group "lookup"
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-assert (not found?))))
+ (test-group "update"
+ (test-error (hashtable-update! table 'a (lambda (x) (+ x 1))))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv 1 x)
+ (test-assert found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)))
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv x 2)
+ (test-assert found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv x 3)
+ (test-assert found?)))
+ (test-group "intern"
+ (test-eqv 0 (hashtable-intern! table 'b (lambda () 0)))
+ (test-eqv 0 (hashtable-intern! table 'b (lambda () 1))))))
+ (test-group "copy/clear"
+ (let ((table (alist->hashtable equal-hash equal? '((a . b)))))
+ (test-group "copy"
+ (let ((table2 (hashtable-copy table)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (test-error (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #f)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (test-error (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #t)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (hashtable-set! table2 'a 'c)
+ (test-eq 'c (hashtable-ref table2 'a)))
+ (let ((table2 (hashtable-copy table #f #f)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq #f (hashtable-weakness table2))))
+ (test-group "clear"
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2)
+ (test-eqv 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2 10)
+ (test-eqv 0 (hashtable-size table2))))
+ (test-group "empty-copy"
+ (let ((table2 (hashtable-empty-copy table)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eqv 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-empty-copy table 10)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eqv 0 (hashtable-size table2))))))
+ (test-group "keys/values"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table))))
+ (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table))))
+ (let-values (((keys values) (hashtable-entries table)))
+ (test-assert (lset= eq? '(a c) (vector->list keys)))
+ (test-assert (lset= eq? '(b d) (vector->list values))))
+ (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(b d) (hashtable-value-list table)))
+ (let-values (((keys values) (hashtable-entry-lists table)))
+ (test-assert (lset= eq? '(a c) keys))
+ (test-assert (lset= eq? '(b d) values)))))
+ (test-group "iteration"
+ (test-group "walk"
+ (let ((keys '())
+ (values '()))
+ (hashtable-walk (alist->eq-hashtable '((a . b) (c . d)))
+ (lambda (k v)
+ (set! keys (cons k keys))
+ (set! values (cons v values))))
+ (test-assert (lset= eq? '(a c) keys))
+ (test-assert (lset= eq? '(b d) values))))
+ (test-group "update-all"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-update-all! table
+ (lambda (k v)
+ (string->symbol (string-append (symbol->string v) "x"))))
+ (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(bx dx) (hashtable-value-list table)))))
+ (test-group "prune"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-prune! table (lambda (k v) (eq? k 'a)))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-assert (hashtable-contains? table 'c))))
+ (test-group "merge"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d))))
+ (table2 (alist->eq-hashtable '((a . x) (e . f)))))
+ (hashtable-merge! table table2)
+ (test-assert (lset= eq? '(a c e) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(x d f) (hashtable-value-list table)))))
+ (test-group "sum"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= eq? '(a b c d)
+ (hashtable-sum table '()
+ (lambda (k v acc)
+ (lset-adjoin eq? acc k v)))))))
+ (test-group "map->lset"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= equal? '((a . b) (c . d))
+ (hashtable-map->lset table cons)))))
+ (test-group "find"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (let-values (((k v f?) (hashtable-find table
+ (lambda (k v)
+ (eq? k 'a)))))
+ (test-assert (and f? (eq? k 'a) (eq? v 'b))))
+ (let-values (((k v f?) (hashtable-find table (lambda (k v) #f))))
+ (test-assert (not f?)))))
+ (test-group "misc"
+ (test-group "empty?"
+ (test-assert (hashtable-empty? (alist->eq-hashtable '())))
+ (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a .
b)))))))
+ (test-group "pop!"
+ (test-error (hashtable-pop! (make-eq-hashtable)))
+ (let ((table (alist->eq-hashtable '((a . b)))))
+ (let-values (((k v) (hashtable-pop! table)))
+ (test-eq 'a k)
+ (test-eq 'b v)
+ (test-assert (hashtable-empty? table)))))
+ (test-group "inc!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-inc! table 'a)
+ (test-eqv 1 (hashtable-ref table 'a))
+ (hashtable-inc! table 'a 2)
+ (test-eqv 3 (hashtable-ref table 'a))))
+ (test-group "dec!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-dec! table 'a)
+ (test-eqv -1 (hashtable-ref table 'a))
+ (hashtable-dec! table 'a 2)
+ (test-eqv -3 (hashtable-ref table 'a)))))))
+
+(test-group "hashing"
+ (test-assert (and (exact-integer? (hash-salt))))
+ (test-assert (not (negative? (hash-salt))))
+ (test-assert (= (equal-hash (list "foo" 'bar 42))
+ (equal-hash (list "foo" 'bar 42))))
+ (test-assert (= (string-hash (string-copy "foo"))
+ (string-hash (string-copy "foo"))))
+ (test-assert (= (string-ci-hash (string-copy "foo"))
+ (string-ci-hash (string-copy "FOO"))))
+ (test-assert (= (symbol-hash (string->symbol "foo"))
+ (symbol-hash (string->symbol "foo")))))
+
+(test-end "SRFI-126")
+
+(display
+ (string-append
+ "\n"
+ "NOTE: On implementations using the (r6rs hashtables) library from
Larceny,\n"
+ " 14 tests are expected to fail in relation to make-eq-hashtable and\n"
+ " make-eqv-hashtable returning hashtables whose hash functions are\n"
+ " exposed instead of being #f. We have no obvious way to detect this\n"
+ " within this portable test suite, hence no XFAIL results.\n"))
+
+;; Local Variables:
+;; eval: (put (quote test-group) (quote scheme-indent-function) 1)
+;; End:
diff --git a/test-suite/tests/srfi-126.test b/test-suite/tests/srfi-126.test
new file mode 100644
index 000000000..3a9283205
--- /dev/null
+++ b/test-suite/tests/srfi-126.test
@@ -0,0 +1,37 @@
+;;; srfi-126.test --- Test suite for SRFI-126. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(define-module (test-srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-126))
+
+(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-126-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
