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.scm: 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.
---
(no changes since v5)
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
NEWS | 3 +
am/bootstrap.am | 1 +
doc/ref/guile.texi | 25 +-
doc/ref/srfi-modules.texi | 600 +++++++++++++++++++++++++++++
module/srfi/srfi-126.scm | 396 +++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-126-test.scm | 289 ++++++++++++++
test-suite/tests/srfi-126.test | 49 +++
8 files changed, 1364 insertions(+), 1 deletion(-)
create mode 100644 module/srfi/srfi-126.scm
create mode 100644 test-suite/tests/srfi-126-test.scm
create mode 100644 test-suite/tests/srfi-126.test
diff --git a/NEWS b/NEWS
index e5cc3c7aa..31107a76d 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,9 @@ 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
+** Add (srfi 128), a comparators library
+
* Bug fixes
** (ice-9 suspendable-ports) incorrect UTF-8 decoding
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 68d4b3334..3586f0873 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -349,6 +349,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-126.scm \
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.scm b/module/srfi/srfi-126.scm
new file mode 100644
index 000000000..ce91fd158
--- /dev/null
+++ b/module/srfi/srfi-126.scm
@@ -0,0 +1,396 @@
+;;; srfi-126.scm -- SRFI 126 - R6RS-based hashtables.
+
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). 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.
+
+(define-module (srfi srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 control)
+ #:use-module ((rnrs hashtables) #:select (equal-hash
+ string-hash
+ string-ci-hash))
+ #: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)
+ #:re-export (equal-hash string-hash string-ci-hash))
+
+(define-record-type <hashtable>
+ (%make-hashtable %table %hash %assoc hash equiv weakness mutable)
+ hashtable?
+ (%table %hashtable-table)
+ (%hash %hashtable-hash)
+ (%assoc %hashtable-assoc)
+ (hash hashtable-hash-function)
+ (equiv hashtable-equivalence-function)
+ (weakness hashtable-weakness)
+ (mutable hashtable-mutable? %hashtable-set-mutable!))
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define (make-table capacity weakness)
+ (let ((capacity (or capacity 32)))
+ (case weakness
+ ((#f) (make-hash-table capacity))
+ ((weak-key) (make-weak-key-hash-table capacity))
+ ((weak-value) (make-weak-value-hash-table capacity))
+ ((weak-key-and-value) (make-doubly-weak-hash-table capacity))
+ (else (error "Hashtable weakness not supported." weakness)))))
+
+(define* (make-eq-hashtable #:optional capacity weakness)
+ (let ((table (make-table capacity weakness)))
+ (%make-hashtable table hashq assq #f eq? weakness #t)))
+
+(define* (make-eqv-hashtable #:optional capacity weakness)
+ (let ((table (make-table capacity weakness)))
+ (%make-hashtable table hashv assv #f eqv? weakness #t)))
+
+(define* (make-hashtable hash equiv #:optional 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
+ (let* ((table (make-table capacity weakness))
+ (hash (if (pair? hash)
+ (car hash)
+ hash))
+ (%hash (lambda (obj bound)
+ (modulo (hash obj) bound)))
+ (assoc (lambda (key alist)
+ (find (lambda (entry)
+ (equiv (car entry) key))
+ alist))))
+ (%make-hashtable table %hash assoc hash equiv weakness #t)))))
+
+(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 ((ht (make-hashtable hash equiv capacity weakness)))
+ (for-each (lambda (entry)
+ (hashtable-set! ht (car entry) (cdr entry)))
+ (reverse alist))
+ ht))))
+
+(define-syntax weakness
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <sym>)
+ (let ((sym (syntax->datum #'<sym>)))
+ (case sym
+ ((weak-key weak-value weak-key-and-value ephemeral-key
+ ephemeral-value ephemeral-key-and-value)
+ #''sym)
+ (else
+ (error "Bad weakness symbol." sym))))))))
+
+(define (hashtable-size ht)
+ (hash-count (const #t) (%hashtable-table ht)))
+
+(define* (%hashtable-ref ht key default)
+ (hashx-ref (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key default))
+
+(define* (hashtable-ref ht key #:optional (default nil))
+ (let ((val (%hashtable-ref ht key default)))
+ (if (nil? val)
+ (error "No association for key in hashtable." key ht)
+ val)))
+
+(define (assert-mutable ht)
+ (when (not (hashtable-mutable? ht))
+ (error "Hashtable is immutable." ht)))
+
+(define (hashtable-set! ht key value)
+ (assert-mutable ht)
+ (hashx-set! (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key value)
+ *unspecified*)
+
+(define (hashtable-delete! ht key)
+ (assert-mutable ht)
+ (hashx-remove! (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key)
+ *unspecified*)
+
+(define (hashtable-contains? ht key)
+ (not (nil? (%hashtable-ref ht key nil))))
+
+(define (hashtable-lookup ht key)
+ (let ((val (%hashtable-ref ht key nil)))
+ (if (nil? val)
+ (values #f #f)
+ (values val #t))))
+
+(define* (hashtable-update! ht key updater #:optional (default nil))
+ (assert-mutable ht)
+ (let ((handle (hashx-create-handle!
+ (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key nil)))
+ (if (eq? nil (cdr handle))
+ (if (nil? default)
+ (error "No association for key in hashtable." key ht)
+ (set-cdr! handle (updater default)))
+ (set-cdr! handle (updater (cdr handle))))
+ (cdr handle)))
+
+(define (hashtable-intern! ht key default-proc)
+ (assert-mutable ht)
+ (let ((handle (hashx-create-handle!
+ (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key nil)))
+ (when (nil? (cdr handle))
+ (set-cdr! handle (default-proc)))
+ (cdr handle)))
+
+(define* (hashtable-copy ht #:optional mutable weakness)
+ (let ((copy (hashtable-empty-copy ht (hashtable-size ht) weakness)))
+ (hashtable-walk ht
+ (lambda (k v)
+ (hashtable-set! copy k v)))
+ (%hashtable-set-mutable! copy mutable)
+ copy))
+
+(define* (hashtable-clear! ht #:optional _capacity)
+ (assert-mutable ht)
+ (hash-clear! (%hashtable-table ht))
+ *unspecified*)
+
+(define* (hashtable-empty-copy ht #:optional capacity weakness)
+ (make-hashtable (hashtable-hash-function ht)
+ (hashtable-equivalence-function ht)
+ (case capacity
+ ((#f) #f)
+ ((#t) (hashtable-size ht))
+ (else capacity))
+ (or weakness (hashtable-weakness ht))))
+
+(define (hashtable-keys ht)
+ (let ((keys (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (+ i 1)))
+ keys))
+
+(define (hashtable-values ht)
+ (let ((vals (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! vals i v)
+ (+ i 1)))
+ vals))
+
+(define (hashtable-entries ht)
+ (let ((keys (make-vector (hashtable-size ht)))
+ (vals (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (vector-set! vals i v)
+ (+ i 1)))
+ (values keys vals)))
+
+(define (hashtable-key-list ht)
+ (hashtable-map->lset ht (lambda (k v) k)))
+
+(define (hashtable-value-list ht)
+ (hashtable-map->lset ht (lambda (k v) v)))
+
+(define (hashtable-entry-lists ht)
+ (let ((keys&vals (cons '() '())))
+ (hashtable-walk ht
+ (lambda (k v)
+ (set-car! keys&vals (cons k (car keys&vals)))
+ (set-cdr! keys&vals (cons v (cdr keys&vals)))))
+ (car+cdr keys&vals)))
+
+(define (hashtable-walk ht proc)
+ (hash-for-each proc (%hashtable-table ht)))
+
+(define (hashtable-update-all! ht proc)
+ (assert-mutable ht)
+ (hash-for-each-handle
+ (lambda (handle)
+ (set-cdr! handle (proc (car handle) (cdr handle))))
+ (%hashtable-table ht)))
+
+(define (hashtable-prune! ht pred)
+ (assert-mutable ht)
+ (let ((keys (hashtable-sum ht '()
+ (lambda (k v keys-to-delete)
+ (if (pred k v)
+ (cons k keys-to-delete)
+ keys-to-delete)))))
+ (for-each (lambda (k)
+ (hashtable-delete! ht k))
+ keys)))
+
+(define (hashtable-merge! ht-dest ht-src)
+ (assert-mutable ht-dest)
+ (hashtable-walk ht-src
+ (lambda (k v)
+ (hashtable-set! ht-dest k v)))
+ ht-dest)
+
+(define (hashtable-sum ht init proc)
+ (hash-fold proc init (%hashtable-table ht)))
+
+(define (hashtable-map->lset ht proc)
+ (hash-map->list proc (%hashtable-table ht)))
+
+(define (hashtable-find ht pred)
+ (let/ec return
+ (hashtable-walk ht
+ (lambda (k v)
+ (when (pred k v)
+ (return k v #t))))
+ (return #f #f #f)))
+
+(define (hashtable-empty? ht)
+ (zero? (hashtable-size ht)))
+
+(define (hashtable-pop! ht)
+ (assert-mutable ht)
+ (when (hashtable-empty? ht)
+ (error "Cannot pop from empty hashtable." ht))
+ (let-values (((k v found?) (hashtable-find ht (const #t))))
+ (hashtable-delete! ht k)
+ (values k v)))
+
+(define* (hashtable-inc! ht k #:optional (x 1))
+ (assert-mutable ht)
+ (hashtable-update! ht k (lambda (v) (+ v x)) 0))
+
+(define* (hashtable-dec! ht k #:optional (x 1))
+ (assert-mutable ht)
+ (hashtable-update! ht k (lambda (v) (- v x)) 0))
+
+(define (hash-salt) 0)
+
+(set-record-type-printer!
+ <hashtable>
+ (lambda (ht port)
+ (with-output-to-port port
+ (lambda ()
+ (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+ (string-hash (@ (rnrs hashtables) string-hash))
+ (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+ (symbol-hash (@ (rnrs hashtables) symbol-hash))
+ (hash (hashtable-hash-function ht))
+ (equiv (hashtable-equivalence-function ht))
+ (alist (hashtable-map->lset ht cons)))
+ (cond
+ ((and (not hash) (eq? equiv eq?))
+ (display "#hasheq")
+ (display alist))
+ ((and (not hash) (eq? equiv eqv?))
+ (display "#hasheqv")
+ (display alist))
+ (else
+ (display "#hash")
+ (cond
+ ((and (eq? hash (@ (rnrs hashtables) equal-hash)) (eq? equiv
equal?))
+ (display alist))
+ ((and (eq? hash (@ (rnrs hashtables) string-hash)) (eq? equiv
string=?))
+ (display (cons 'string alist)))
+ ((and (eq? hash string-ci-hash) (eq? equiv string-ci=?))
+ (display (cons 'string-ci alist)))
+ ((and (eq? hash symbol-hash) (eq? equiv eq?))
+ (display (cons 'symbol alist)))
+ (else
+ (display (cons 'custom alist)))))))))))
+
+(read-hash-extend
+ #\h
+ (lambda (char port)
+ (with-input-from-port port
+ (lambda ()
+ (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+ (string-hash (@ (rnrs hashtables) string-hash))
+ (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+ (symbol-hash (@ (rnrs hashtables) symbol-hash))
+ (type (string-append "h" (symbol->string (read))))
+ (alist (read)))
+ (cond
+ ((string=? type "hasheq")
+ (alist->eq-hashtable alist))
+ ((string=? type "hasheqv")
+ (alist->eqv-hashtable alist))
+ (else
+ (when (not (string=? type "hash"))
+ (error "Unrecognized hash type." type))
+ (let* ((has-tag? (symbol? (car alist)))
+ (subtype (if has-tag?
+ (car alist)
+ "equal"))
+ (alist (if has-tag?
+ (cdr alist)
+ alist)))
+ (cond
+ ((string=? subtype "equal")
+ (alist->hashtable equal-hash equal? alist))
+ ((string=? subtype "string")
+ (alist->hashtable string-hash string=? alist))
+ ((string=? subtype "string-ci")
+ (alist->hashtable string-ci-hash string-ci=? alist))
+ ((string=? subtype "symbol")
+ (alist->hashtable symbol-hash eq? alist))
+ (else
+ (error "Unrecognized hash subtype." subtype)))))))))))
+
+;; 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..25ba5ae91
--- /dev/null
+++ b/test-suite/tests/srfi-126-test.scm
@@ -0,0 +1,289 @@
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). 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 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..8d8a1cd3f
--- /dev/null
+++ b/test-suite/tests/srfi-126.test
@@ -0,0 +1,49 @@
+;;;; srfi-126.test --- Test suite for SRFI-126. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-srfi-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
