* [PATCH v3 1/6] module: Add srfi-126.
@ 2023-11-18 6:05 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 2/6] tests: Add new compile-file tests Maxim Cournoyer
` (4 more replies)
0 siblings, 5 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
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.
---
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
am/bootstrap.am | 1 +
doc/ref/srfi-modules.texi | 599 +++++++++++++++++++++++++++++
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 +++
6 files changed, 1336 insertions(+)
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/am/bootstrap.am b/am/bootstrap.am
index a71946958..04ae9049c 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -347,6 +347,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/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 0cdf56923..bc5b17680 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -64,6 +64,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 +5663,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
\f
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:
base-commit: 75cd95060fb1ea7586f0e4b9081694c6d61f1d3b
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
* [PATCH v3 2/6] tests: Add new compile-file tests.
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
@ 2023-11-18 6:05 ` Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 3/6] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
` (3 subsequent siblings)
4 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
Add a test for bug #66046.
To run just the compiler tests:
./meta/guile -L test-suite -L . test-suite/tests/compiler.test
* test-suite/tests/compiler.test (with-temporary-directory): New syntax.
(delete-file-recursively): New procedure.
("compile-file: relative include works")
("compile-file: relative include works with load path
canonicalization"): New tests.
---
(no changes since v1)
test-suite/tests/compiler.test | 75 +++++++++++++++++++++++++++++++++-
1 file changed, 74 insertions(+), 1 deletion(-)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index a018e0c41..2026d5ff3 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021-2022 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-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
@@ -18,6 +18,7 @@
(define-module (tests compiler)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
+ #:use-module (ice-9 ftw)
#:use-module (system base compile)
#:use-module ((language tree-il)
#:select (tree-il-src call-args))
@@ -27,6 +28,39 @@
(define read-and-compile
(@@ (system base compile) read-and-compile))
+;;; Based on 'with-directory-excursion', from (guix build utils).
+(define-syntax-rule (with-temporary-directory body ...)
+ "Run BODY with DIR as the process's current directory."
+ (let ((init (getcwd))
+ (dir (mkdtemp "tempdir.XXXXXX")))
+ (dynamic-wind
+ (lambda ()
+ (chdir dir))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (chdir init)
+ (delete-file-recursively dir)))))
+
+;;; XXX: Adapted from (guix build utils).
+(define* (delete-file-recursively dir)
+ "Delete DIR recursively, like `rm -rf', without following symlinks."
+ (file-system-fold (const #t) ;enter
+ (lambda (file stat result) ; leaf
+ (delete-file file))
+ (const #t) ; down
+ (lambda (dir stat result) ; up
+ (rmdir dir))
+ (const #t) ; skip
+ (lambda (file stat errno result)
+ (format (current-error-port)
+ "warning: failed to delete ~a: ~a~%"
+ file (strerror errno)))
+ #t
+ dir
+
+ ;; Don't follow symlinks.
+ lstat))
\f
(with-test-prefix "basic"
@@ -434,3 +468,42 @@
(set! proc ((load-thunk-from-memory bytecode)))
(procedure? proc)))
(pass-if-equal "proc executes" 42 (proc))))
+
+(with-test-prefix "compile-file"
+ ;; Setup test library sources in a temporary directory.
+ (let ((top-sexp '(define-library (hello)
+ (import (scheme base)
+ (scheme write))
+ (export hello)
+ (include "hello/hello-impl.scm")))
+ (included-sexp '(define (hello)
+ (display "hello!\n"))))
+ (with-temporary-directory
+ (mkdir "module")
+ (call-with-output-file "module/hello.scm"
+ (lambda (port)
+ (write top-sexp port)))
+ (mkdir "module/hello")
+ (call-with-output-file "module/hello/hello-impl.scm"
+ (lambda (port)
+ (write included-sexp port)))
+ (mkdir "build")
+ (chdir "build")
+
+ (pass-if "relative include works"
+ (compile-file "../module/hello.scm" #:output-file "hello.go")
+ #t)
+
+ ;; This used to fail, because compile-file's #:canonicalization
+ ;; defaults to 'relative, which caused 'scm_relativize_path' to
+ ;; strip the prefix not in the load path, to avoid baking an
+ ;; invalid source file reference in the byte compiled output file
+ ;; (see: https://bugs.gnu.org/66046). This was fixed by having a
+ ;; 'compilation-source-file' fluid that preserves the file name
+ ;; passed to 'compile-file', used by 'include' instead of the file
+ ;; name of the port.
+ (pass-if "relative include works with load path canonicalization"
+ (begin
+ (add-to-load-path (string-append (getcwd) "/../module"))
+ (compile-file "../module/hello.scm" #:output-file "hello.go")
+ #t)))))
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
* [PATCH v3 3/6] ice-9: Fix 'include' when used in compilation contexts.
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 2/6] tests: Add new compile-file tests Maxim Cournoyer
@ 2023-11-18 6:05 ` Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 4/6] module: Add srfi-128 Maxim Cournoyer
` (2 subsequent siblings)
4 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
Fix bug #66046.
Introduce a 'compilation-source-file-name' fluid that captures the
pre-canonicalized file name used when compiling a file, before it gets
modified in fport_canonicalize_filename. That reference that can then
used directly by 'include', avoiding problems.
* module/ice-9/boot-9.scm (compilation-source-file-name): New fluid.
(compile-file): Set it to the value of FILE.
(compile-and-load): Likewise.
* module/ice-9/psyntax.scm (call-with-include-port): Use it.
---
(no changes since v1)
module/ice-9/boot-9.scm | 6 ++++++
module/ice-9/psyntax.scm | 13 +++++++++----
module/system/base/compile.scm | 6 ++++--
3 files changed, 19 insertions(+), 6 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a5f2eea9b..7f2a02007 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -395,6 +395,12 @@ If returning early, return the return value of F."
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
+;;; This fluid captures the original compiled source file name, before
+;;; it gets potentially stripped by the file ports canonicalization. It
+;;; is used with 'include' to locate the true source, which is necessary
+;;; when using relative paths during compilation, for example.
+(define compilation-source-file-name (make-fluid #f))
+
;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
;; The binding for `macroexpand' has now been overridden, making psyntax the
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7811f7118..ccdd15fca 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3260,15 +3260,20 @@
(let ((syntax-dirname (lambda (stx)
(define src (syntax-source stx))
(define filename (and src (assq-ref src 'filename)))
- (and (string? filename)
- (dirname filename)))))
+ (define source-file-name
+ (fluid-ref compilation-source-file-name))
+ (or (and source-file-name
+ (dirname source-file-name))
+ (and (string? filename)
+ (dirname filename))))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename)))
"Like @code{call-with-input-file}, except relative paths are
-searched relative to the @var{dirname} instead of the current working
+searched relative to @var{dirname} instead of the current working
directory. Also, @var{filename} can be a syntax object; in that case,
and if @var{dirname} is not specified, the @code{syntax-source} of
@var{filename} is used to obtain a base directory for relative file
-names."
+names. As a special case, when the @var{compilation-source-file-name}
+fluid is set, its value overrides the @var{dirname} argument provided."
(let* ((filename (syntax->datum filename))
(p (open-input-file
(cond ((absolute-file-name? filename)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index a33d012bd..7b2670c21 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -174,7 +174,8 @@
(opts '())
(canonicalization 'relative))
(validate-options opts)
- (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (with-fluids ((%file-port-name-canonicalization canonicalization)
+ (compilation-source-file-name file))
(let* ((comp (or output-file (compiled-file-name file)
(error "failed to create path for auto-compiled file"
file)))
@@ -202,7 +203,8 @@
(opts '())
(canonicalization 'relative))
(validate-options opts)
- (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (with-fluids ((%file-port-name-canonicalization canonicalization)
+ (compilation-source-file-name file))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
#:optimization-level optimization-level
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
* [PATCH v3 4/6] module: Add srfi-128.
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 2/6] tests: Add new compile-file tests Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 3/6] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
@ 2023-11-18 6:05 ` Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 5/6] module: Add srfi-125 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 6/6] module: Add srfi-151 Maxim Cournoyer
4 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
From upstream commit 62504e3b5b01615297cf65c33ca76a474bd61dd3.
* module/srfi/srfi-128.scm
* module/srfi/srfi-128/128.body1.scm
* module/srfi/srfi-128/128.body2.scm
* test-suite/tests/srfi-128-test.scm
* test-suite/tests/srfi-128.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-128.scm.
(NOCOMP_SOURCES): Register 128.body1.scm and 128.body2.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI Support): Document it.
---
Changes in v3:
- Rename SRFI-128 to SRFI 128 in text
- Replace srfi-128.scm with upstream srfi/128.sld
Changes in v2:
- Remove string-hash and symbol-hash from exports (they are already
listed in #:rename)
am/bootstrap.am | 3 +
doc/ref/srfi-modules.texi | 552 ++++++++++++++++++++++++++++-
module/srfi/srfi-128.scm | 61 ++++
module/srfi/srfi-128/128.body1.scm | 361 +++++++++++++++++++
module/srfi/srfi-128/128.body2.scm | 146 ++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-128-test.scm | 321 +++++++++++++++++
test-suite/tests/srfi-128.test | 47 +++
8 files changed, 1492 insertions(+), 1 deletion(-)
create mode 100644 module/srfi/srfi-128.scm
create mode 100644 module/srfi/srfi-128/128.body1.scm
create mode 100644 module/srfi/srfi-128/128.body2.scm
create mode 100644 test-suite/tests/srfi-128-test.scm
create mode 100644 test-suite/tests/srfi-128.test
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 04ae9049c..1bf867924 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -348,6 +348,7 @@ SOURCES = \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
srfi/srfi-126.scm \
+ srfi/srfi-128.scm \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -437,6 +438,8 @@ NOCOMP_SOURCES = \
srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
+ srfi/srfi-128/128.body1.scm \
+ srfi/srfi-128/128.body2.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index bc5b17680..0de53616a 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -65,7 +65,8 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
* SRFI 126:: R6RS-based hash tables.
-* SRFI-171:: Transducers
+* SRFI 128:: Comparators.
+* SRFI-171:: Transducers.
@end menu
@@ -6261,6 +6262,555 @@ contents, ignoring case. This hash function is suitable for use with
Return an integer hash value for @var{symbol}.
@end deffn
+@node SRFI 128
+@subsection Comparators
+@cindex SRFI 128
+@cindex comparators
+
+@uref{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI 128}
+provides comparators, which bundle a @emph{type test predicate}, an
+@emph{equality predicate}, an @emph{ordering predicate}, and a @emph{hash
+function} into a single Scheme object. By packaging these procedures
+together, they can be treated as a single item for use in the
+implementation of data structures.
+
+@noindent
+The four procedures above have complex dependencies on one another, and
+it is inconvenient to have to pass them individually to other procedures
+that might or might not make use of all of them. For example, a set
+implementation by its nature requires only an equality predicate, but if
+it is implemented using a hash table, an appropriate hash function is
+also required if the implementation does not provide one; alternatively,
+if it is implemented using a tree, procedures specifying a total order
+are required. By passing a comparator rather than a bare equality
+predicate, the set implementation can make use of whatever procedures
+are available and useful to it.
+
+@subheading Definitions
+
+A comparator is an object of a disjoint type. It is a bundle of
+procedures that are useful for comparing two objects in a total order.
+It is an error if any of the procedures have side effects. There are
+four procedures in the bundle:
+
+@enumerate
+@item
+The @emph{type test predicate} returns @code{#t} if its argument has the
+correct type to be passed as an argument to the other three procedures,
+and @code{#f} otherwise.
+
+@item
+The @emph{equality predicate} returns @code{#t} if the two objects are the
+same in the sense of the comparator, and @code{#f} otherwise. It is the
+programmer's responsibility to ensure that it is reflexive, symmetric,
+transitive, and can handle any arguments that satisfy the type test
+predicate.
+
+@item
+The @emph{ordering predicate} returns @code{#t} if the first object
+precedes the second in a total order, and @code{#f} otherwise. Note
+that if it is true, the equality predicate must be false. It is the
+programmer's responsibility to ensure that it is irreflexive,
+anti-symmetric, transitive, and can handle any arguments that satisfy
+the type test predicate.
+
+@item
+The @emph{hash function} takes an object and returns an exact non-negative
+integer. It is the programmer's responsibility to ensure that it can
+handle any argument that satisfies the type test predicate, and that it
+returns the same value on two objects if the equality predicate says
+they are the same (but not necessarily the converse).
+@end enumerate
+
+It is also the programmer's responsibility to ensure that all four
+procedures provide the same result whenever they are applied to the same
+object(s) (in the sense of @code{eqv?}), unless the object(s) have been
+mutated since the last invocation.
+
+@subheading Limitations
+
+The comparator objects defined in SRFI 128 are not applicable to
+circular structures or to NaNs, or to objects containing any of these.
+Attempts to pass any such objects to any procedure defined here, or to
+any procedure that is part of a comparator defined here, is an error
+except as otherwise noted.
+
+@menu
+* SRFI 128 Predicates::
+* SRFI 128 Constructors::
+* SRFI 128 Standard hash functions::
+* SRFI 128 Bounds and salt::
+* SRFI 128 Default comparators::
+* SRFI 128 Accessors and Invokers::
+* SRFI 128 Comparison predicates::
+* SRFI 128 Syntax::
+@end menu
+
+@node SRFI 128 Predicates
+@subsubsection SRFI 128 Predicates
+
+@deffn {Scheme Procedure} comparator? obj
+
+Return @code{#t} if @var{obj} is a comparator, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-ordered? comparator
+
+Return @code{#t} if @var{comparator} has a supplied ordering predicate,
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-hashable? comparator
+Return @code{#t} if @var{comparator} has a supplied hash function, and
+@code{#f} otherwise.
+@end deffn
+
+@node SRFI 128 Constructors
+@subsubsection SRFI 128 Constructors
+
+The following comparator constructors all supply appropriate type test
+predicates, equality predicates, ordering predicates, and hash functions
+based on the supplied arguments. They are allowed to cache their
+results: they need not return a newly allocated object, since
+comparators are pure and functional. In addition, the procedures in a
+comparator are likewise pure and functional.
+
+@deffn {Scheme Procedure} make-comparator type-test equality ordering hash
+
+Return a comparator which bundles the @var{type-test}, @var{equality},
+@var{ordering}, and @var{hash} procedures provided. However, if
+@var{ordering} or @var{hash} is @code{#f}, a procedure is provided that
+signals an error on application. The predicates
+@code{comparator-ordered?} and/or @code{comparator-hashable?},
+respectively, will return @code{#f} in these cases.
+
+Here are calls on @code{make-comparator} that will return useful
+comparators for standard Scheme types:
+
+@itemize
+@item
+@samp{(make-comparator boolean? boolean=? (lambda (x y) (and (not x) y))
+boolean-hash)} will return a comparator for booleans, expressing the
+ordering @samp{#f < #t} and the standard hash function for booleans.
+
+@item
+@samp{(make-comparator real? = < (lambda (x) (exact (abs x))))} will
+return a comparator expressing the natural ordering of real numbers and
+a plausible (but not optimal) hash function.
+
+@item
+@samp{(make-comparator string? string=? string<? string-hash)} will
+return a comparator expressing the ordering of strings and the standard
+hash function.
+
+@item
+@samp{(make-comparator string? string-ci=? string-ci<? string-ci-hash)}
+will return a comparator expressing the case-insensitive ordering of
+strings and the standard case-insensitive hash function.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-pair-comparator car-comparator cdr-comparator
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument is a pair, if the car
+satisfies the type test predicate of @var{car-comparator}, and the cdr
+satisfies the type test predicate of @var{cdr-comparator}.
+
+@item
+The equality function returns @code{#t} if the cars are equal according
+to @var{car-comparator} and the cdrs are equal according to
+@var{cdr-comparator}, and @code{#f} otherwise.
+
+@item
+The ordering function first compares the cars of its pairs using the
+equality predicate of @var{car-comparator}. If they are not equal, then
+the ordering predicate of @var{car-comparator} is applied to the cars
+and its value is returned. Otherwise, the predicate compares the cdrs
+using the equality predicate of @var{cdr-comparator}. If they are not
+equal, then the ordering predicate of @var{cdr-comparator} is applied to
+the cdrs and its value is returned.
+
+@item
+The hash function computes the hash values of the car and the cdr using
+the hash functions of @var{car-comparator} and @var{cdr-comparator}
+respectively and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-list-comparator element-comparator type-test empty? head tail
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The total order defined by the equality and ordering functions is as
+follows (known as lexicographic order):
+
+@itemize
+@item
+The empty sequence, as determined by calling @code{empty?}, compares
+equal to itself.
+@item
+The empty sequence compares less than any non-empty sequence.
+@item
+Two non-empty sequences are compared by calling the @var{head} procedure
+on each. If the heads are not equal when compared using
+@var{element-comparator}, the result is the result of that comparison.
+Otherwise, the results of calling the @var{tail} procedure are compared
+recursively.
+@end itemize
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-vector-comparator element-comparator type-test length ref
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The equality predicate returns @code{#t} if both of the following tests
+are satisfied in order: the lengths of the vectors are the same in the
+sense of @code{=}, and the elements of the vectors are the same in the
+sense of the equality predicate of @var{element-comparator}.
+
+@item
+The ordering predicate returns @code{#t} if the results of applying
+@var{length} to the first vector is less than the result of applying
+length to the second vector. If the lengths are equal, then the
+elements are examined pairwise using the ordering predicate of
+@var{element-comparator}. If any pair of elements returns @code{#t},
+then that is the result of the list comparator's ordering predicate;
+otherwise the result is @code{#f}.
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+
+Here is an example, which returns a comparator for byte vectors:
+
+@lisp
+(make-vector-comparator
+ (make-comparator exact-integer? = < number-hash)
+ bytevector?
+ bytevector-length
+ bytevector-u8-ref)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} make-eq-comparator
+@deffnx {Scheme Procedure} make-eqv-comparator
+@deffnx {Scheme Procedure} make-equal-comparator
+
+These procedures return comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} in all cases.
+
+@item
+The equality functions are @code{eq?}, @code{eqv?}, and @code{equal?},
+respectively.
+
+@item
+The ordering function is set @code{#f}, and attempting to use it will
+cause an error with the message @code{"ordering is not supported"}.
+
+@item
+The hash function is @code{default-hash}.
+@end itemize
+@end deffn
+
+@node SRFI 128 Standard hash functions
+@subsubsection SRFI 128 Standard hash functions
+
+These are hash functions for some standard Scheme types, suitable for
+passing to @code{make-comparator}. Users may write their own hash
+functions with the same signature. However, if programmers wish their
+hash functions to be backward compatible with the reference
+implementation of @uref{https://srfi.schemers.org/srfi-69/srfi-69.html,
+SRFI 69}, they are advised to write their hash functions to accept a
+second argument and ignore it.
+
+@deffn {Scheme Procedure} boolean-hash obj
+@deffnx {Scheme Procedure} char-hash obj
+@deffnx {Scheme Procedure} string-hash obj
+@deffnx {Scheme Procedure} string-ci-hash obj
+@deffnx {Scheme Procedure} symbol-hash obj
+@deffnx {Scheme Procedure} number-hash obj
+@end deffn
+
+These are suitable hash functions for the specified types. The hash
+functions @code{char-ci-hash} and @code{string-ci-hash} treat their
+argument case-insensitively. Note that while @code{symbol-hash} may
+return the hashed value of applying @code{symbol->string} and then
+@code{string-hash} to the symbol, this is not a requirement.
+
+@node SRFI 128 Bounds and salt
+@subsubsection SRFI 128 Bounds and salt
+
+The following macros allow the callers of hash functions to affect their
+behavior without interfering with the calling signature of a hash
+function, which accepts a single argument (the object to be hashed) and
+returns its hash value.
+
+@deffn {Scheme Syntax} hash-bound
+
+Hash functions should be written so as to return a number between
+@code{0} and the largest reasonable number of elements (such as hash
+buckets) a data structure in the implementation might have. This value
+is defined as @math{2^25-1} or @code{33554432} in the reference
+implementation used by Guile. This value provides the current bound as
+a positive exact integer, typically for use by user-written hash
+functions. However, they are not required to bound their results in
+this way.
+@end deffn
+
+@deffn {Scheme Syntax} hash-salt
+
+A salt is random data in the form of a non-negative exact integer used
+as an additional input to a hash function in order to defend against
+dictionary attacks, or (when used in hash tables) against
+denial-of-service attacks that overcrowd certain hash buckets,
+increasing the amortized O(1) lookup time to O(n). Salt can also be
+used to specify which of a family of hash functions should be used for
+purposes such as cuckoo hashing. This macro provides the current value
+of the salt, typically for use by user-written hash functions. However,
+they are not required to make use of the current salt.
+
+The initial value is implementation-dependent, but must be less than the
+value of @samp{(hash-bound)}, and should be distinct for distinct runs
+of a program unless otherwise specified by the implementation. In the
+reference implementation used by Guile, the initial salt value is
+@code{16064047}.
+@end deffn
+
+@node SRFI 128 Default comparators
+@subsubsection SRFI 128 Default comparators
+
+@deffn {Scheme Procedure} make-default-comparator
+
+Return a comparator known as a @emph{default comparator} that accepts
+Scheme values and orders them in a way that respects the following
+conditions:
+
+@itemize
+@item
+Given disjoint types @code{a} and @code{b}, one of three conditions must
+hold:
+@itemize
+@item
+All objects of type @code{a} compare less than all objects of type
+@code{b}.
+@item
+All objects of type @code{a} compare greater than all objects of type
+@code{b}.
+@item
+All objects of both type @code{a} and type @code{b} compare equal to
+each other. This is not permitted for any of the Scheme types mentioned
+below.
+@end itemize
+
+@item
+The empty list must be ordered before all pairs.
+
+@item
+When comparing booleans, it must use the total order @samp{#f < #t}.
+
+@item
+When comparing characters, @code{char=?} and @code{char<?} are used.
+
+@item
+When comparing pairs, it must behave the same as a comparator returned
+by @code{make-pair-comparator} with default comparators as arguments.
+
+@item
+When comparing symbols, the total order produced with @code{symbol<?}
+and @code{symbol<?} is used.
+
+@item
+When comparing bytevectors, it must behave the same as a comparator
+created by the expression @samp{(make-vector-comparator (make-comparator
+bytevector? = < number-hash) bytevector? bytevector-length
+bytevector-u8-ref)}.
+
+@item
+When comparing numbers where either number is complex, since non-real
+numbers cannot be compared with @code{<}, the following least-surprising
+ordering is defined: If the real parts are @code{<} or @code{>}, so are
+the numbers; otherwise, the numbers are ordered by their imaginary
+parts. This can still produce somewhat surprising results if one real
+part is exact and the other is inexact.
+
+@item
+When comparing real numbers, it must use @code{=} and @code{<}.
+
+@item
+When comparing strings, it must use @code{string=?} and @code{string<?}.
+
+@item
+When comparing vectors, it must behave the same as a comparator returned
+by @samp{(make-vector-comparator (make-default-comparator) vector?
+vector-length vector-ref)}.
+
+@item
+When comparing members of types registered with
+@code{comparator-register-default!}, it must behave in the same way as
+the comparator registered using that function.
+@end itemize
+
+Default comparators use @code{default-hash} as their hash function.
+@end deffn
+
+@deffn {Scheme Procedure} default-hash obj
+
+This is the hash function used by default comparators, which accepts a
+Scheme value and hashes it in a way that respects the following
+conditions:
+
+@itemize
+@item
+When applied to a pair, it must return the result of hashing together
+the values returned by @code{default-hash} when applied to the car and
+the cdr.
+
+@item
+When applied to a boolean, character, string, symbol, or number, it must
+return the same result as @code{boolean-hash}, @code{char-hash},
+@code{string-hash}, @code{symbol-hash}, or @code{number-hash}
+respectively.
+
+@item
+When applied to a list or vector, it must return the result of hashing
+together the values returned by @code{default-hash} when applied to each
+of the elements.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} comparator-register-default! comparator
+
+Register @var{comparator} for use by default comparators, such that if
+the objects being compared both satisfy the type test predicate of
+@var{comparator}, it will be employed by default comparators to compare
+them. Return an unspecified value. It is an error if any value
+satisfies both the type test predicate of @var{comparator} and any of
+the following type test predicates: @code{boolean?}, @code{char?},
+@code{null?}, @code{pair?}, @code{symbol?}, @code{bytevector?},
+@code{number?}, @code{string?}, @code{vector?}, or the type test
+predicate of a comparator that has already been registered.
+
+This procedure is intended only to extend default comparators into
+territory that would otherwise be undefined, not to override their
+existing behavior. In general, the ordering of calls to
+@code{comparator-register-default!} should be irrelevant.
+
+The comparators available from this library are not registered with the
+@code{comparator-register-default!} procedure, because the default
+comparator is meant to be under the control of the program author rather
+than the library author. It is the program author's responsibility to
+ensure that the registered comparators do not conflict with each other.
+@end deffn
+
+@node SRFI 128 Accessors and Invokers
+@subsubsection SRFI 128 Accessors and Invokers
+
+@deffn {Scheme Procedure} comparator-type-test-predicate comparator
+@deffnx {Scheme Procedure} comparator-equality-predicate comparator
+@deffnx {Scheme Procedure} comparator-ordering-predicate comparator
+@deffnx {Scheme Procedure} comparator-hash-function comparator
+@end deffn
+
+Return the four procedures of @var{comparator}.
+
+@deffn {Scheme Procedure} comparator-test-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return what it returns. More convenient than
+@code{comparator-type-test-predicate}, but less efficient when the
+predicate is called repeatedly.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-check-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return true if it returns true, but signal an error otherwise. More
+convenient than @code{comparator-type-test-predicate}, but less
+efficient when the predicate is called repeatedly.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-hash comparator obj
+
+Invoke the hash function of @var{comparator} on @var{obj} and return
+what it returns. More convenient than @code{comparator-hash-function},
+but less efficient when the predicate is called repeatedly.
+
+@quotation note
+No invokers are required for the equality and ordering predicates,
+because the @code{=?} and @code{<?} predicates described after serve
+this function.
+@end quotation
+@end deffn
+
+@node SRFI 128 Comparison predicates
+@subsubsection SRFI 128 Comparison predicates
+
+@deffn {Scheme Procedure} =? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@end deffn
+
+@noindent
+These procedures are analogous to the number, character, and string
+comparison predicates of Scheme. They allow the convenient use of
+comparators to handle variable data types.
+
+@noindent
+These procedures apply the equality and ordering predicates of
+@var{comparator} to the objects as follows. If the specified relation
+returns @code{#t} for all @var{object@sub{i}} and @var{object@sub{j}}
+where @var{n} is the number of objects and @math{1 <= @var{i} < @var{j}
+<= @var{n}}, then the procedures return @code{#t}, but otherwise
+@code{#f}. Because the relations are transitive, it suffices to compare
+each object with its successor. The order in which the values are
+compared is unspecified.
+
+@node SRFI 128 Syntax
+@subsubsection SRFI 128 Syntax
+
+@deffn {Scheme Procedure} comparator-if<=> [comparator] object@sub{1} object@sub{2} less-than equal-to greater-than
+
+It is an error unless @var{comparator} evaluates to a comparator and
+@var{object@sub{1}} and @var{object@sub{2}} evaluate to objects that the
+comparator can handle. If the ordering predicate returns true when
+applied to the values of @var{object@sub{1}} and @var{object@sub{2}} in
+that order, then @var{less-than} is evaluated and its value returned.
+If the equality predicate returns true when applied in the same way,
+then @var{equal-to} is evaluated and its value returned. If neither
+returns true, @var{greater-than} is evaluated and its value returned.
+
+If @var{comparator} is omitted, a default comparator is used.
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-128.scm b/module/srfi/srfi-128.scm
new file mode 100644
index 000000000..b91d07e05
--- /dev/null
+++ b/module/srfi/srfi-128.scm
@@ -0,0 +1,61 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+(define-library (srfi srfi-128)
+ (export comparator? comparator-ordered? comparator-hashable?
+ make-comparator
+ make-pair-comparator make-list-comparator make-vector-comparator
+ make-eq-comparator make-eqv-comparator make-equal-comparator
+ boolean-hash char-hash char-ci-hash
+ string-hash string-ci-hash symbol-hash number-hash
+ make-default-comparator default-hash comparator-register-default!
+ comparator-type-test-predicate comparator-equality-predicate
+ comparator-ordering-predicate comparator-hash-function
+ comparator-test-type comparator-check-type comparator-hash
+ hash-bound hash-salt
+ =? <? >? <=? >=?
+ comparator-if<=>
+ )
+ (import (scheme base)
+ (scheme case-lambda)
+ (scheme char)
+ (scheme inexact)
+ (scheme complex))
+
+ (cond-expand ((library (srfi 126))
+ (import (only (srfi 126) equal-hash)))
+ ((library (rnrs hashtables))
+ (import (only (rnrs hashtables) equal-hash)))
+ ((library (r6rs hashtables))
+ (import (only (r6rs hashtables) equal-hash)))
+ ((library (srfi 69))
+ (import (rename (only (srfi 69) hash-by-identity)
+ (hash-by-identity equal-hash))))
+ (else
+ ;; FIXME: This works well enough for the test program,
+ ;; but you wouldn't want to use it in a real program.
+ (begin (define (equal-hash x) 0))))
+
+ (include "srfi-128/128.body1.scm")
+ (include "srfi-128/128.body2.scm")
+)
diff --git a/module/srfi/srfi-128/128.body1.scm b/module/srfi/srfi-128/128.body1.scm
new file mode 100644
index 000000000..8cb41a2bf
--- /dev/null
+++ b/module/srfi/srfi-128/128.body1.scm
@@ -0,0 +1,361 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;;; Main part of the SRFI 114 reference implementation
+
+;;; "There are two ways of constructing a software design: One way is to
+;;; make it so simple that there are obviously no deficiencies, and the
+;;; other way is to make it so complicated that there are no *obvious*
+;;; deficiencies." --Tony Hoare
+
+;;; Syntax (because syntax must be defined before it is used, contra Dr. Hardcase)
+
+;; Arithmetic if
+(define-syntax comparator-if<=>
+ (syntax-rules ()
+ ((if<=> a b less equal greater)
+ (comparator-if<=> (make-default-comparator) a b less equal greater))
+ ((comparator-if<=> comparator a b less equal greater)
+ (cond
+ ((=? comparator a b) equal)
+ ((<? comparator a b) less)
+ (else greater)))))
+
+;; Upper bound of hash functions is 2^25-1
+(define-syntax hash-bound
+ (syntax-rules ()
+ ((hash-bound) 33554432)))
+
+(define %salt% (make-parameter 16064047))
+
+(define-syntax hash-salt
+ (syntax-rules ()
+ ((hash-salt) (%salt%))))
+
+(define-syntax with-hash-salt
+ (syntax-rules ()
+ ((with-hash-salt new-salt hash-func obj)
+ (parameterize ((%salt% new-salt)) (hash-func obj)))))
+
+;;; Definition of comparator records with accessors and basic comparator
+
+(define-record-type comparator
+ (make-raw-comparator type-test equality ordering hash ordering? hash?)
+ comparator?
+ (type-test comparator-type-test-predicate)
+ (equality comparator-equality-predicate)
+ (ordering comparator-ordering-predicate)
+ (hash comparator-hash-function)
+ (ordering? comparator-ordered?)
+ (hash? comparator-hashable?))
+
+;; Public constructor
+(define (make-comparator type-test equality ordering hash)
+ (make-raw-comparator
+ (if (eq? type-test #t) (lambda (x) #t) type-test)
+ (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
+ (if ordering ordering (lambda (x y) (error "ordering not supported")))
+ (if hash hash (lambda (x y) (error "hashing not supported")))
+ (if ordering #t #f)
+ (if hash #t #f)))
+
+;;; Invokers
+
+;; Invoke the test type
+(define (comparator-test-type comparator obj)
+ ((comparator-type-test-predicate comparator) obj))
+
+;; Invoke the test type and throw an error if it fails
+(define (comparator-check-type comparator obj)
+ (if (comparator-test-type comparator obj)
+ #t
+ (error "comparator type check failed" comparator obj)))
+
+;; Invoke the hash function
+(define (comparator-hash comparator obj)
+ ((comparator-hash-function comparator) obj))
+
+;;; Comparison predicates
+
+;; Binary versions for internal use
+
+(define (binary=? comparator a b)
+ ((comparator-equality-predicate comparator) a b))
+
+(define (binary<? comparator a b)
+ ((comparator-ordering-predicate comparator) a b))
+
+(define (binary>? comparator a b)
+ (binary<? comparator b a))
+
+(define (binary<=? comparator a b)
+ (not (binary>? comparator a b)))
+
+(define (binary>=? comparator a b)
+ (not (binary<? comparator a b)))
+
+;; General versions for export
+
+(define (=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+
+;;; Simple ordering and hash functions
+
+(define (boolean<? a b)
+ ;; #f < #t but not otherwise
+ (and (not a) b))
+
+
+(define (boolean-hash obj)
+ (if obj (%salt%) 0))
+
+(define (char-hash obj)
+ (modulo (* (%salt%) (char->integer obj)) (hash-bound)))
+
+(define (char-ci-hash obj)
+ (modulo (* (%salt%) (char->integer (char-foldcase obj))) (hash-bound)))
+
+(define (number-hash obj)
+ (cond
+ ((nan? obj) (%salt%))
+ ((and (infinite? obj) (positive? obj)) (* 2 (%salt%)))
+ ((infinite? obj) (* (%salt%) 3))
+ ((real? obj) (abs (exact (round obj))))
+ (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj))))))
+
+;; Lexicographic ordering of complex numbers
+(define (complex<? a b)
+ (if (= (real-part a) (real-part b))
+ (< (imag-part a) (imag-part b))
+ (< (real-part a) (real-part b))))
+
+(define (string-ci-hash obj)
+ (string-hash (string-foldcase obj)))
+
+(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
+
+(define (symbol-hash obj)
+ (string-hash (symbol->string obj)))
+
+;;; Wrapped equality predicates
+;;; These comparators don't have ordering functions.
+
+(define (make-eq-comparator)
+ (make-comparator #t eq? #f default-hash))
+
+(define (make-eqv-comparator)
+ (make-comparator #t eqv? #f default-hash))
+
+(define (make-equal-comparator)
+ (make-comparator #t equal? #f default-hash))
+
+;;; Sequence ordering and hash functions
+;; The hash functions are based on djb2, but
+;; modulo 2^25 instead of 2^32 in hopes of sticking to fixnums.
+
+(define (make-hasher)
+ (let ((result (%salt%)))
+ (case-lambda
+ (() result)
+ ((n) (set! result (+ (modulo (* result 33) (hash-bound)) n))
+ result))))
+
+;;; Pair comparator
+(define (make-pair-comparator car-comparator cdr-comparator)
+ (make-comparator
+ (make-pair-type-test car-comparator cdr-comparator)
+ (make-pair=? car-comparator cdr-comparator)
+ (make-pair<? car-comparator cdr-comparator)
+ (make-pair-hash car-comparator cdr-comparator)))
+
+(define (make-pair-type-test car-comparator cdr-comparator)
+ (lambda (obj)
+ (and (pair? obj)
+ (comparator-test-type car-comparator (car obj))
+ (comparator-test-type cdr-comparator (cdr obj)))))
+
+(define (make-pair=? car-comparator cdr-comparator)
+ (lambda (a b)
+ (and ((comparator-equality-predicate car-comparator) (car a) (car b))
+ ((comparator-equality-predicate cdr-comparator) (cdr a) (cdr b)))))
+
+(define (make-pair<? car-comparator cdr-comparator)
+ (lambda (a b)
+ (if (=? car-comparator (car a) (car b))
+ (<? cdr-comparator (cdr a) (cdr b))
+ (<? car-comparator (car a) (car b)))))
+
+(define (make-pair-hash car-comparator cdr-comparator)
+ (lambda (obj)
+ (let ((acc (make-hasher)))
+ (acc (comparator-hash car-comparator (car obj)))
+ (acc (comparator-hash cdr-comparator (cdr obj)))
+ (acc))))
+
+;;; List comparator
+
+;; Cheap test for listness
+(define (norp? obj) (or (null? obj) (pair? obj)))
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+ (make-comparator
+ (make-list-type-test element-comparator type-test empty? head tail)
+ (make-list=? element-comparator type-test empty? head tail)
+ (make-list<? element-comparator type-test empty? head tail)
+ (make-list-hash element-comparator type-test empty? head tail)))
+
+
+(define (make-list-type-test element-comparator type-test empty? head tail)
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+ (let loop ((obj obj))
+ (cond
+ ((empty? obj) #t)
+ ((not (elem-type-test (head obj))) #f)
+ (else (loop (tail obj)))))))))
+
+(define (make-list=? element-comparator type-test empty? head tail)
+ (lambda (a b)
+ (let ((elem=? (comparator-equality-predicate element-comparator)))
+ (let loop ((a a) (b b))
+ (cond
+ ((and (empty? a) (empty? b) #t))
+ ((empty? a) #f)
+ ((empty? b) #f)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ (else #f))))))
+
+(define (make-list<? element-comparator type-test empty? head tail)
+ (lambda (a b)
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator)))
+ (let loop ((a a) (b b))
+ (cond
+ ((and (empty? a) (empty? b) #f))
+ ((empty? a) #t)
+ ((empty? b) #f)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ ((elem<? (head a) (head b)) #t)
+ (else #f))))))
+
+(define (make-list-hash element-comparator type-test empty? head tail)
+ (lambda (obj)
+ (let ((elem-hash (comparator-hash-function element-comparator))
+ (acc (make-hasher)))
+ (let loop ((obj obj))
+ (cond
+ ((empty? obj) (acc))
+ (else (acc (elem-hash (head obj))) (loop (tail obj))))))))
+
+
+;;; Vector comparator
+
+(define (make-vector-comparator element-comparator type-test length ref)
+ (make-comparator
+ (make-vector-type-test element-comparator type-test length ref)
+ (make-vector=? element-comparator type-test length ref)
+ (make-vector<? element-comparator type-test length ref)
+ (make-vector-hash element-comparator type-test length ref)))
+
+(define (make-vector-type-test element-comparator type-test length ref)
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator))
+ (len (length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((not (elem-type-test (ref obj n))) #f)
+ (else (loop (+ n 1)))))))))
+
+(define (make-vector=? element-comparator type-test length ref)
+ (lambda (a b)
+ (and
+ (= (length a) (length b))
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (len (length b)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ (else #f)))))))
+
+(define (make-vector<? element-comparator type-test length ref)
+ (lambda (a b)
+ (cond
+ ((< (length a) (length b)) #t)
+ ((> (length a) (length b)) #f)
+ (else
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator))
+ (len (length a)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #f)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ ((elem<? (ref a n) (ref b n)) #t)
+ (else #f))))))))
+
+(define (make-vector-hash element-comparator type-test length ref)
+ (lambda (obj)
+ (let ((elem-hash (comparator-hash-function element-comparator))
+ (acc (make-hasher))
+ (len (length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) (acc))
+ (else (acc (elem-hash (ref obj n))) (loop (+ n 1))))))))
+
+(define (string-hash obj)
+ (let ((acc (make-hasher))
+ (len (string-length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) (acc))
+ (else (acc (char->integer (string-ref obj n))) (loop (+ n 1)))))))
diff --git a/module/srfi/srfi-128/128.body2.scm b/module/srfi/srfi-128/128.body2.scm
new file mode 100644
index 000000000..b424d41b5
--- /dev/null
+++ b/module/srfi/srfi-128/128.body2.scm
@@ -0,0 +1,146 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; The default comparator
+
+;;; Standard comparators and their functions
+
+;; The unknown-object comparator, used as a fallback to everything else
+;; Everything compares exactly the same and hashes to 0
+(define unknown-object-comparator
+ (make-comparator
+ (lambda (obj) #t)
+ (lambda (a b) #t)
+ (lambda (a b) #f)
+ (lambda (obj) 0)))
+
+;; Next index for added comparator
+
+(define first-comparator-index 9)
+(define *next-comparator-index* 9)
+(define *registered-comparators* (list unknown-object-comparator))
+
+;; Register a new comparator for use by the default comparator.
+(define (comparator-register-default! comparator)
+ (set! *registered-comparators* (cons comparator *registered-comparators*))
+ (set! *next-comparator-index* (+ *next-comparator-index* 1)))
+
+;; Return ordinal for object types: null sorts before pairs, which sort
+;; before booleans, etc. Implementations can extend this.
+;; People who call comparator-register-default! effectively do extend it.
+(define (object-type obj)
+ (cond
+ ((null? obj) 0)
+ ((pair? obj) 1)
+ ((boolean? obj) 2)
+ ((char? obj) 3)
+ ((string? obj) 4)
+ ((symbol? obj) 5)
+ ((number? obj) 6)
+ ((vector? obj) 7)
+ ((bytevector? obj) 8)
+ ; Add more here if you want: be sure to update comparator-index variables
+ (else (registered-index obj))))
+
+;; Return the index for the registered type of obj.
+(define (registered-index obj)
+ (let loop ((i 0) (registry *registered-comparators*))
+ (cond
+ ((null? registry) (+ first-comparator-index i))
+ ((comparator-test-type (car registry) obj) (+ first-comparator-index i))
+ (else (loop (+ i 1) (cdr registry))))))
+
+;; Given an index, retrieve a registered conductor.
+;; Index must be >= first-comparator-index.
+(define (registered-comparator i)
+ (list-ref *registered-comparators* (- i first-comparator-index)))
+
+(define (dispatch-equality type a b)
+ (case type
+ ((0) #t) ; All empty lists are equal
+ ((1) ((make-pair=? (make-default-comparator) (make-default-comparator)) a b))
+ ((2) (boolean=? a b))
+ ((3) (char=? a b))
+ ((4) (string=? a b))
+ ((5) (symbol=? a b))
+ ((6) (= a b))
+ ((7) ((make-vector=? (make-default-comparator)
+ vector? vector-length vector-ref) a b))
+ ((8) ((make-vector=? (make-comparator exact-integer? = < default-hash)
+ bytevector? bytevector-length bytevector-u8-ref) a b))
+ ; Add more here
+ (else (binary=? (registered-comparator type) a b))))
+
+(define (dispatch-ordering type a b)
+ (case type
+ ((0) 0) ; All empty lists are equal
+ ((1) ((make-pair<? (make-default-comparator) (make-default-comparator)) a b))
+ ((2) (boolean<? a b))
+ ((3) (char<? a b))
+ ((4) (string<? a b))
+ ((5) (symbol<? a b))
+ ((6) (complex<? a b))
+ ((7) ((make-vector<? (make-default-comparator) vector? vector-length vector-ref) a b))
+ ((8) ((make-vector<? (make-comparator exact-integer? = < default-hash)
+ bytevector? bytevector-length bytevector-u8-ref) a b))
+ ; Add more here
+ (else (binary<? (registered-comparator type) a b))))
+
+;;; The author of SRFI 128 has suggested a post-finalization note
+;;; saying the first and third bullet items stating "must" requirements
+;;; for default-hash may be weakened. That allows a much faster hash
+;;; function to be used for lists and vectors.
+
+(define (default-hash obj)
+ (case (object-type obj)
+ ((0 1 7) ; empty list, pair, or vector
+ ((make-hasher) (equal-hash obj)))
+ ((2) (boolean-hash obj))
+ ((3) (char-hash obj))
+ ((4) (string-hash obj))
+ ((5) (symbol-hash obj))
+ ((6) (number-hash obj))
+ ((8) ((make-vector-hash (make-default-comparator)
+ bytevector? bytevector-length bytevector-u8-ref) obj))
+ ; Add more here
+ (else (comparator-hash (registered-comparator (object-type obj)) obj))))
+
+(define (default-ordering a b)
+ (let ((a-type (object-type a))
+ (b-type (object-type b)))
+ (cond
+ ((< a-type b-type) #t)
+ ((> a-type b-type) #f)
+ (else (dispatch-ordering a-type a b)))))
+
+(define (default-equality a b)
+ (let ((a-type (object-type a))
+ (b-type (object-type b)))
+ (if (= a-type b-type) (dispatch-equality a-type a b) #f)))
+
+(define (make-default-comparator)
+ (make-comparator
+ (lambda (obj) #t)
+ default-equality
+ default-ordering
+ default-hash))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index eaa5e1fdb..0fb5827cc 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-105.test \
tests/srfi-111.test \
tests/srfi-126.test \
+ tests/srfi-128.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
tests/srfi-126-test.scm \
+ tests/srfi-128-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-128-test.scm b/test-suite/tests/srfi-128-test.scm
new file mode 100644
index 000000000..2cad04377
--- /dev/null
+++ b/test-suite/tests/srfi-128-test.scm
@@ -0,0 +1,321 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library. A 'test-begin' call is added.
+(use-modules (rnrs bytevectors)
+ (srfi srfi-64)
+ (srfi srfi-128))
+
+(define-syntax-rule (test arg ...)
+ (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+ (test-end))
+
+(test-begin "comparators")
+;;; END Guile-specific modifications.
+
+(define (print x) (display x) (newline))
+
+(test-group "comparators"
+
+ (define (vector-cdr vec)
+ (let* ((len (vector-length vec))
+ (result (make-vector (- len 1))))
+ (let loop ((n 1))
+ (cond
+ ((= n len) result)
+ (else (vector-set! result (- n 1) (vector-ref vec n))
+ (loop (+ n 1)))))))
+
+ (test '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+ (test '#() (vector-cdr '#(1)))
+
+ (print "default-comparator")
+ (define default-comparator (make-default-comparator))
+ (print "real-comparator")
+ (define real-comparator (make-comparator real? = < number-hash))
+ (print "degenerate comparator")
+ (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+ (print "boolean comparator")
+ (define boolean-comparator
+ (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+ (print "bool-pair-comparator")
+ (define bool-pair-comparator (make-pair-comparator boolean-comparator boolean-comparator))
+ (print "num-list-comparator")
+ (define num-list-comparator
+ (make-list-comparator real-comparator list? null? car cdr))
+ (print "num-vector-comparator")
+ (define num-vector-comparator
+ (make-vector-comparator real-comparator vector? vector-length vector-ref))
+ (print "vector-qua-list comparator")
+ (define vector-qua-list-comparator
+ (make-list-comparator
+ real-comparator
+ vector?
+ (lambda (vec) (= 0 (vector-length vec)))
+ (lambda (vec) (vector-ref vec 0))
+ vector-cdr))
+ (print "list-qua-vector-comparator")
+ (define list-qua-vector-comparator
+ (make-vector-comparator default-comparator list? length list-ref))
+ (print "eq-comparator")
+ (define eq-comparator (make-eq-comparator))
+ (print "eqv-comparator")
+ (define eqv-comparator (make-eqv-comparator))
+ (print "equal-comparator")
+ (define equal-comparator (make-equal-comparator))
+ (print "symbol-comparator")
+ (define symbol-comparator
+ (make-comparator
+ symbol?
+ eq?
+ (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+ symbol-hash))
+
+ (test-group "comparators/predicates"
+ (test-assert (comparator? real-comparator))
+ (test-assert (not (comparator? =)))
+ (test-assert (comparator-ordered? real-comparator))
+ (test-assert (comparator-hashable? real-comparator))
+ (test-assert (not (comparator-ordered? degenerate-comparator)))
+ (test-assert (not (comparator-hashable? degenerate-comparator)))
+ ) ; end comparators/predicates
+
+ (test-group "comparators/constructors"
+ (test-assert (=? boolean-comparator #t #t))
+ (test-assert (not (=? boolean-comparator #t #f)))
+ (test-assert (<? boolean-comparator #f #t))
+ (test-assert (not (<? boolean-comparator #t #t)))
+ (test-assert (not (<? boolean-comparator #t #f)))
+
+ (test-assert (comparator-test-type bool-pair-comparator '(#t . #f)))
+ (test-assert (not (comparator-test-type bool-pair-comparator 32)))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+ (test-assert (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+ (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+ (test-assert (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+ (test-assert (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+ (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+ (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+ (test-assert (comparator-test-type num-vector-comparator '#(1 2 3)))
+ (test-assert (comparator-test-type num-vector-comparator '#()))
+ (test-assert (not (comparator-test-type num-vector-comparator 1)))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+ (test-assert (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+ (test-assert (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+ (test-assert (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+ (test-assert (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+ (test-assert (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+ (define bool-pair (cons #t #f))
+ (define bool-pair-2 (cons #t #f))
+ (define reverse-bool-pair (cons #f #t))
+ (test-assert (=? eq-comparator #t #t))
+ (test-assert (not (=? eq-comparator #f #t)))
+ (test-assert (=? eqv-comparator bool-pair bool-pair))
+ (test-assert (not (=? eqv-comparator bool-pair bool-pair-2)))
+ (test-assert (=? equal-comparator bool-pair bool-pair-2))
+ (test-assert (not (=? equal-comparator bool-pair reverse-bool-pair)))
+ ) ; end comparators/constructors
+
+ (test-group "comparators/hash"
+ (test-assert (exact-integer? (boolean-hash #f)))
+ (test-assert (not (negative? (boolean-hash #t))))
+ (test-assert (exact-integer? (char-hash #\a)))
+ (test-assert (not (negative? (char-hash #\b))))
+ (test-assert (exact-integer? (char-ci-hash #\a)))
+ (test-assert (not (negative? (char-ci-hash #\b))))
+ (test-assert (= (char-ci-hash #\a) (char-ci-hash #\A)))
+ (test-assert (exact-integer? (string-hash "f")))
+ (test-assert (not (negative? (string-hash "g"))))
+ (test-assert (exact-integer? (string-ci-hash "f")))
+ (test-assert (not (negative? (string-ci-hash "g"))))
+ (test-assert (= (string-ci-hash "f") (string-ci-hash "F")))
+ (test-assert (exact-integer? (symbol-hash 'f)))
+ (test-assert (not (negative? (symbol-hash 't))))
+ (test-assert (exact-integer? (number-hash 3)))
+ (test-assert (not (negative? (number-hash 3))))
+ (test-assert (exact-integer? (number-hash -3)))
+ (test-assert (not (negative? (number-hash -3))))
+ (test-assert (exact-integer? (number-hash 3.0)))
+ (test-assert (not (negative? (number-hash 3.0))))
+
+ ) ; end comparators/hash
+
+ (test-group "comparators/default"
+ (test-assert (<? default-comparator '() '(a)))
+ (test-assert (not (=? default-comparator '() '(a))))
+ (test-assert (=? default-comparator #t #t))
+ (test-assert (not (=? default-comparator #t #f)))
+ (test-assert (<? default-comparator #f #t))
+ (test-assert (not (<? default-comparator #t #t)))
+ (test-assert (=? default-comparator #\a #\a))
+ (test-assert (<? default-comparator #\a #\b))
+
+ (test-assert (comparator-test-type default-comparator '()))
+ (test-assert (comparator-test-type default-comparator #t))
+ (test-assert (comparator-test-type default-comparator #\t))
+ (test-assert (comparator-test-type default-comparator '(a)))
+ (test-assert (comparator-test-type default-comparator 'a))
+ (test-assert (comparator-test-type default-comparator (make-bytevector 10)))
+ (test-assert (comparator-test-type default-comparator 10))
+ (test-assert (comparator-test-type default-comparator 10.0))
+ (test-assert (comparator-test-type default-comparator "10.0"))
+ (test-assert (comparator-test-type default-comparator '#(10)))
+
+ (test-assert (=? default-comparator '(#t . #t) '(#t . #t)))
+ (test-assert (not (=? default-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (=? default-comparator '(#t . #t) '(#t . #f))))
+ (test-assert (<? default-comparator '(#f . #t) '(#t . #t)))
+ (test-assert (<? default-comparator '(#t . #f) '(#t . #t)))
+ (test-assert (not (<? default-comparator '(#t . #t) '(#t . #t))))
+ (test-assert (not (<? default-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (test-assert (=? default-comparator '#(#t #t) '#(#t #t)))
+ (test-assert (not (=? default-comparator '#(#t #t) '#(#f #t))))
+ (test-assert (not (=? default-comparator '#(#t #t) '#(#t #f))))
+ (test-assert (<? default-comparator '#(#f #t) '#(#t #t)))
+ (test-assert (<? default-comparator '#(#t #f) '#(#t #t)))
+ (test-assert (not (<? default-comparator '#(#t #t) '#(#t #t))))
+ (test-assert (not (<? default-comparator '#(#t #t) '#(#f #t))))
+ (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (test-assert (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+ (test-assert (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+ (test-assert (= (comparator-hash default-comparator "t") (string-hash "t")))
+ (test-assert (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+ (test-assert (= (comparator-hash default-comparator 10) (number-hash 10)))
+ (test-assert (= (comparator-hash default-comparator 10.0) (number-hash 10.0)))
+
+ (comparator-register-default!
+ (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 200)))
+ (test-assert (=? default-comparator (lambda () #t) (lambda () #f)))
+ (test-assert (not (<? default-comparator (lambda () #t) (lambda () #f))))
+ (test 200 (comparator-hash default-comparator (lambda () #t)))
+
+ ) ; end comparators/default
+
+ ;; SRFI 128 does not actually require a comparator's four procedures
+ ;; to be eq? to the procedures originally passed to make-comparator.
+ ;; For interoperability/interchangeability between the comparators
+ ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+ ;; make-comparator may need to be wrapped inside another lambda
+ ;; expression before they're returned by the corresponding accessor.
+ ;;
+ ;; So this next group of tests is incorrect, hence commented out
+ ;; and replaced by a slightly less naive group of tests.
+
+#;
+ (test-group "comparators/accessors"
+ (define ttp (lambda (x) #t))
+ (define eqp (lambda (x y) #t))
+ (define orp (lambda (x y) #t))
+ (define hf (lambda (x) 0))
+ (define comp (make-comparator ttp eqp orp hf))
+ (test ttp (comparator-type-test-predicate comp))
+ (test eqp (comparator-equality-predicate comp))
+ (test orp (comparator-ordering-predicate comp))
+ (test hf (comparator-hash-function comp))
+ ) ; end comparators/accessors
+
+ (test-group "comparators/accessors"
+ (define x1 0)
+ (define x2 0)
+ (define x3 0)
+ (define x4 0)
+ (define ttp (lambda (x) (set! x1 111) #t))
+ (define eqp (lambda (x y) (set! x2 222) #t))
+ (define orp (lambda (x y) (set! x3 333) #t))
+ (define hf (lambda (x) (set! x4 444) 0))
+ (define comp (make-comparator ttp eqp orp hf))
+ (test #t (and ((comparator-type-test-predicate comp) x1) (= x1 111)))
+ (test #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+ (test #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+ (test #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444)))
+ ) ; end comparators/accessors
+
+ (test-group "comparators/invokers"
+ (test-assert (comparator-test-type real-comparator 3))
+ (test-assert (comparator-test-type real-comparator 3.0))
+ (test-assert (not (comparator-test-type real-comparator "3.0")))
+ (test-assert (comparator-check-type boolean-comparator #t))
+ (test-error (comparator-check-type boolean-comparator 't))
+ ) ; end comparators/invokers
+
+ (test-group "comparators/comparison"
+ (test-assert (=? real-comparator 2 2.0 2))
+ (test-assert (<? real-comparator 2 3.0 4))
+ (test-assert (>? real-comparator 4.0 3.0 2))
+ (test-assert (<=? real-comparator 2.0 2 3.0))
+ (test-assert (>=? real-comparator 3 3.0 2))
+ (test-assert (not (=? real-comparator 1 2 3)))
+ (test-assert (not (<? real-comparator 3 1 2)))
+ (test-assert (not (>? real-comparator 1 2 3)))
+ (test-assert (not (<=? real-comparator 4 3 3)))
+ (test-assert (not (>=? real-comparator 3 4 4.0)))
+
+ ) ; end comparators/comparison
+
+ (test-group "comparators/syntax"
+ (test 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+ (test 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+ (test 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater))
+ (test 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+ (test 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+ (test 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+ ) ; end comparators/syntax
+
+ (test-group "comparators/bound-salt"
+ (test-assert (exact-integer? (hash-bound)))
+ (test-assert (exact-integer? (hash-salt)))
+ (test-assert (< (hash-salt) (hash-bound)))
+ ) ; end comparators/bound-salt
+
+) ; end comparators
+
+(test-exit)
diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test
new file mode 100644
index 000000000..a6a447767
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,47 @@
+;;;; srfi-128.test --- Test suite for SRFI-128. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-128)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-128))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-128-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
* [PATCH v3 5/6] module: Add srfi-125.
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
` (2 preceding siblings ...)
2023-11-18 6:05 ` [PATCH v3 4/6] module: Add srfi-128 Maxim Cournoyer
@ 2023-11-18 6:05 ` Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 6/6] module: Add srfi-151 Maxim Cournoyer
4 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-125.scm
* module/srfi/srfi-125/hash-table.scm
* test-suite/tests/srfi-125-test.scm
* test-suite/tests/srfi-125.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-125.scm.
(NOCOMP_SOURCES): Register hash-table.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI-125): Document it.
---
Changes in v3:
- Add menu entries.
- Rename SRFI-125 to SRFI 125 in text
- Rename included file to upstream name (125.body.scm)
- Add copyright/license header 125.body.scm
am/bootstrap.am | 2 +
doc/ref/srfi-modules.texi | 603 ++++++++++++++++++++
module/srfi/srfi-125.scm | 79 +++
module/srfi/srfi-125/125.body.scm | 589 +++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-125-test.scm | 887 +++++++++++++++++++++++++++++
test-suite/tests/srfi-125.test | 47 ++
7 files changed, 2209 insertions(+)
create mode 100644 module/srfi/srfi-125.scm
create mode 100644 module/srfi/srfi-125/125.body.scm
create mode 100644 test-suite/tests/srfi-125-test.scm
create mode 100644 test-suite/tests/srfi-125.test
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 1bf867924..ae977c48d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -347,6 +347,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-125.scm \
srfi/srfi-126.scm \
srfi/srfi-128.scm \
srfi/srfi-171.scm \
@@ -438,6 +439,7 @@ NOCOMP_SOURCES = \
srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
+ srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
srfi/srfi-128/128.body2.scm \
system/base/lalr.upstream.scm \
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 0de53616a..087c27e4b 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -64,6 +64,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
+* SRFI 125:: Mutators.
* SRFI 126:: R6RS-based hash tables.
* SRFI 128:: Comparators.
* SRFI-171:: Transducers.
@@ -5664,6 +5665,608 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI 125
+@subsection SRFI 125 Intermediate hash tables
+@cindex SRFI 125
+@cindex hash tables
+
+This SRFI defines an interface to hash tables, which are widely
+recognized as a fundamental data structure for a wide variety of
+applications. A hash table is a data structure that:
+
+@itemize
+@item
+Is disjoint from all other types.
+
+@item
+Provides a mapping from objects known as keys to corresponding objects
+known as values.
+@itemize
+@item
+Keys may be any Scheme objects in some kinds of hash tables, but are
+restricted in other kinds.
+@item
+Values may be any Scheme objects.
+@end itemize
+
+@item
+Has no intrinsic order for the key-value associations it contains.
+
+@item
+Provides an equality predicate which defines when a proposed key is the
+same as an existing key. No table may contain more than one value for a
+given key.
+
+@item
+Provides a hash function which maps a candidate key into a non-negative
+exact integer.
+
+@item
+Supports mutation as the primary means of setting the contents of a
+table.
+
+@item
+Provides key lookup and destructive update in (expected) amortized
+constant time, provided a satisfactory hash function is available.
+
+@item
+Does not guarantee that whole-table operations work in the presence of
+concurrent mutation of the whole hash table (values may be safely
+mutated).
+@end itemize
+
+@menu
+* SRFI 125 Rationale::
+* SRFI 125 Constructors::
+* SRFI 125 Predicates::
+* SRFI 125 Accessors::
+* SRFI 125 Mutators::
+* SRFI 125 The whole hash table::
+* SRFI 125 Mapping and folding::
+* SRFI 125 Copying and conversion::
+* SRFI 125 Hash tables as sets::
+* SRFI 125 Hash functions and reflectivity::
+@end menu
+
+@node SRFI 125 Rationale
+@subsubsection SRFI 125 Rationale
+
+Hash tables themselves don't really need defending: almost all
+dynamically typed languages, from awk to JavaScript to Lua to Perl to
+Python to Common Lisp, and including many Scheme implementations,
+provide them in some form as a fundamental data structure. Therefore,
+what needs to be defended is not the data structure but the procedures.
+This SRFI is at an intermediate level. It supports a great many
+convenience procedures on top of the basic hash table interfaces
+provided by SRFI 69 and R6RS. Nothing in it adds power to what those
+interfaces provide, but it does add convenience in the form of
+pre-debugged routines to do various common things, and even some things
+not so commonly done but useful.
+
+There is no mandated support for thread safety, immutability, or
+weakness, though there are portable hooks for specifying these features.
+
+While the specification of this SRFI accepts separate equality
+predicates and hash functions for backward compatibility, it strongly
+encourages the use of SRFI 128 comparators, which package a type test,
+an equality predicate, and a hash function into a single bundle.
+
+@subheading SRFI 69 compatibility
+
+This SRFI is downward compatible with SRFI 69. Some procedures have
+been given new preferred names for compatibility with other SRFIs, but
+in all cases the SRFI 69 names have been retained as deprecated
+synonyms; in Guile, these deprecated procedures have their name prefixed
+with @code{deprecated:}.
+
+There is one absolute incompatibility with SRFI 69: the reflective
+procedure @code{hash-table-hash-function} may return @code{#f}, which is
+not permitted by SRFI 69.
+
+@subheading R6RS compatibility
+
+The relatively few hash table procedures in R6RS are all available in
+this SRFI under somewhat different names. The only substantive
+difference is that R6RS @code{hashtable-values} and
+@code{hashtable-entries} return vectors, whereas in this SRFI
+@code{hash-table-value} and @code{hash-table-entries} return lists.
+This SRFI adopts SRFI 69's term hash-table rather than R6RS's hashtable,
+because of the universal use of ``hash table'' rather than ``hashtable''
+in other computer languages and in technical prose generally. Besides,
+the English word hashtable obviously means something that can be@dots{}
+hashted.
+
+In addition, the @code{hashtable-ref} and @code{hashtable-update!} of
+R6RS correspond to the @code{hash-table-ref/default} and
+@code{hash-table-update!/default} of both SRFI 69 and this SRFI.
+
+@subheading Common Lisp compatibility
+
+As usual, the Common Lisp names are completely different from the Scheme
+names. Common Lisp provides the following capabilities that are
+@emph{not} in this SRFI:
+
+@itemize
+@item
+The constructor allows specifying the rehash size and rehash threshold
+of the new hash table. There are also accessors and mutators for these
+and for the current capacity (as opposed to size).
+
+@item
+There are hash tables based on @code{equalp} (which does not exist in
+Scheme).
+
+@item
+@code{with-hash-table-iterator} is a hash table external iterator
+implemented as a local macro.
+
+@item
+@code{sxhash} is an implementation-specific hash function for the equal
+predicate. It has the property that objects in different instantiations
+of the same Lisp implementation that are similar, a concept analogous to
+e@code{qual} but defined across all instantiations, always return the
+same value from @code{sxhash}; for example, the symbol @code{xyz} will
+have the same @code{sxhash} result in all instantiations.
+@end itemize
+
+@subheading Sources
+
+The procedures in this SRFI are drawn primarily from SRFI 69 and
+R6RS. In addition, the following sources are acknowledged:
+
+@itemize
+@item
+The @code{hash-table-mutable?} procedure and the second argument of
+@code{hash-table-copy} (which allows the creation of immutable hash
+tables) are from R6RS, renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-intern!} procedure is from
+@url{https://docs.racket-lang.org/reference/hashtables.html, Racket},
+renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-find} procedure is a modified version of
+@code{table-search} in Gambit.
+
+@item
+The procedures @code{hash-table-unfold} and @code{hash-table-count} were
+suggested by SRFI-1.
+
+@item
+The procedures @code{hash-table=?} and @code{hash-table-map} were
+suggested by Haskell's @code{Data.Map.Strict} module.
+
+@item
+The procedure @code{hash-table-map->list} is from Guile.
+@end itemize
+
+The procedures @code{hash-table-empty?,} @code{hash-table-empty-copy,
+hash-table-pop!,} @code{hash-table-map!,}
+@code{hash-table-intersection!, hash-table-difference!,} and
+@code{hash-table-xor!} were added for convenience and completeness.
+
+The native hash tables of MIT, SISC, Bigloo, Scheme48, SLIB, RScheme,
+Scheme 7, Scheme 9, Rep, and FemtoLisp were also investigated, but no
+additional procedures were incorporated.
+
+@subheading Pronunciation
+
+The slash in the names of some procedures can be pronounced ``with''.
+
+@node SRFI 125 Constructors
+@subsubsection SRFI 125 Constructors
+
+@deffn {Scheme Procedure} make-hash-table comparator [ arg @dots{} ]
+@deffnx {Scheme Procedure} make-hash-table equality-predicate [ hash-function ] [ arg @dots{} ])
+
+Return a newly allocated hash table whose equality predicate and hash
+function are extracted from comparator. Alternatively, for backward
+compatibility with SRFI 69 the equality predicate and hash function can
+be passed as separate arguments; this usage is deprecated.
+
+These procedures relate to R6RS @code{make-eq-hashtable},
+@code{make-eqv-hashtable} and @code{make-hashtable} ones, and
+@code{make-hash-table} from Common Lisp.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table comparator [ key value ] @dots{}
+
+Return a newly allocated hash table, created as if by
+@code{make-hash-table} using @var{comparator}. For each pair of
+arguments, an association is added to the new hash table with @var{key}
+as its key and @var{value} as its value. This procedure returns an
+immutable hash table. If the same key (in the sense of the equality
+predicate) is specified more than once, it is an error.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-unfold stop? mapper successor seed comparator arg @dots{}
+
+Create a new hash table as if by @var{make-hash-table} using
+@var{comparator} and the @var{args}. If the result of applying the
+predicate @code{stop?} to @var{seed} is true, return the hash table.
+Otherwise, apply the procedure @var{mapper} to @var{seed}. @var{mapper}
+returns two values, which are inserted into the hash table as the key
+and the value respectively. Then get a new seed by applying the
+procedure @var{successor} to @var{seed}, and repeat this algorithm.
+@end deffn
+
+@deffn {Scheme Procedure} alist->hash-table alist comparator arg @dots{}
+@deffnx {Scheme Procedure} alist->hash-table alist equality-predicate [ hash-function ] arg @dots{}
+
+Return a newly allocated hash table as if by @code{make-hash-table}
+using @var{comparator} and the @var{args}. It is then initialized from
+the associations of @var{alist}. Associations earlier in the list take
+precedence over those that come later. The second form is for
+compatibility with SRFI 69, and is deprecated.
+@end deffn
+
+@node SRFI 125 Predicates
+@subsubsection SRFI 125 Predicates
+
+@deffn {Scheme Procedure} hash-table? obj
+
+Return @code{#t} if @var{obj} is a hash table, and @code{#f} otherwise.
+(R6RS @code{hashtable?}; Common Lisp @code{hash-table-p})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-contains? hash-table key
+@deffnx {Scheme Procedure} hash-table-exists? hash-table key
+
+Return @code{#t} if there is any association to key in @var{hash-table},
+and @code{#f} otherwise. Execute in amortized constant time. The
+@code{hash-table-exists?} procedure is the same as
+@code{hash-table-contains?}; it is provided for backward compatibility
+with SRFI 69, and is deprecated. (R6RS @code{hashtable-contains?})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty? hash-table
+
+Return @code{#t} if @var{hash-table} contains no associations, and
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table=? value-comparator hash-table@sub{1} hash-table@sub{2}
+
+Return @code{#t} if @var{hash-table@sub{1}} and @var{hash-table@sub{2}}
+have the same keys (in the sense of their common equality predicate) and
+each key has the same value (in the sense of @var{value-comparator)},
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-mutable? hash-table
+
+Return @code{#t} if @var{hash-table} is mutable. (R6RS
+@code{hashtable-mutable?})
+@end deffn
+
+@node SRFI 125 Accessors
+@subsubsection SRFI 125 Accessors
+
+The following procedures, given a key, return the corresponding value.
+
+@deffn {Scheme Procedure} hash-table-ref hash-table key [ failure [ success ] ]
+
+Extract the value associated to key in @var{hash-table}, invoke the
+procedure success on it, and return its result; if @var{success} is not
+provided, then the value itself is returned. If @var{key} is not
+contained in @var{hash-table} and @var{failure} is supplied, then
+@var{failure} is called with no arguments and its result is returned.
+Otherwise, it is an error. Execute in expected amortized constant time,
+not counting the time to call the procedures. SRFI 69 does not support
+the @var{success} procedure.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-ref/default hash-table key default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-ref @var{hash-table} @var{key} (lambda () @var{default}))
+@end lisp
+
+(R6RS @code{hashtable-ref}; Common Lisp @code{gethash})
+@end deffn
+
+@node SRFI 125 Mutators
+@subsubsection SRFI 125 Mutators
+
+The following procedures alter the associations in a hash table either
+unconditionally, or conditionally on the presence or absence of a
+specified key. It is an error to add an association to a hash table
+whose key does not satisfy the type test predicate of the comparator
+used to create the hash table.
+
+@deffn {Scheme Procedure} hash-table-set! hash-table arg @dots{}
+
+Repeatedly mutates @code{hash-table}, creating new associations in it by
+processing the arguments from left to right. The @var{args} alternate
+between keys and values. Whenever there is a previous association for a
+key, it is deleted. It is an error if the type check procedure of the
+comparator of @var{hash-table}, when invoked on a key, does not return
+@code{#t}. Likewise, it is an error if a key is not a valid argument to
+the equality predicate of @var{hash-table}. Return an unspecified
+value. Execute in expected amortized constant time per key.
+SRFI 69, R6RS @code{hashtable-set!} and Common Lisp (@samp{setf
+gethash}) do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-delete! hash-table key @dots{}
+
+Delete any association to each key in @var{hash-table} and returns the
+number of keys that had associations. Execute in expected amortized
+constant time per key. SRFI 69, R6RS @code{hashtable-delete!}, and
+Common Lisp @var{remhash} do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intern! hash-table key failure
+
+Effectively invoke @code{hash-table-ref} with the given arguments and
+return what it returns. If @var{key} was not found in @var{hash-table},
+its value is set to the result of calling @var{failure}. Execute in
+expected amortized constant time.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update! hash-table key updater [ failure [ success ] ]
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref @var{hash-table} @var{key} @var{failure} @var{success})))
+@end lisp
+
+Execute in expected amortized constant time. Return an unspecified
+value. (SRFI 69 and R6RS @code{hashtable-update!} do not support
+the @var{success} procedure)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update!/default hash-table key updater default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref/default @var{hash-table} @var{key} @var{default})))
+@end lisp
+
+Execute in expected amortized constant time. Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-pop! hash-table
+
+Choose an arbitrary association from @var{hash-table} and removes it,
+returning the key and value as two values. It is an error if
+@var{hash-table} is empty.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-clear! hash-table
+Delete all the associations from @var{hash-table}. (R6RS
+@code{hashtable-clear!}; Common Lisp @code{clrhash}.)
+@end deffn
+
+@node SRFI 125 The whole hash table
+@subsubsection SRFI 125 The whole hash table
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-size hash-table
+
+Return the number of associations in @var{hash-table} as an exact
+integer. Execute in constant time. (R6RS @code{hashtable-size}; Common
+Lisp @code{hash-table-count}.)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-keys hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}. R6RS
+@code{hashtable-keys} returns a vector.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-values hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-entries hash-table
+
+Return two values, a newly allocated list of all the keys in
+@var{hash-table} and a newly allocated list of all the values in
+@var{hash-table} in the corresponding order. R6RS
+@code{hash-table-entries} returns vectors.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-find proc hash-table failure
+
+For each association of @var{hash-table}, invoke @var{proc} on its key
+and value. If @var{proc} returns true, then @code{hash-table-find}
+returns what @var{proc} returns. If all the calls to @var{proc} return
+@code{#f}, return the result of invoking the thunk @var{failure}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-count pred hash-table
+For each association of @var{hash-table}, invoke @var{pred} on its key
+and value. Return the number of calls to @var{pred} which returned
+true.
+@end deffn
+
+@node SRFI 125 Mapping and folding
+@subsubsection SRFI 125 Mapping and folding
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-map proc comparator hash-table
+
+Return a newly allocated hash table as if by @samp{(make-hash-table
+comparator)}. Calls @var{proc} for every association in
+@var{hash-table} with the value of the association. The key of the
+association and the result of invoking @var{proc} are entered into the
+new hash table. Note that this is not the result of lifting mapping
+over the domain of hash tables, but it is considered more useful.
+
+If @var{comparator} recognizes multiple keys in the @var{hash-table} as
+equivalent, any one of such associations is taken.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-for-each proc hash-table
+@deffnx {Scheme Procedure} hash-table-walk hash-table proc
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is discarded. Return an unspecified
+value. The @code{hash-table-walk} procedure is equivalent to
+@code{hash-table-for-each} with the arguments reversed, is provided for
+backward compatibility with SRFI 69, and is deprecated. (Common
+Lisp @code{maphash})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is used to update the value of the
+association. Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map->list proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The values returned by the invocations of @var{proc} are accumulated
+into a list, which is returned.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-fold proc seed hash-table
+@deffnx {Scheme Procedure} hash-table-fold hash-table proc seed
+
+Call @var{proc} for every association in @var{hash-table} with three
+arguments: the key of the association, the value of the association, and
+an accumulated value @var{val}. @var{val} is the seed for the first
+invocation of @var{proc}, and for subsequent invocations of @var{proc},
+the returned value of the previous invocation. The value returned by
+@code{hash-table-fold} is the return value of the last invocation of
+@var{proc}. The order of arguments with @var{hash-table} as the first
+argument is provided for SRFI 69 compatibility, and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-prune! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments, the key and the value of the association, and removes all
+associations from @var{hash-table} for which @var{proc} returns true.
+Return an unspecified value.
+@end deffn
+
+@node SRFI 125 Copying and conversion
+@subsubsection SRFI 125 Copying and conversion
+
+@deffn {Scheme Procedure} hash-table-copy hash-table [ mutable? ]
+
+Return a newly allocated hash table with the same properties and
+associations as @var{hash-table}. If the second argument is present and
+is true, the new hash table is mutable. Otherwise it is immutable.
+SRFI 69 @code{hash-table-copy} does not support a second argument.
+(R6RS @code{hashtable-copy})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty-copy hash-table
+
+Return a newly allocated mutable hash table with the same properties as
+@var{hash-table}, but with no associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table->alist hash-table
+
+Return an alist with the same associations as @var{hash-table} in an
+unspecified order.
+@end deffn
+
+@node SRFI 125 Hash tables as sets
+@subsubsection SRFI 125 Hash tables as sets
+
+@deffn {Scheme Procedure} hash-table-union! hash-table@sub{1} hash-table@sub{2}
+@deffnx {Scheme Procedure} hash-table-merge! hash-table@sub{1} hash-table@sub{2}
+
+Add the associations of @var{hash-table@sub{2}} to
+@var{hash-table@sub{1}} and return @var{hash-table@sub{1}}. If a key
+appears in both hash tables, its value is set to the value appearing in
+@var{hash-table@sub{1}}. Return @var{hash-table@sub{1}}. The
+@code{hash-table-merge!} procedure is the same as
+@code{hash-table-union!}, is provided for compatibility with SRFI 69,
+and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intersection! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations from @var{hash-table@sub{1}} whose keys don't
+also appear in @var{hash-table@sub{2}} and return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-difference! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}} and return @var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-xor! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}}, and then adds the associations of
+@var{hash-table@sub{2}} whose keys are not present in
+@var{hash-table@sub{1}} to @var{hash-table@sub{1}}. Return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@node SRFI 125 Hash functions and reflectivity
+@subsubsection SRFI 125 Hash functions and reflectivity
+
+These functions are made part of this SRFI solely for compatibility with
+SRFI 69, and are deprecated.
+
+@quotation note
+While the SRFI 125 specifies that these deprecated procedures should be
+exported using their original names, which forces its users to rename
+these procedures to something else to avoid clashing with the SRFI 126
+and SRFI 128 variants that should be preferred instead, Guile exports
+them with the @code{deprecated:} prefix.
+@end quotation
+
+@deffn {Scheme Procedure} deprecated:hash obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:string-hash obj [ arg ]
+
+Similar to SRFI 128's @code{string-hash} procedure, except that it must
+accept (and should ignore) an optional second argument. It is
+incompatible with the procedure of the same name exported by SRFI 128
+and SRFI 126.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-by-identity obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-equivalence-function hash-table
+
+Return the equivalence procedure used to create @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-hash-function hash-table
+
+Return the hash function used to create @var{hash-table}.
+@end deffn
+
@node SRFI 126
@subsection SRFI 126 R6RS-based hash tables
@cindex SRFI 126
diff --git a/module/srfi/srfi-125.scm b/module/srfi/srfi-125.scm
new file mode 100644
index 000000000..47c17eb73
--- /dev/null
+++ b/module/srfi/srfi-125.scm
@@ -0,0 +1,79 @@
+;;; srfi-125.scm -- SRFI 125 - Intermediate hash tables.
+;;; Adapted from srfi-125.sld, made necessary due to bug#67255.
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-125)
+ #:use-module ((rnrs base) :version (6) #:hide (error))
+ #:use-module (srfi srfi-126)
+ #:use-module ((srfi srfi-128) #:hide (hash-salt string-hash string-ci-hash))
+ #:replace (hash-table? make-hash-table)
+ #:export (hash-table hash-table-unfold
+ alist->hash-table
+
+ hash-table-contains?
+ hash-table-empty?
+ hash-table=?
+ hash-table-mutable?
+
+ hash-table-ref
+ hash-table-ref/default
+
+ hash-table-set!
+ hash-table-delete!
+ hash-table-intern!
+ hash-table-update!
+ hash-table-update!/default
+ hash-table-pop!
+ hash-table-clear!
+
+ hash-table-size
+ hash-table-keys
+ hash-table-values
+ hash-table-entries
+ hash-table-find
+ hash-table-count
+
+ hash-table-map
+ hash-table-for-each
+ hash-table-map!
+ hash-table-map->list
+ hash-table-fold
+ hash-table-prune!
+
+ hash-table-copy
+ hash-table-empty-copy
+ hash-table->alist
+
+ hash-table-union!
+ hash-table-intersection!
+ hash-table-difference!
+ hash-table-xor!
+
+ ;; The following procedures are deprecated by SRFI 125:
+ deprecated:hash
+ deprecated:string-hash
+ deprecated:string-ci-hash
+ deprecated:hash-by-identity
+
+ deprecated:hash-table-equivalence-function
+ deprecated:hash-table-hash-function
+ deprecated:hash-table-exists?
+ deprecated:hash-table-walk
+ deprecated:hash-table-merge!))
+
+(include-from-path "srfi/srfi-125/125.body.scm")
diff --git a/module/srfi/srfi-125/125.body.scm b/module/srfi/srfi-125/125.body.scm
new file mode 100644
index 000000000..32e9f3a06
--- /dev/null
+++ b/module/srfi/srfi-125/125.body.scm
@@ -0,0 +1,589 @@
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Private stuff, not exported.
+
+;;; Ten of the SRFI 125 procedures are deprecated, and another
+;;; two allow alternative arguments that are deprecated.
+
+(define (issue-deprecated-warnings?) #t)
+
+(define (issue-warning-deprecated name-of-deprecated-misfeature)
+ (if (not (memq name-of-deprecated-misfeature already-warned))
+ (begin
+ (set! already-warned
+ (cons name-of-deprecated-misfeature already-warned))
+ (if (issue-deprecated-warnings?)
+ (let ((out (current-error-port)))
+ (display "WARNING: " out)
+ (display name-of-deprecated-misfeature out)
+ (newline out)
+ (display " is deprecated by SRFI 125. See" out)
+ (newline out)
+ (display " " out)
+ (display url:deprecated out)
+ (newline out))))))
+
+(define url:deprecated
+ "http://srfi.schemers.org/srfi-125/srfi-125.html")
+
+; List of deprecated features for which a warning has already
+; been issued.
+
+(define already-warned '())
+
+;;; Comparators contain a type test predicate, which implementations
+;;; of the hash-table-set! procedure can use to reject invalid keys.
+;;; That's hard to do without sacrificing interoperability with R6RS
+;;; and/or SRFI 69 and/or SRFI 126 hash tables.
+;;;
+;;; Full interoperability means the hash tables implemented here are
+;;; interchangeable with the SRFI 126 hashtables used to implement them.
+;;; SRFI 69 and R6RS and SRFI 126 hashtables don't contain comparators,
+;;; so any association between a hash table and its comparator would have
+;;; to be maintained outside the representation of hash tables themselves,
+;;; which is problematic unless weak pointers are available.
+;;;
+;;; Not all of the hash tables implemented here will have comparators
+;;; associated with them anyway, because an equivalence procedure
+;;; and hash function can be used to create a hash table instead of
+;;; a comparator (although that usage is deprecated by SRFI 125).
+;;;
+;;; One way to preserve interoperability while enforcing a comparator's
+;;; type test is to incorporate that test into a hash table's hash
+;;; function. The advantage of doing that should be weighed against
+;;; these disadvantages:
+;;;
+;;; If the type test is slow, then hashing would also be slower.
+;;;
+;;; The R6RS, SRFI 69, and SRFI 126 APIs allow extraction of
+;;; a hash function from some hash tables.
+;;; Some programmers might expect that hash function to be the
+;;; hash function encapsulated by the comparator (in the sense
+;;; of eq?, perhaps) even though this API makes no such guarantee
+;;; (and extraction of that hash function from an existing hash
+;;; table can only be done by calling a deprecated procedure).
+
+;;; If %enforce-comparator-type-tests is true, then make-hash-table,
+;;; when passed a comparator, will use a hash function that enforces
+;;; the comparator's type test.
+
+(define %enforce-comparator-type-tests #t)
+
+;;; Given a comparator, return its hash function, possibly augmented
+;;; by the comparator's type test.
+
+(define (%comparator-hash-function comparator)
+ (let ((okay? (comparator-type-test-predicate comparator))
+ (hash-function (comparator-hash-function comparator)))
+ (if %enforce-comparator-type-tests
+ (lambda (x . rest)
+ (cond ((not (okay? x))
+ (error "key rejected by hash-table comparator"
+ x
+ comparator))
+ ((null? rest)
+ (hash-function x))
+ (else
+ (apply hash-function x rest))))
+ hash-function)))
+
+;;; A unique (in the sense of eq?) value that will never be found
+;;; within a hash-table.
+
+(define %not-found (list '%not-found))
+
+;;; A unique (in the sense of eq?) value that escapes only as an irritant
+;;; when a hash-table key is not found.
+
+(define %not-found-irritant (list 'not-found))
+
+;;; The error message used when a hash-table key is not found.
+
+(define %not-found-message "hash-table key not found")
+
+;;; FIXME: thread-safe, weak-keys, ephemeral-keys, weak-values,
+;;; and ephemeral-values are not supported by this portable
+;;; reference implementation.
+
+(define (%check-optional-arguments procname args)
+ (if (or (memq 'thread-safe args)
+ (memq 'weak-keys args)
+ (memq 'weak-values args)
+ (memq 'ephemeral-keys args)
+ (memq 'ephemeral-values args))
+ (error (string-append (symbol->string procname)
+ ": unsupported optional argument(s)")
+ args)))
+
+;;; This was exported by an earlier draft of SRFI 125,
+;;; and is still used by hash-table=?
+
+(define (hash-table-every proc ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals))
+ (if (null? keys)
+ #t
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (proc key val)))
+ (and x
+ (loop (cdr keys)
+ (cdr vals)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Exported procedures
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+;;; The first argument can be a comparator or an equality predicate.
+;;;
+;;; If the first argument is a comparator, any remaining arguments
+;;; are implementation-dependent, but a non-negative exact integer
+;;; should be interpreted as an initial capacity and the symbols
+;;; thread-safe, weak-keys, ephemeral-keys, weak-values, and
+;;; emphemeral-values should be interpreted specially. (These
+;;; special symbols are distinct from the analogous special symbols
+;;; in SRFI 126.)
+;;;
+;;; If the first argument is not a comparator, then it had better
+;;; be an equality predicate (which is deprecated by SRFI 125).
+;;; If a second argument is present and is a procedure, then it's
+;;; a hash function (which is allowed only for the deprecated case
+;;; in which the first argument is an equality predicate). If a
+;;; second argument is not a procedure, then it's some kind of
+;;; implementation-dependent optional argument, as are all arguments
+;;; beyond the second.
+;;;
+;;; SRFI 128 defines make-eq-comparator, make-eqv-comparator, and
+;;; make-equal-comparator procedures whose hash function is the
+;;; default-hash procedure of SRFI 128, which is inappropriate
+;;; for use with eq? and eqv? unless the object being hashed is
+;;; never mutated. Neither SRFI 125 nor 128 provide any way to
+;;; define a comparator whose hash function is truly compatible
+;;; with the use of eq? or eqv? as an equality predicate.
+;;;
+;;; That would make SRFI 125 almost as bad as SRFI 69 if not for
+;;; the following paragraph of SRFI 125:
+;;;
+;;; Implementations are permitted to ignore user-specified
+;;; hash functions in certain circumstances. Specifically,
+;;; if the equality predicate, whether passed as part of a
+;;; comparator or explicitly, is more fine-grained (in the
+;;; sense of R7RS-small section 6.1) than equal?, the
+;;; implementation is free — indeed, is encouraged — to
+;;; ignore the user-specified hash function and use something
+;;; implementation-dependent. This allows the use of addresses
+;;; as hashes, in which case the keys must be rehashed if
+;;; they are moved by the garbage collector. Such a hash
+;;; function is unsafe to use outside the context of
+;;; implementation-provided hash tables. It can of course be
+;;; exposed by an implementation as an extension, with
+;;; suitable warnings against inappropriate uses.
+;;;
+;;; That gives implementations permission to do something more
+;;; useful, but when should implementations take advantage of
+;;; that permission? This implementation uses the superior
+;;; solution provided by SRFI 126 whenever:
+;;;
+;;; A comparator is passed as first argument and its equality
+;;; predicate is eq? or eqv?.
+;;;
+;;; The eq? or eqv? procedure is passed as first argument
+;;; (which is a deprecated usage).
+
+(define (make-hash-table comparator/equiv . rest)
+ (if (comparator? comparator/equiv)
+ (let ((equiv (comparator-equality-predicate comparator/equiv))
+ (hash-function (%comparator-hash-function comparator/equiv)))
+ (%make-hash-table equiv hash-function rest))
+ (let* ((equiv comparator/equiv)
+ (hash-function (if (and (not (null? rest))
+ (procedure? (car rest)))
+ (car rest)
+ #f))
+ (rest (if hash-function (cdr rest) rest)))
+ (issue-warning-deprecated 'srfi-69-style:make-hash-table)
+ (%make-hash-table equiv hash-function rest))))
+
+(define (%make-hash-table equiv hash-function opts)
+ (%check-optional-arguments 'make-hash-table opts)
+ (cond ((equal? equiv eq?)
+ (make-eq-hashtable))
+ ((equal? equiv eqv?)
+ (make-eqv-hashtable))
+ (hash-function
+ (make-hashtable hash-function equiv))
+ ((equal? equiv equal?)
+ (make-hashtable equal-hash equiv))
+ ((equal? equiv string=?)
+ (make-hashtable string-hash equiv))
+ ((equal? equiv string-ci=?)
+ (make-hashtable string-ci-hash equiv))
+ ((equal? equiv symbol=?)
+ (make-hashtable symbol-hash equiv))
+ (else
+ (error "make-hash-table: unable to infer hash function"
+ equiv))))
+
+(define (hash-table comparator . rest)
+ (let ((ht (apply make-hash-table comparator rest)))
+ (let loop ((kvs rest))
+ (cond
+ ((null? kvs) #f)
+ ((null? (cdr kvs)) (error "hash-table: wrong number of arguments"))
+ ((hashtable-contains? ht (car kvs))
+ (error "hash-table: two equivalent keys were provided"
+ (car kvs)))
+ (else (hashtable-set! ht (car kvs) (cadr kvs))
+ (loop (cddr kvs)))))
+ (hashtable-copy ht #f)))
+
+(define (hash-table-unfold stop? mapper successor seed comparator . rest)
+ (let ((ht (apply make-hash-table comparator rest)))
+ (let loop ((seed seed))
+ (if (stop? seed)
+ ht
+ (call-with-values
+ (lambda () (mapper seed))
+ (lambda (key val)
+ (hash-table-set! ht key val)
+ (loop (successor seed))))))))
+
+(define (alist->hash-table alist comparator/equiv . rest)
+ (if (and (not (null? rest))
+ (procedure? (car rest)))
+ (issue-warning-deprecated 'srfi-69-style:alist->hash-table))
+ (let ((ht (apply make-hash-table comparator/equiv rest))
+ (entries (reverse alist)))
+ (for-each (lambda (entry)
+ (hash-table-set! ht (car entry) (cdr entry)))
+ entries)
+ ht))
+
+;;; Predicates.
+
+(define (hash-table? obj)
+ (hashtable? obj))
+
+(define (hash-table-contains? ht key)
+ (hashtable-contains? ht key))
+
+(define (hash-table-empty? ht)
+ (= 0 (hashtable-size ht)))
+
+;;; FIXME: walks both hash tables because their key comparators
+;;; might be different
+
+(define (hash-table=? value-comparator ht1 ht2)
+ (let ((val=? (comparator-equality-predicate value-comparator))
+ (n1 (hash-table-size ht1))
+ (n2 (hash-table-size ht2)))
+ (and (= n1 n2)
+ (hash-table-every (lambda (key val1)
+ (and (hashtable-contains? ht2 key)
+ (val=? val1
+ (hashtable-ref ht2 key 'ignored))))
+ ht1)
+ (hash-table-every (lambda (key val2)
+ (and (hashtable-contains? ht1 key)
+ (val=? val2
+ (hashtable-ref ht1 key 'ignored))))
+ ht2))))
+
+(define (hash-table-mutable? ht)
+ (hashtable-mutable? ht))
+
+;;; Accessors.
+
+(define (hash-table-ref ht key . rest)
+ (let ((failure (if (null? rest) #f (car rest)))
+ (success (if (or (null? rest) (null? (cdr rest))) #f (cadr rest)))
+ (val (hashtable-ref ht key %not-found)))
+ (cond ((eq? val %not-found)
+ (if (and failure (procedure? failure))
+ (failure)
+ (error %not-found-message ht key %not-found-irritant)))
+ (success
+ (success val))
+ (else
+ val))))
+
+(define (hash-table-ref/default ht key default)
+ (hashtable-ref ht key default))
+
+;;; Mutators.
+
+(define (hash-table-set! ht . rest)
+ (if (= 2 (length rest))
+ (hashtable-set! ht (car rest) (cadr rest))
+ (let loop ((kvs rest))
+ (cond ((and (not (null? kvs))
+ (not (null? (cdr kvs))))
+ (hashtable-set! ht (car kvs) (cadr kvs))
+ (loop (cddr kvs)))
+ ((not (null? kvs))
+ (error "hash-table-set!: wrong number of arguments"
+ (cons ht rest)))))))
+
+(define (hash-table-delete! ht . keys)
+ (let loop ((keys keys) (cnt 0))
+ (cond ((null? keys) cnt)
+ ((hash-table-contains? ht (car keys))
+ (hashtable-delete! ht (car keys))
+ (loop (cdr keys) (+ cnt 1)))
+ (else
+ (loop (cdr keys) cnt)))))
+
+(define (hash-table-intern! ht key failure)
+ (if (hashtable-contains? ht key)
+ (hash-table-ref ht key)
+ (let ((val (failure)))
+ (hash-table-set! ht key val)
+ val)))
+
+(define (hash-table-update! ht key updater . rest)
+ (hash-table-set! ht
+ key
+ (updater (apply hash-table-ref ht key rest))))
+
+(define (hash-table-update!/default ht key updater default)
+ (hash-table-set! ht key (updater (hashtable-ref ht key default))))
+
+(define (hash-table-pop! ht)
+ (call/cc
+ (lambda (return)
+ (hash-table-for-each
+ (lambda (key value)
+ (hash-table-delete! ht key)
+ (return key value))
+ ht)
+ (error "hash-table-pop!: hash table is empty" ht))))
+
+(define (hash-table-clear! ht)
+ (hashtable-clear! ht))
+
+;;; The whole hash table.
+
+(define (hash-table-size ht)
+ (hashtable-size ht))
+
+(define (hash-table-keys ht)
+ (vector->list (hashtable-keys ht)))
+
+(define (hash-table-values ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (vector->list vals))))
+
+(define (hash-table-entries ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (values (vector->list keys)
+ (vector->list vals)))))
+
+(define (hash-table-find proc ht failure)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals))
+ (if (null? keys)
+ (failure)
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (proc key val)))
+ (or x
+ (loop (cdr keys)
+ (cdr vals)))))))))
+
+(define (hash-table-count pred ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals)
+ (n 0))
+ (if (null? keys)
+ n
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (pred key val)))
+ (loop (cdr keys)
+ (cdr vals)
+ (if x (+ n 1) n))))))))
+
+;;; Mapping and folding.
+
+(define (hash-table-map proc comparator ht)
+ (let ((result (make-hash-table comparator)))
+ (hash-table-for-each
+ (lambda (key val)
+ (hash-table-set! result key (proc val)))
+ ht)
+ result))
+
+(define (hash-table-map->list proc ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (map proc keys vals))))
+
+;;; With this particular implementation, the proc can safely mutate ht.
+;;; That property is not guaranteed by the specification, but can be
+;;; relied upon by procedures defined in this file.
+
+(define (hash-table-for-each proc ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (vector-for-each proc keys vals))))
+
+(define (hash-table-map! proc ht)
+ (hash-table-for-each (lambda (key val)
+ (hashtable-set! ht key (proc key val)))
+ ht))
+
+(define (hash-table-fold proc init ht)
+ (if (hashtable? proc)
+ (deprecated:hash-table-fold proc init ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals)
+ (x init))
+ (if (null? keys)
+ x
+ (loop (cdr keys)
+ (cdr vals)
+ (proc (car keys) (car vals) x))))))))
+
+(define (hash-table-prune! proc ht)
+ (hash-table-for-each (lambda (key val)
+ (if (proc key val)
+ (hashtable-delete! ht key)))
+ ht))
+
+;;; Copying and conversion.
+
+(define (hash-table-copy ht . rest)
+ (apply hashtable-copy ht rest))
+
+(define (hash-table-empty-copy ht)
+ (let* ((ht2 (hashtable-copy ht #t))
+ (ignored (hashtable-clear! ht2)))
+ ht2))
+
+(define (hash-table->alist ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (map cons keys vals))))
+
+;;; Hash tables as sets.
+
+(define (hash-table-union! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key2 val2)
+ (if (not (hashtable-contains? ht1 key2))
+ (hashtable-set! ht1 key2 val2)))
+ ht2)
+ ht1)
+
+(define (hash-table-intersection! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key1 val1)
+ (if (not (hashtable-contains? ht2 key1))
+ (hashtable-delete! ht1 key1)))
+ ht1)
+ ht1)
+
+(define (hash-table-difference! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key1 val1)
+ (if (hashtable-contains? ht2 key1)
+ (hashtable-delete! ht1 key1)))
+ ht1)
+ ht1)
+
+(define (hash-table-xor! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key2 val2)
+ (if (hashtable-contains? ht1 key2)
+ (hashtable-delete! ht1 key2)
+ (hashtable-set! ht1 key2 val2)))
+ ht2)
+ ht1)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The following procedures are deprecated by SRFI 125, but must
+;;; be exported nonetheless.
+;;;
+;;; Programs that import the (srfi 125) library must rename the
+;;; deprecated string-hash and string-ci-hash procedures to avoid
+;;; conflict with the string-hash and string-ci-hash procedures
+;;; exported by SRFI 126 and SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (deprecated:hash obj . rest)
+ (issue-warning-deprecated 'hash)
+ (default-hash obj))
+
+(define (deprecated:string-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-hash)
+ (string-hash obj))
+
+(define (deprecated:string-ci-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-ci-hash)
+ (string-ci-hash obj))
+
+(define (deprecated:hash-by-identity obj . rest)
+ (issue-warning-deprecated 'hash-by-identity)
+ (deprecated:hash obj))
+
+(define (deprecated:hash-table-equivalence-function ht)
+ (issue-warning-deprecated 'hash-table-equivalence-function)
+ (hashtable-equivalence-function ht))
+
+(define (deprecated:hash-table-hash-function ht)
+ (issue-warning-deprecated 'hash-table-hash-function)
+ (hashtable-hash-function ht))
+
+(define (deprecated:hash-table-exists? ht key)
+ (issue-warning-deprecated 'hash-table-exists?)
+ (hash-table-contains? ht key))
+
+(define (deprecated:hash-table-walk ht proc)
+ (issue-warning-deprecated 'hash-table-walk)
+ (hash-table-for-each proc ht))
+
+(define (deprecated:hash-table-fold ht proc seed)
+ (issue-warning-deprecated 'srfi-69-style:hash-table-fold)
+ (hash-table-fold proc seed ht))
+
+(define (deprecated:hash-table-merge! ht1 ht2)
+ (issue-warning-deprecated 'hash-table-merge!)
+ (hash-table-union! ht1 ht2))
+
+; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0fb5827cc..13eb1f24f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
+ tests/srfi-125.test \
tests/srfi-126.test \
tests/srfi-128.test \
tests/srfi-171.test \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
$(SCM_TESTS) \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
+ tests/srfi-125-test.scm \
tests/srfi-126-test.scm \
tests/srfi-128-test.scm \
ChangeLog-2008
diff --git a/test-suite/tests/srfi-125-test.scm b/test-suite/tests/srfi-125-test.scm
new file mode 100644
index 000000000..3aa5ef2a6
--- /dev/null
+++ b/test-suite/tests/srfi-125-test.scm
@@ -0,0 +1,887 @@
+;;; Copyright (C) William D Clinger 2015. All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; This is a very shallow sanity test for hash tables.
+;;;
+;;; Tests marked by a "FIXME: glass-box" comment test behavior of the
+;;; reference implementation that is not required by the specification.
+
+(use-modules (srfi srfi-125)
+ ((rnrs base) :version (6) #:hide (error))
+ ((rnrs sorting) :version (6) #:select (list-sort)) ;(scheme sort)
+ (srfi srfi-34)
+ (srfi srfi-64)
+ ((srfi srfi-126) #:select (hashtable-copy))
+ (srfi srfi-128)) ;(scheme comparator)
+
+;;; Commentary:
+
+;;; The test suite was slightly adjusted to use SRFI 64, for better
+;;; integration with the Guile test suite.
+
+;;; Code:
+
+(test-begin "srfi-125")
+
+;;; FIXME: when debugging catastrophic failures, printing every expression
+;;; before it's executed may help.
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ expr expected)
+ (test-equal expr expected))))
+
+(define-syntax test-deny
+ (syntax-rules ()
+ ((_ expr)
+ (test-assert (not expr)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from SRFI 114 to SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define default-comparator (make-default-comparator))
+
+;;; SRFI 128 says the following definition will work, but that's
+;;; an error in SRFI 128; the hash function produce non-integers.
+
+#;
+(define number-comparator
+ (make-comparator real? = < (lambda (x) (exact (abs x)))))
+
+(define number-comparator
+ (make-comparator real? = < (lambda (x) (exact (abs (round x))))))
+
+(define string-comparator
+ (make-comparator string? string=? string<? string-hash))
+
+(define string-ci-comparator
+ (make-comparator string? string-ci=? string-ci<? string-ci-hash))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from earlier draft of SRFI 125 to this draft.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Returns an immutable hash table.
+
+(define (hash-table-tabulate comparator n proc)
+ (let ((ht (make-hash-table comparator)))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ (hash-table-copy ht))
+ (call-with-values
+ (lambda ()
+ (proc i))
+ (lambda (key val)
+ (hash-table-set! ht key val))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+(define ht-default (make-hash-table default-comparator))
+
+(define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
+
+(define ht-eqv (make-hash-table eqv-comparator))
+
+(define ht-eq2 (make-hash-table eq?))
+
+(define ht-eqv2 (make-hash-table eqv?))
+
+(define ht-equal (make-hash-table equal?))
+
+(define ht-string (make-hash-table string=?))
+
+(define ht-string-ci (make-hash-table string-ci=?))
+
+(define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box
+
+(define ht-fixnum (make-hash-table = abs))
+
+(define ht-default2
+ (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#()))
+
+(define ht-fixnum2
+ (hash-table-tabulate number-comparator
+ 10
+ (lambda (i) (values (* i i) i))))
+
+(define ht-string2
+ (hash-table-unfold (lambda (s) (= 0 (string-length s)))
+ (lambda (s) (values s (string-length s)))
+ (lambda (s) (substring s 0 (- (string-length s) 1)))
+ "prefixes"
+ string-comparator
+ 'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
+
+(define ht-string-ci2
+ (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
+ string-ci-comparator
+ "ignored1" 'ignored2))
+
+(define ht-symbol2
+ (alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow))
+ eq?))
+
+(define ht-equal2
+ (alist->hash-table '(((edward) . abbey)
+ ((dashiell) . hammett)
+ ((edward) . teach)
+ ((mark) . twain))
+ equal?
+ (comparator-hash-function default-comparator)))
+
+(define test-tables
+ (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z)
+ ht-eq ht-eq2 ; initially empty
+ ht-eqv ht-eqv2 ; initially empty
+ ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark)
+ ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes"
+ ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
+ ht-symbol ht-symbol2 ; initial keys: mary, noel, peter
+ ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81
+
+;;; Predicates
+
+(test (map hash-table?
+ (cons '#()
+ (cons default-comparator
+ test-tables)))
+ (append '(#f #f) (map (lambda (x) #t) test-tables)))
+
+(test (map hash-table-contains?
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t))
+
+(test (map hash-table-contains?
+ test-tables
+ '(#u8() 47.9
+ '#() '()
+ foo bar
+ 19 (henry)
+ "p" "perp"
+ "mike" "Noel"
+ jane paul
+ 0 5))
+ (map (lambda (x) #f) test-tables))
+
+(test (map hash-table-empty? test-tables)
+ '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ test-tables)
+ (map (lambda (x) #t) test-tables))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ (do ((tables (reverse test-tables) (cddr tables))
+ (rev '() (cons (car tables) (cons (cadr tables) rev))))
+ ((null? tables)
+ rev)))
+ '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f))
+
+(test (map hash-table-mutable? test-tables)
+ '(#t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #f))
+
+;;; FIXME: glass-box
+
+(test (map hash-table-mutable? (map hash-table-copy test-tables))
+ (map (lambda (x) #f) test-tables))
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t))
+ #t)
+
+;;; Accessors.
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key)))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err))))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(err "fever" err err err err err twain err 4 err 4 err stookey err 2))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key (lambda () 'eh))))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key (lambda () 'eh) list)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2)))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'eh))
+ (hash-table-ref/default ht 'not-a-key 'eh)))
+ test-tables)
+ (map (lambda (ht) 'eh) test-tables))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref/default ht key 'eh)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (begin (hash-table-set! ht-fixnum)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '())
+
+(test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '(121 144 169))
+
+(test (begin (hash-table-set! ht-fixnum
+ 0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '(0 1 4 9 16 25 36 49 64 81 121 144 169))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1))
+
+(test (begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (hash-table-intern! ht-fixnum 0 (lambda () 0))
+ (hash-table-intern! ht-fixnum 1 (lambda () 1))
+ (hash-table-intern! ht-fixnum 1 (lambda () 99))
+ (hash-table-intern! ht-fixnum 121 (lambda () 66))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
+ (hash-table-map->list vector ht-fixnum))
+ '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13)))
+
+(test (begin (hash-table-prune! (lambda (key val)
+ (and (odd? key) (> val 10)))
+ ht-fixnum)
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum)))
+ '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13)))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 144 (lambda () 9999))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum)))
+ '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13)))
+
+(test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 -)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 - abs)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 5)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 999)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (let* ((n0 (hash-table-size ht-fixnum))
+ (ht (hash-table-copy ht-fixnum #t)))
+ (call-with-values
+ (lambda () (hash-table-pop! ht))
+ (lambda (key val)
+ (list (= key (* val val))
+ (= (- n0 1) (hash-table-size ht))))))
+ '(#t #t))
+
+(test (begin (hash-table-delete! ht-fixnum 75)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 75 81)))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1))
+
+(let ((ht-eg (hashtable-copy (hash-table number-comparator
+ 1 1 4 2 9 3 16 4 25 5 64 8)
+ #t))) ;make it mutable
+ (test (hash-table-delete! ht-eg)
+ 0)
+ (test (hash-table-delete! ht-eg 2 7 2000)
+ 0)
+ (test (hash-table-delete! ht-eg 1 2 4 7 64 2000)
+ 3)
+ (test-assert (= 3 (length (hash-table-keys ht-eg)))))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (begin (hash-table-set! ht-fixnum 36 6)
+ (hash-table-set! ht-fixnum 81 9)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 6 -1 8 9))
+
+(test (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq))
+ 0)
+
+;;; The whole hash table.
+
+(test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
+ (hash-table-size ht-eq))
+ 3)
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+ (n0 (hash-table-size ht))
+ (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
+ (n1 (hash-table-size ht)))
+ (list n0 n1 (hash-table=? default-comparator ht ht-eq)))
+ '(0 3 #t))
+
+(test (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq))
+ 0)
+
+(test (hash-table-find (lambda (key val)
+ (if (= 144 key (* val val))
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99))
+ '(144 12))
+
+(test (hash-table-find (lambda (key val)
+ (if (= 144 key val)
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99))
+ 99)
+
+(test (hash-table-count <= ht-fixnum)
+ 2)
+
+;;; Mapping and folding.
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))
+ '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))
+
+(test (let ((ht (hash-table-map (lambda (val) (* val val))
+ eqv-comparator
+ ht-fixnum)))
+ (map (lambda (i) (hash-table-ref/default ht i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+ '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1))
+
+(test (let ((keys (make-vector 15 -1))
+ (vals (make-vector 15 -1)))
+ (hash-table-for-each (lambda (key val)
+ (vector-set! keys val key)
+ (vector-set! vals val val))
+ ht-fixnum)
+ (list keys vals))
+ '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+ #(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)))
+
+(test (begin (hash-table-map! (lambda (key val)
+ (if (<= 10 key)
+ (- val)
+ val))
+ ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+ '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1))
+
+(test (hash-table-fold (lambda (key val acc)
+ (+ val acc))
+ 0
+ ht-string-ci2)
+ 13)
+
+(test (list-sort < (hash-table-fold (lambda (key val acc)
+ (cons key acc))
+ '()
+ ht-fixnum))
+ '(0 1 4 9 16 25 36 64 81 121 144 169))
+
+;;; Copying and conversion.
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum))
+ #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f))
+ #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t))
+ #t)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum))
+ #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #f))
+ #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #t))
+ #t)
+
+(test (hash-table->alist ht-eq)
+ '())
+
+(test (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+;;; Hash tables as sets.
+
+(test (begin (hash-table-union! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-union! ht ht-fixnum)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+(test (begin (hash-table-union! ht-eqv2 ht-fixnum)
+ (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+ #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-fixnum)
+ (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+ #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-eqv)
+ (hash-table-empty? ht-eqv2))
+ #t)
+
+(test (begin (hash-table-intersection! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9)))
+
+(test (begin (hash-table-intersection!
+ ht-fixnum
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((4 . 2)
+ (25 . -5)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-difference!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-xor!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((-1 . -1)
+ (0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (100 . 10)))
+
+(test (guard (exn
+ (else 'key-not-found))
+ (hash-table-ref ht-default "this key won't be present"))
+ 'key-not-found)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Desultory tests of deprecated procedures and usages.
+;;; Deprecated usage of make-hash-table and alist->hash-table
+;;; has already been tested above.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (deprecated:hash x))
+ (h2 (deprecated:hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (deprecated:string-hash x))
+ (h2 (deprecated:string-hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (deprecated:string-ci-hash x))
+ (h2 (deprecated:string-ci-hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+ (y x)
+ (h1 (deprecated:hash-by-identity x))
+ (h2 (deprecated:hash-by-identity y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (hash x 60))
+ (h2 (hash y 60)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (deprecated:string-hash x 97))
+ (h2 (deprecated:string-hash y 97)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (deprecated:string-ci-hash x 101))
+ (h2 (deprecated:string-ci-hash y 101)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+ (y x)
+ (h1 (deprecated:hash-by-identity x 102))
+ (h2 (deprecated:hash-by-identity y 102)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let ((f (deprecated:hash-table-equivalence-function ht-fixnum)))
+ (if (procedure? f)
+ (f 34 34)
+ #t))
+ #t)
+
+(test (let ((f (deprecated:hash-table-hash-function ht-fixnum)))
+ (if (procedure? f)
+ (= (f 34) (f 34))
+ #t))
+ #t)
+
+(test (map (lambda (key) (deprecated:hash-table-exists? ht-fixnum2 key))
+ '(0 1 2 3 4 5 6 7 8 9 10))
+ '(#t #t #f #f #t #f #f #f #f #t #f))
+
+(test (let ((n 0))
+ (deprecated:hash-table-walk ht-fixnum2
+ (lambda (key val) (set! n (+ n key))))
+ n)
+ (apply +
+ (map (lambda (x) (* x x))
+ '(0 1 2 3 4 5 6 7 8 9))))
+
+(test (list-sort < (hash-table-fold ht-fixnum2
+ (lambda (key val acc)
+ (cons key acc))
+ '()))
+ '(0 1 4 9 16 25 36 49 64 81))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t))
+ (ht2 (hash-table number-comparator
+ .25 .5 64 9999 81 9998 121 -11 144 -12)))
+ (deprecated:hash-table-merge! ht ht2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (.25 . .5)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12)))
+
+;;; Bugs reported on 5 January 2019 by Jéssica Milaré
+;;; ( https://srfi-email.schemers.org/srfi-125/msg/10177551 )
+
+;;; Spec says hash-table returns an immutable hash table (if that
+;;; is supported) and signal an error if there are duplicate keys,
+;;; but standard implementation returns a mutable hash table and
+;;; signals no error with duplicate keys.
+;;;
+;;; Comment by Will Clinger: the spec says specifying a duplicate
+;;; key "is an error", so hash-table is not required to signal an
+;;; error when there are duplicate keys. That part of the spec
+;;; was added on 8 May 2016, which is why it was not implemented
+;;; by the sample implementation of 2 May 2016. Because a duplicate
+;;; key "is an error" rather than "signals an error", testing for
+;;; that situation is glass-box, as is testing for immutability.
+
+;;; FIXME: glass-box
+
+(test (hash-table-mutable?
+ (hash-table number-comparator
+ .25 .5 64 9999 81 9998 121 -11 144 -12))
+ #f)
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (guard (exn
+ (else 'eh))
+ (hash-table number-comparator .25 .5 .25 -.5))
+ 'eh)
+
+;;; Spec says hash-table-set! must go left to right, but in
+;;; standard implementation it goes right to left.
+;;;
+;;; Comment by Will Clinger: the left-to-right requirement was
+;;; added to the spec on 8 May 2016, which is why it was not
+;;; implemented by the sample implementation of 2 May 2016.
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+ (ignored (hash-table-set! ht 'foo 13 'bar 14 'foo 18)))
+ (hash-table-ref ht 'foo))
+ 18)
+
+;;; Spec says hash-table-empty-copy returns a mutable hash table,
+;;; but in standard implementation it returns an immutable hash
+;;; table if the given hash table is immutable.
+
+;;; FIXME: glass-box (immutable tables need not be supported)
+
+(test (hash-table-mutable?
+ (hash-table number-comparator))
+ #f)
+
+(test (hash-table-mutable?
+ (hash-table-empty-copy
+ (hash-table-copy (hash-table number-comparator) #f)))
+ #t)
+
+;;; hash-table-delete! seems to loop infinitely once it finds a key.
+;;;
+;;; Comment by Will Clinger: that bug was added by
+;;; commit e17c15203a934ab741300e59619f880f363c2b2f
+;;; on 26 September 2018. I do not understand the purpose of that
+;;; commit, as its one change appears to have had no substantive
+;;; effect apart from inserting this bug.
+
+(test (let* ((ht
+ (hash-table default-comparator 'foo 1 'bar 2 'baz 3))
+ (ht (hash-table-copy ht #t)))
+ (hash-table-delete! ht 'foo)
+ (hash-table-size ht))
+ 2)
+
+(test-end "srfi-125")
+
+; eof
diff --git a/test-suite/tests/srfi-125.test b/test-suite/tests/srfi-125.test
new file mode 100644
index 000000000..0d7946ac5
--- /dev/null
+++ b/test-suite/tests/srfi-125.test
@@ -0,0 +1,47 @@
+;;;; srfi-125.test --- Test suite for SRFI-125. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-125)
+ #:use-module (srfi srfi-125)
+ #:use-module (srfi srfi-64))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-125-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; Endxsn
\ No newline at end of file
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
* [PATCH v3 6/6] module: Add srfi-151.
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
` (3 preceding siblings ...)
2023-11-18 6:05 ` [PATCH v3 5/6] module: Add srfi-125 Maxim Cournoyer
@ 2023-11-18 6:05 ` Maxim Cournoyer
4 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-11-18 6:05 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-151.scm
* module/srfi/srfi-151/bitwise-33.scm
* module/srfi/srfi-151/bitwise-60.scm
* module/srfi/srfi-151/bitwise-other.scm
* test-suite/tests/srfi-151.test
* test-suite/tests/srfi-151-test.scm: New files.
* am/bootstrap.am (SOURCES): Register srfi-151.scm.
(NOCOMP_SOURCES): Register srfi-151/bitwise-33.scm,
srfi-151/bitwise-60.scm and srfi-151/bitwise-other.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-151.test.
(EXTRA_DIST): Register srfi-151-test.scm.
* doc/ref/srfi-modules.texi (SRFI 151): Document it.
---
Changes in v3:
- Add SRFI 151
am/bootstrap.am | 4 +
doc/ref/srfi-modules.texi | 813 +++++++++++++++++++++++++
module/srfi/srfi-151.scm | 56 ++
module/srfi/srfi-151/bitwise-33.scm | 108 ++++
module/srfi/srfi-151/bitwise-60.scm | 70 +++
module/srfi/srfi-151/bitwise-other.scm | 62 ++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-151-test.scm | 381 ++++++++++++
test-suite/tests/srfi-151.test | 46 ++
9 files changed, 1542 insertions(+)
create mode 100644 module/srfi/srfi-151.scm
create mode 100644 module/srfi/srfi-151/bitwise-33.scm
create mode 100644 module/srfi/srfi-151/bitwise-60.scm
create mode 100644 module/srfi/srfi-151/bitwise-other.scm
create mode 100644 test-suite/tests/srfi-151-test.scm
create mode 100644 test-suite/tests/srfi-151.test
diff --git a/am/bootstrap.am b/am/bootstrap.am
index ae977c48d..002f598ac 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -350,6 +350,7 @@ SOURCES = \
srfi/srfi-125.scm \
srfi/srfi-126.scm \
srfi/srfi-128.scm \
+ srfi/srfi-151.scm \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -442,6 +443,9 @@ NOCOMP_SOURCES = \
srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
srfi/srfi-128/128.body2.scm \
+ srfi/srfi-151/bitwise-33.scm \
+ srfi/srfi-151/bitwise-60.scm \
+ srfi/srfi-151/bitwise-other.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 087c27e4b..c42cc4d17 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -67,6 +67,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 125:: Mutators.
* SRFI 126:: R6RS-based hash tables.
* SRFI 128:: Comparators.
+* SRFI 151:: Bitwise Operations.
* SRFI-171:: Transducers.
@end menu
@@ -7414,6 +7415,818 @@ returns true, @var{greater-than} is evaluated and its value returned.
If @var{comparator} is omitted, a default comparator is used.
@end deffn
+@node SRFI 151
+@subsection SRFI 151 Bitwise Operations
+@cindex SRFI 151
+
+@menu
+* SRFI 151 Abstract::
+* SRFI 151 Rationale::
+* SRFI 151 Procedure index::
+* SRFI 151 Basic operations::
+* SRFI 151 Integer operations::
+* SRFI 151 Single-bit operations::
+* SRFI 151 Bit field operations::
+* SRFI 151 Bits conversion::
+* SRFI 151 Fold/unfold and generate::
+@end menu
+
+@node SRFI 151 Abstract
+@subsubsection SRFI 151 Abstract
+
+This SRFI proposes a coherent and comprehensive set of procedures for
+performing bitwise logical operations on integers; it is accompanied by
+a reference implementation of the spec in terms of a set of seven core
+operators.
+
+The precise semantics of these operators is almost never an issue. A
+consistent, portable set of @emph{names} and @emph{parameter
+conventions}, however, is. Hence this SRFI, which is based mainly on
+@url{https://srfi.schemers.org/srfi-33/srfi-33.html, SRFI 33}, with some
+changes and additions from
+@url{http://srfi.schemers.org/srfi-33/mail-archive/msg00023.html, Olin's
+late revisions to SRFI 33} (which were never consummated).
+@url{https://srfi.schemers.org/srfi-60/srfi-60.html, SRFI 60} (based on
+SLIB) is smaller but has a few procedures of its own; some of its
+procedures have both native (often Common Lisp) and SRFI 33 names. They
+have been incorporated into this SRFI.
+@url{http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-12.html#node_sec_11.4,
+R6RS} is a subset of SRFI 60, except that all procedure names begin with
+a @code{bitwise-} prefix. A few procedures have been added from the
+general vector @url{https://srfi.schemers.org/srfi-133/srfi-133.html,
+SRFI 133}.
+
+Among the applications of bitwise operations are: hashing, Galois-field
+calculations of error-detecting and error-correcting codes, cryptography
+and ciphers, pseudo-random number generation, register-transfer-level
+modeling of digital logic designs, Fast-Fourier transforms, packing and
+unpacking numbers in persistent data structures, space-filling curves
+with applications to dimension reduction and sparse multi-dimensional
+database indexes, and generating approximate seed values for
+root-finders and transcendental function algorithms.
+
+@noindent
+This SRFI differs from SRFI 142 in only two ways:
+
+@enumerate
+@item
+The @code{bitwise-if} function has the argument ordering of
+SLIB, SRFI 60, and R6RS rather than the ordering of SRFI 33.
+
+@item
+The order in which bits are processed by the procedures listed in the
+``Bits conversion'' section has been clarified and some of the
+procedures' names have been changed. See the ``Bit processing order''
+section for details.
+@end enumerate
+
+@node SRFI 151 Rationale
+@subsubsection SRFI 151 Rationale
+
+@subheading General design principles
+
+@itemize
+@item
+These operations interpret exact integers using two's-complement
+representation.
+
+@item
+The associative bitwise ops are required to be n-ary. Programmers can
+reliably write @code{bitwise-and} with 3 arguments, for example.
+
+@item
+The word @code{or} is never used by itself, only with modifiers:
+@code{xor}, @code{ior}, @code{nor}, @code{orc1}, or @code{orc2}. This
+is the same rule as Common Lisp.
+
+@item
+Extra and redundant functions such as @code{bitwise-count},
+@code{bitwise-nor}and the bit-field ops have been included. Settling on
+a standard choice of names makes it easier to read code that uses these
+sorts of operations. It also means computations can be clearly
+expressed using the more powerful ops rather than synthesized with a
+snarled mess of @code{bitwise-and}s, @code{bitwise-or}s, and
+@code{bitwise-not}s. What we gain is having an agreed-upon set of names
+by which we can refer to these functions. If you believe in "small is
+beautiful," then what is your motivation for including anything beyond
+@code{bitwise-nand}?
+
+@item
+Programmers don't have to re-implement the redundant functions, and
+stumble over the boundary cases and error checking, but can express
+themselves using a full palette of building blocks.
+
+@item
+Compilers can directly implement many of these ops for great efficiency
+gains without requiring any tricky analysis.
+
+@item
+Logical right or left shift operations are excluded because they are not
+well defined on general integers; they are only defined on integers in
+some finite range. Remember that, in this library, integers are
+interpreted as semi-infinite bit strings that have only a finite number
+of ones or a finite number of zeros. Logical shifting operates on bit
+strings of some fixed size. If we shift left, then leftmost bits "fall
+off" the end (and zeros shift in on the right). If we shift right, then
+zeros shift into the string on the left (and rightmost bits fall off the
+end). So to define a logical shift operation, we must specify the size
+of the window.
+@end itemize
+
+@subheading Common Lisp
+
+The core of this design mirrors the structure of Common Lisp's pretty
+closely. Here are some differences:
+
+@itemize
+@item
+"load" and "deposit" are the wrong verbs (e.g., Common Lisp's @code{ldb}
+and @code{dpb} ops), since they have nothing to do with the store.
+
+@item
+@code{boole} has been removed; it is not one with the Way of Scheme.
+Boolean functions are directly encoded in Scheme as first-class
+functions.
+
+@item
+The name choices are more in tune with Scheme conventions (hyphenation,
+using @code{?} to mark a predicate, etc.) Common Lisp's name choices
+were more historically motivated, for reasons of backward compatibility
+with Maclisp and Zetalisp.
+
+@item
+The prefix @code{log} has been changed to @code{bitwise-} (e.g,
+@code{lognot} to @code{bitwise-not}), as the prefix @code{bitwise-} more
+accurately reflects what they do.
+
+@item
+The six trivial binary boolean ops that return constants, the left or
+right arguments, and the @code{bitwise-not} of the left or right
+arguments, do not appear in this SRFI.
+
+@end itemize
+
+@subheading SRFI 33
+
+This SRFI contains all the procedures of SRFI 33, and retains their
+original names with these exceptions:
+
+@itemize
+@item
+The name @code{bitwise-merge} is replaced by @code{bitwise-if}, the name
+used in SRFI 60 and R6RS.
+
+@item
+The name @code{extract-bit-field} (@code{bit-field-extract} in Olin's
+revisions) is replaced by @code{bit-field}, the name used in SRFI 60 and
+R6RS.
+
+@item
+The names @code{any-bits-set?} and @code{all-bits-set?} are replaced by
+@code{any-bit-set?} and @code{every-bit-set?}, in accordance with Olin's
+revisions.
+
+@item
+The name @code{test-bit-field?} has been renamed @code{bit-field-any?}
+and supplemented with @code{bit-field-every?}, in accordance with Olin's
+revisions.
+
+@item
+Because @code{copy-bit-field} means different things in SRFI 33 and SRFI
+60, SRFI 33's name @code{copy-bit-field} (@code{bit-field-copy} in
+Olin's revisions) has been changed to @code{bit-field-replace-same}
+@end itemize
+
+@subheading SRFI 60
+
+SRFI 60 includes six procedures that do not have SRFI 33 equivalents.
+They are incorporated into this SRFI as follows:
+
+@itemize
+@item
+The names @code{rotate-bit-field} and @code{reverse-bit-field} are
+replaced by @code{bit-field-rotate} and @code{bit-field-reverse}, by
+analogy with Olin's revisions.
+
+@item
+The procedure @code{copy-bit} is incorporated into this SRFI with the
+same name.
+
+@item
+The procedures @code{integer->list} and @code{list->integer}are
+incorporated into this SRFI with the slightly different names
+@code{integer->bits}and @code{bits->integer} because they are
+incompatible with SRFI 60.
+
+@item
+The procedure @code{booleans->integer} is a convenient way to specify a
+bitwise integer: it accepts an arbitrary number of boolean arguments and
+returns a non-negative integer. So in this SRFI it has the short name
+@code{bits}, roughly analogous to @code{list}, @code{string}, and
+@code{vector}
+@end itemize
+
+@subheading Other sources
+
+@itemize
+@item
+The following procedures are inspired by
+@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}:
+@code{bit-swap}, @code{bitwise-fold}, @code{bitwise-for-each},
+@code{bitwise-unfold}.
+
+@item
+The procedure @code{bit-field-set} is the counterpart of
+@code{bit-field-clear}.
+
+@item
+The procedures @code{bits->vector} and @code{vector->bits} are inspired
+by their list counterparts.
+
+@item
+The @code{make-bitwise-generator} procedure is a generator constructor
+similar to those provided by
+@url{https://srfi.schemers.org/srfi/srfi-127.html, SRFI 127}.
+@end itemize
+
+@subheading Argument ordering and semantics
+
+In general, these procedures place the bitstring arguments to be
+operated on first. Where the operation is not commutative, the
+"destination" argument that provides the background bits to be operated
+on is placed before the "source" argument that provides the bits to be
+transferred to it.
+
+@itemize
+@item
+In SRFI 33, @code{bitwise-nand} and @code{bitwise-nor} accepted an
+arbitrary number of arguments even though they are not commutative.
+Olin's late revisions made them dyadic, and so does this SRFI.
+
+@item
+Common Lisp bit-field operations use a @emph{byte spec} to encapsulate
+the position and size of the field. SRFI 33 bit-field operations had
+leading @emph{position} and @emph{size}arguments instead. These have
+been replaced in this SRFI by trailing @emph{start} (inclusive) and
+@emph{end} (exclusive) arguments, the convention used not only in SRFI
+60 and R6RS but also in most other subsequence operations in Scheme
+standards and SRFIs.
+
+@item
+In SRFI 60, the @code{bitwise-if} function was defined with a different
+argument ordering from SRFI 33's @code{bitwise-merge}, but was provided
+under both names, using the SLIB ordering. SRFI 142 adopted the SRFI 33
+ordering rather than the SLIB and R6RS ordering. Since SLIB and R6RS
+have seen far more usage than SRFI 33, this SRFI adopts the SRFI 60
+ordering instead.
+@end itemize
+
+@subheading Bit processing order
+
+In SLIB and SRFI 60, the the order in which bits were processed by
+@code{integer->list} and @code{list->integer} was not clearly specified.
+When SRFI 142 was written, the specification was clarified to process
+bits from least significant to most significant, so that
+@samp{(integer->list 6) => (#f #t #t)}. However, the SLIB and SRFI 60
+implementation processed them from the most significant bit to the
+least-significant bit, so that @samp{(integer->list 6) => (#t #t #f)}.
+This SRFI retains the little-endian order, but renames the procedures to
+@code{bits->list} and @code{list->bits} to avoid a silent breaking
+change from SLIB and SRFI 60. The same is true of the closely analogous
+@code{integer->vector}, @code{vector->integer}, and @code{bits}
+procedures.
+
+@node SRFI 151 Procedure index
+@subsubsection SRFI 151 Procedure index
+
+@lisp
+bitwise-not
+bitwise-and bitwise-ior
+bitwise-xor bitwise-eqv
+bitwise-nand bitwise-nor
+bitwise-andc1 bitwise-andc2
+bitwise-orc1 bitwise-orc2
+arithmetic-shift bit-count
+integer-length bitwise-if
+bit-set? copy-bit bit-swap
+any-bit-set? every-bit-set?
+first-set-bit
+bit-field bit-field-any? bit-field-every?
+bit-field-clear bit-field-set
+bit-field-replace bit-field-replace-same
+bit-field-rotate bit-field-reverse
+bits->list list->bits bits->vector vector->bits
+bits
+bitwise-fold bitwise-for-each bitwise-unfold
+make-bitwise-generator
+@end lisp
+
+In the following procedure specifications all parameters and return
+values are exact integers unless otherwise indicated (except that
+procedures with names ending in @samp{?} are predicates, as usual). It
+is an error to pass values of other types as arguments to these
+functions.
+
+Bitstrings are represented by exact integers, using a two's-complement
+encoding of the bitstring. Thus every integer represents a
+semi-infinite bitstring, having either a finite number of zeros
+(negative integers) or a finite number of ones (non-negative integers).
+The bits of a bitstring are numbered from the
+rightmost/least-significant bit: bit #0 is the rightmost or 2@sup{0}
+bit, bit #1 is the next or 2@sup{1} bit, and so forth.
+
+@node SRFI 151 Basic operations
+@subsubsection SRFI 151 Basic operations
+
+@deffn {Scheme Procedure} bitwise-not i
+
+Returns the bitwise complement of @emph{i}; that is, all 1 bits are changed
+to 0 bits and all 0 bits to 1 bits.
+
+@lisp
+ (bitwise-not 10) => -11
+ (bitwise-not -37) => 36
+@end lisp
+
+@end deffn
+
+The following ten procedures correspond to the useful set of non-trivial
+two-argument boolean functions. For each such function, the
+corresponding bitwise operator maps that function across a pair of
+bitstrings in a bit-wise fashion. The core idea of this group of
+functions is this bitwise ``lifting'' of the set of dyadic boolean
+functions to bitstring parameters.
+
+@deffn {Scheme Procedure} bitwise-and i @dots{}
+@deffnx {Scheme Procedure} bitwise-ior i @dots{}
+@deffnx {Scheme Procedure} bitwise-xor i @dots{}
+@deffnx {Scheme Procedure} bitwise-eqv i @dots{}
+
+These operations are associative. When passed no arguments, the procedures
+return the identity values -1, 0, 0, and -1 respectively.
+
+The @code{bitwise-eqv} procedure produces the complement of the
+@code{bitwise-xor} procedure. When applied to three arguments, it does
+@emph{not} produce a 1 bit everywhere that @var{a}, @var{b} and @var{c}
+all agree. That is, it does @emph{not} produce:
+
+@lisp
+ (bitwise-ior (bitwise-and a b c)
+ (bitwise-and (bitwise-not a)
+ (bitwise-not b)
+ (bitwise-not c)))
+@end lisp
+
+Rather, it produces @samp{(bitwise-eqv @var{a} (bitwise-eqv @var{b}
+@var{c}))} or the equivalent @samp{(bitwise-eqv (bitwise-eqv @var{a}
+@var{b}) @var{c})}:
+
+@lisp
+ (bitwise-ior 3 10) => 11
+ (bitwise-and 11 26) => 10
+ (bitwise-xor 3 10) => 9
+ (bitwise-eqv 37 12) => -42
+ (bitwise-and 37 12) => 4
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-nand i j
+@deffnx {Scheme Procedure} bitwise-nor i j
+@deffnx {Scheme Procedure} bitwise-andc1 i j
+@deffnx {Scheme Procedure} bitwise-andc2 i j
+@deffnx {Scheme Procedure} bitwise-orc1 i j
+@deffnx {Scheme Procedure} bitwise-orc2 i j
+
+These operations are not associative.
+
+@lisp
+ (bitwise-nand 11 26) => -11
+ (bitwise-nor 11 26) => -28
+ (bitwise-andc1 11 26) => 16
+ (bitwise-andc2 11 26) => 1
+ (bitwise-orc1 11 26) => -2
+ (bitwise-orc2 11 26) => -17
+@end lisp
+@end deffn
+
+@node SRFI 151 Integer operations
+@subsubsection SRFI 151 Integer operations
+
+@deffn {Scheme Procedure} arithmetic-shift i count
+
+Return the arithmetic left shift when @var{count}>0; right shift when
+@var{count}<0.
+
+@lisp
+ (arithmetic-shift 8 2) => 32
+ (arithmetic-shift 4 0) => 4
+ (arithmetic-shift 8 -1) => 4
+ (arithmetic-shift -100000000000000000000000000000000 -100) => -79
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-count i
+
+Return the population count of 1's (@emph{i} >= 0) or 0's (@emph{i} <
+0). The result is always non-negative.
+
+@quotation note
+The R6RS analogue @code{bitwise-bit-count} applies @code{bitwise-not} to
+the population count before returning it if @emph{i} is negative.
+@end quotation
+
+@lisp
+ (bit-count 0) => 0
+ (bit-count -1) => 0
+ (bit-count 7) => 3
+ (bit-count 13) => 3 ;Two's-complement binary: ...0001101
+ (bit-count -13) => 2 ;Two's-complement binary: ...1110011
+ (bit-count 30) => 4 ;Two's-complement binary: ...0011110
+ (bit-count -30) => 4 ;Two's-complement binary: ...1100010
+ (bit-count (expt 2 100)) => 1
+ (bit-count (- (expt 2 100))) => 100
+ (bit-count (- (1+ (expt 2 100)))) => 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} integer-length i
+
+The number of bits needed to represent @var{i}, i.e.
+
+@lisp
+ (ceiling (/ (log (if (negative? integer)
+ (- integer)
+ (+ 1 integer)))
+ (log 2)))
+@end lisp
+
+The result is always non-negative.
+
+For non-negative @var{i}, this is the number of bits needed to represent
+@var{i} in an unsigned binary representation. For all @var{i}, @samp{(+
+1 (integer-length @var{i}))} is the number of bits needed to represent
+@var{i} in a signed twos-complement representation.
+
+@lisp
+ (integer-length 0) => 0
+ (integer-length 1) => 1
+ (integer-length -1) => 0
+ (integer-length 7) => 3
+ (integer-length -7) => 3
+ (integer-length 8) => 4
+ (integer-length -8) => 3
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-if mask i j
+
+Merge the bitstrings @var{i} and @var{j}, with bitstring @var{mask}
+determining from which string to take each bit. That is, if the
+@var{k}th bit of @var{mask} is 1, then the @var{k}th bit of the result
+is the @var{k}th bit of @var{i}, otherwise the @var{k}th bit of @var{j}.
+
+@lisp
+ (bitwise-if 3 1 8) => 9
+ (bitwise-if 3 8 1) => 0
+ (bitwise-if 1 1 2) => 3
+ (bitwise-if #b00111100 #b11110000 #b00001111) => #b00110011
+@end lisp
+@end deffn
+
+@node SRFI 151 Single-bit operations
+@subsubsection SRFI 151 Single-bit operations
+
+As always, the rightmost/least-significant bit in @var{i} is bit 0.
+
+@deffn {Scheme Procedure} bit-set? index i
+
+Is bit @var{index} set in bitstring @var{i} (where @var{index} is a
+non-negative exact integer)?
+
+@quotation note
+The R6RS analogue @code{bitwise-bit-set?} accepts its arguments in the
+opposite order.
+@end quotation
+
+@lisp
+ (bit-set? 1 1) => false
+ (bit-set? 0 1) => true
+ (bit-set? 3 10) => true
+ (bit-set? 1000000 -1) => true
+ (bit-set? 2 6) => true
+ (bit-set? 0 6) => false
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} copy-bit index i boolean
+
+Return an integer the same as @var{i} except in the @var{index}th bit,
+which is 1 if @var{boolean} is @code{#t} and 0 if @var{boolean} is
+@code{#f}.
+
+@quotation note
+The R6RS analogue @code{bitwise-copy-bit} as originally documented has a
+completely different interface. @samp{(bitwise-copy-bit @var{dest}
+@var{ndex} @var{source})} replaces the @var{index}'th bit of @var{dest}
+with the @var{index}'th bit of @var{source}. It is equivalent to
+@samp{(bit-field-replace-same @var{dest} @var{source} @var{index} (+
+@var{index} 1))}.
+@end quotation
+
+@lisp
+(copy-bit 0 0 #t) => #b1
+(copy-bit 2 0 #t) => #b100
+(copy-bit 2 #b1111 #f) => #b1011
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-swap index@sub{1} index@sub{2} i
+
+Return an integer the same as @var{i} except that the
+@var{index@sub{1}}th bit and the @var{index@sub{2}}th bit have been
+exchanged.
+
+@lisp
+(bit-swap 0 2 4) => #b1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} any-bit-set? test-bits i
+@deffnx {Scheme Procedure} every-bit-set? test-bits i
+
+Determine if any/all of the bits set in bitstring @var{test-bits} are
+set in bitstring @var{i}. I.e., return @samp{(not (zero? (bitwise-and
+@var{test-bits} @var{i})))} and @samp{(= @var{test-bits} (bitwise-and
+@var{test-bits} @var{i}))} respectively.
+
+@lisp
+ (any-bit-set? 3 6) => #t
+ (any-bit-set? 3 12) => #f
+ (every-bit-set? 4 6) => #t
+ (every-bit-set? 7 6) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} first-set-bit i
+
+Return the index of the first (smallest index) 1 bit in bitstring
+@var{i}. Return -1 if @var{i} contains no 1 bits (i.e., if @var{i} is
+zero).
+
+@lisp
+ (first-set-bit 1) => 0
+ (first-set-bit 2) => 1
+ (first-set-bit 0) => -1
+ (first-set-bit 40) => 3
+ (first-set-bit -28) => 2
+ (first-set-bit (expt 2 99)) => 99
+ (first-set-bit (expt -2 99)) => 99
+@end lisp
+@end deffn
+
+@node SRFI 151 Bit field operations
+@subsubsection SRFI 151 Bit field operations
+
+These functions operate on a contiguous field of bits (a "byte", in
+Common Lisp parlance) in a given bitstring. The @var{start} and
+@var{end} arguments, which are not optional, are non-negative exact
+integers specifying the field: it is the @var{end-start} bits running
+from bit @var{start} to bit @var{end}-1.
+
+@deffn {Scheme Procedure} bit-field i start end
+
+Return the field from @var{i}, shifted down to the least-significant
+position in the result.
+
+@lisp
+ (bit-field #b1101101010 0 4) => #b1010
+ (bit-field #b1101101010 3 9) => #b101101
+ (bit-field #b1101101010 4 9) => #b10110
+ (bit-field #b1101101010 4 10) => #b110110
+ (bit-field 6 0 1) => 0
+ (bit-field 6 1 3) => 3
+ (bit-field 6 2 999) => 1
+ (bit-field #x100000000000000000000000000000000 128 129) => 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-any? i start end
+
+Return true if any of the field's bits are set in bitstring @var{i},
+and false otherwise.
+
+@lisp
+ (bit-field-any? #b1001001 1 6) => #t
+ (bit-field-any? #b1000001 1 6) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-every? i start end
+
+Return false if any of the field's bits are not set in bitstring
+@var{i}, and true otherwise.
+
+@lisp
+ (bit-field-every? #b1011110 1 5) => #t
+ (bit-field-every? #b1011010 1 5) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-clear i start end
+@deffnx {Scheme Procedure} bit-field-set i start end
+
+Return @var{i} with the field's bits set to all 0s/1s.
+
+@lisp
+ (bit-field-clear #b101010 1 4) => #b100000
+ (bit-field-set #b101010 1 4) => #b101110
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-replace dest source start end
+
+Return @var{dest} with the field replaced by the least-significant
+@var{end-start} bits in @var{source}.
+
+@lisp
+ (bit-field-replace #b101010 #b010 1 4) => #b100100
+ (bit-field-replace #b110 1 0 1) => #b111
+ (bit-field-replace #b110 1 1 2) => #b110
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-replace-same dest source start end
+
+Return @var{dest} with its field replaced by the corresponding field in
+@var{source}.
+
+@lisp
+ (bit-field-replace-same #b1111 #b0000 1 3) => #b1001
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-rotate i count start end
+
+Return @var{i} with the field cyclically permuted by @var{count} bits
+towards high-order.
+
+@quotation note
+The R6RS analogue @code{bitwise-rotate-bit-field} uses the argument
+ordering @var{i} @var{start} @var{end} @var{count}.
+@end quotation
+
+@lisp
+ (bit-field-rotate #b110 0 0 10) => #b110
+ (bit-field-rotate #b110 0 0 256) => #b110
+ (bit-field-rotate #x100000000000000000000000000000000 1 0 129) => 1
+ (bit-field-rotate #b110 1 1 2) => #b110
+ (bit-field-rotate #b110 1 2 4) => #b1010
+ (bit-field-rotate #b0111 -1 1 4) => #b1011
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-reverse i start end
+
+Return @var{i} with the order of the bits in the field reversed.
+
+@lisp
+ (bit-field-reverse 6 1 3) => 6
+ (bit-field-reverse 6 1 4) => 12
+ (bit-field-reverse 1 0 32) => #x80000000
+ (bit-field-reverse 1 0 31) => #x40000000
+ (bit-field-reverse 1 0 30) => #x20000000
+ (bit-field-reverse #x140000000000000000000000000000000 0 129) => 5
+@end lisp
+@end deffn
+
+@node SRFI 151 Bits conversion
+@subsubsection SRFI 151 Bits conversion
+
+@deffn {Scheme Procedure} bits->list i [len]
+@deffnx {Scheme Procedure} bits->vector i [len]
+
+Return a list/vector of @var{len} booleans corresponding to each bit of
+the non-negative integer @var{i}, returning bit #0 as the first element,
+bit #1 as the second, and so on. @code{#t} is returned for each 1;
+@code{#f} for 0.
+
+@lisp
+ (bits->list #b1110101) => (#t #f #t #f #t #t #t)
+ (bits->list 3 5) => (#t #t #f #f #f)
+ (bits->list 6 4) => (#f #t #t #f)
+ (bits->vector #b1110101) => #(#t #f #t #f #t #t #t)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} list->bits list
+@deffnx {Scheme Procedure} vector->bits vector
+
+Return an integer formed from the booleans in @var{list}/@var{vector},
+using the first element as bit #0, the second element as bit #1, and so
+on. It is an error if @var{list}/@var{vector} contains non-booleans. A
+1 bit is coded for each @code{#t}; a 0 bit for @code{#f}. Note that the
+result is never a negative integer.
+
+@lisp
+ (list->bits '(#t #f #t #f #t #t #t)) => #b1110101
+ (list->bits '(#f #f #t #f #t #f #t #t #t)) => #b111010100
+ (list->bits '(#f #t #t)) => 6
+ (list->bits '(#f #t #t #f)) => 6
+ (list->bits '(#f #f #t #t)) => 12
+ (vector->bits '#(#t #f #t #f #t #t #t)) => #b1110101
+ (vector->bits '#(#f #f #t #f #t #f #t #t #t)) => #b111010100
+ (vector->bits '#(#f #t #t)) => 6
+ (vector->bits '#(#f #t #t #f)) => 6
+ (vector->bits '#(#f #f #t #t)) => 12
+@end lisp
+
+For positive integers,
+@code{bits->list} and @code{list->bits} are inverses in the sense of @code{equal?},
+and so are @code{bits->vector} and @code{vector->bits}
+@end deffn
+
+@deffn {Scheme Procedure} bits bool @dots{}
+
+Return the integer coded by the @code{bool} arguments. The first
+argument is bit #0, the second argument is bit #1, and so on. Note that
+the result is never a negative integer.
+
+@lisp
+ (bits #t #f #t #f #t #t #t) => #b1110101
+ (bits #f #f #t #f #t #f #t #t #t) => #b111010100
+@end lisp
+@end deffn
+
+@node SRFI 151 Fold/unfold and generate
+@subsubsection SRFI 151 Fold, unfold, and generate
+
+It is an error if the arguments named @var{proc}, @var{top}?,
+@var{apper} or @var{successor} are not procedures. The arguments named
+@var{seed} may be any Scheme object.
+
+@deffn {Scheme Procedure} bitwise-fold proc seed i
+
+For each bit @var{b} of @var{i} from bit #0 (inclusive) to bit
+@samp{(integer-length @var{i})}(exclusive), @var{proc} is called as
+@samp{(@var{proc} @var{b} @var{r})}, where @var{r} is the current
+accumulated result. The initial value of @var{r} is @var{seed}, and
+the value returned by @var{proc} becomes the next accumulated result.
+When the last bit has been processed, the final accumulated result
+becomes the result of @code{bitwise-fold}.
+
+@lisp
+ (bitwise-fold cons '() #b1010111) => (#t #f #t #f #t #t #t)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-for-each proc i
+
+Repeatedly apply @var{proc} to the bits of @var{i} starting with bit
+#0 (inclusive) and ending with bit @samp{(integer-length @var{i})}
+(exclusive). The values returned by @var{proc} are discarded. Return
+an unspecified value.
+
+@lisp
+ (let ((count 0))
+ (bitwise-for-each (lambda (b) (if b (set! count (+ count 1))))
+ #b1010111)
+ count)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-unfold stop? mapper successor seed
+
+Generate a non-negative integer bit by bit, starting with bit 0. If the
+result of applying @var{stop?} to the current state (whose initial value
+is @var{seed}) is true, return the currently accumulated bits as an
+integer. Otherwise, apply @var{mapper} to the current state to obtain
+the next bit of the result by interpreting a true value as a 1 bit and a
+false value as a 0 bit. Then get a new state by applying
+@var{successor} to the current state, and repeat this algorithm.
+
+@lisp
+ (bitwise-unfold (lambda (i) (= i 10))
+ even?
+ (lambda (i) (+ i 1))
+ 0) => #b101010101
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} make-bitwise-generator i
+
+Return a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI
+121} generator that generates all the bits of @var{i} starting with bit
+#0. Note that the generator is infinite.
+
+@lisp
+ (let ((g (make-bitwise-generator #b110)))
+ (test #f (g))
+ (test #t (g))
+ (test #t (g))
+ (test #f (g)))
+@end lisp
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-151.scm b/module/srfi/srfi-151.scm
new file mode 100644
index 000000000..beb004b87
--- /dev/null
+++ b/module/srfi/srfi-151.scm
@@ -0,0 +1,56 @@
+;; Copyright (C) John Cowan (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-library (srfi srfi-151)
+ (import (scheme base))
+ (import (scheme case-lambda))
+
+ (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv
+ bitwise-nand bitwise-nor bitwise-andc1 bitwise-andc2
+ bitwise-orc1 bitwise-orc2)
+ (export arithmetic-shift bit-count integer-length bitwise-if
+ bit-set? copy-bit bit-swap any-bit-set? every-bit-set? first-set-bit)
+ (export bit-field bit-field-any? bit-field-every? bit-field-clear bit-field-set
+ bit-field-replace bit-field-replace-same
+ bit-field-rotate bit-field-reverse)
+ (export bits->list list->bits bits->vector vector->bits bits
+ bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator)
+
+ ;; Provide core functions
+ (import (only (rnrs arithmetic bitwise)
+ bitwise-not bitwise-and bitwise-ior bitwise-xor
+ bitwise-bit-count))
+ (import (rename (only (rnrs arithmetic bitwise)
+ bitwise-arithmetic-shift bitwise-length)
+ (bitwise-arithmetic-shift arithmetic-shift)
+ (bitwise-length integer-length)))
+
+ (begin
+ (define (bit-count i) ; Negative case different to R6RS bitwise-bit-count
+ (if (>= i 0)
+ (bitwise-bit-count i)
+ (bitwise-bit-count (bitwise-not i)))))
+
+ ;; Stable part of the implementation
+ (include "srfi-151/bitwise-33.scm")
+ (include "srfi-151/bitwise-60.scm")
+ (include "srfi-151/bitwise-other.scm"))
diff --git a/module/srfi/srfi-151/bitwise-33.scm b/module/srfi/srfi-151/bitwise-33.scm
new file mode 100644
index 000000000..92f8056d0
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-33.scm
@@ -0,0 +1,108 @@
+;;;; bitwise-33 - Olin Shivers's code from SRFI-33 with modified names
+
+;;; Olin Shivers is the sole author of this code, and he has placed it in
+;;; the public domain.
+;;;
+;;; A good implementation might choose to provide direct compiler/interpreter
+;;; support for these derived functions, or might simply define them to be
+;;; integrable -- i.e., inline-expanded.
+;;;
+;;; The seven non-trivial boolean functions in terms
+;;; of not, and, or & xor.
+
+(define (bitwise-nand i j) (bitwise-not (bitwise-and i j)))
+(define (bitwise-nor i j) (bitwise-not (bitwise-ior i j)))
+(define (bitwise-andc1 i j) (bitwise-and (bitwise-not i) j))
+(define (bitwise-andc2 i j) (bitwise-and i (bitwise-not j)))
+(define (bitwise-orc1 i j) (bitwise-ior (bitwise-not i) j))
+(define (bitwise-orc2 i j) (bitwise-ior i (bitwise-not j)))
+
+;;; This is a general definition, but less than efficient. It should also
+;;; receive primitive compiler/interpreter support so that the expensive
+;;; n-ary mechanism is not invoked in the standard cases -- that is,
+;;; an application of BITWISE-EQV should be rewritten into an equivalent
+;;; tree applying some two-argument primitive to the arguments, in the
+;;; same manner that statically-known n-ary applications of associative
+;;; operations such as + and * are handled efficiently:
+;;; (bitwise-eqv) => -1
+;;; (bitwise-eqv i) => i
+;;; (bitwise-eqv i j) => (%bitwise-eqv i j)
+;;; (bitwise-eqv i j k) => (%bitwise-eqv (%bitwise-eqv i j) k)
+;;; (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l)
+
+(define (bitwise-eqv . args)
+ (let lp ((args args) (ans -1))
+ (if (pair? args)
+ (lp (cdr args) (bitwise-not (bitwise-xor ans (car args))))
+ ans)))
+
+;;; Helper function -- make a mask of SIZE 1-bits, e.g. (%MASK 3) = #b111.
+;;; Suppose your Scheme's fixnums are N bits wide (counting the sign bit,
+;;; not counting any tag bits). This version, due to Marc Feeley, will
+;;; handle SIZE in the range [0,N-1] without overflowing to bignums.
+;;; (For SIZE >= N, the correct bignum value is also produced.)
+
+(define (mask start end) (bitwise-not (arithmetic-shift -1 (- end start))))
+
+;;; This alternate, mathematically-equivalent expression
+;;; (- (arithmetic-shift 1 size) 1)
+;;; is not as good -- it only handles SIZE in the range [0,N-2] without
+;;; overflowing to bignums.
+;;;
+;;; Finally, note that even Feeley's expression can't build an N-bit mask
+;;; without bignum help. This is fundamental, since the interpretation
+;;; of fixed-size fixnum bit patterns as semi-infinite-bit-strings is that
+;;; you replicate the high bit out to infinity. So you have to have a
+;;; zero "stop bit" appearing after that highest one bit to turn off the
+;;; replication of the ones.
+
+(define (bit-set? index n)
+ (not (zero? (bitwise-and (arithmetic-shift 1 index) n))))
+
+(define (any-bit-set? test-bits n) (not (zero? (bitwise-and test-bits n))))
+
+(define (every-bit-set? test-bits n) (= test-bits (bitwise-and test-bits n)))
+
+;;; Bit-field ops
+
+(define (bit-field n start end)
+ (bitwise-and (mask start end) (arithmetic-shift n (- start))))
+
+(define (bit-field-any? n start end)
+ (not (zero? (bitwise-and (arithmetic-shift n (- start)) (mask start end)))))
+
+;; Part of Olin's late revisions; code by John Cowan; public domain.
+(define (bit-field-every? n start end)
+ (let ((m (mask start end)))
+ (eqv? m (bitwise-and (arithmetic-shift n (- start)) m))))
+
+;; Integrating i-b-f reduces nicely.
+(define (bit-field-clear n start end)
+ (bit-field-replace n 0 start end))
+
+;; Counterpart to above, not in SRFI 33, written by John Cowan, public domain
+(define (bit-field-set n start end)
+ (bit-field-replace n -1 start end))
+
+;;; Oops -- intermediate ARITHMETIC-SHIFT can fixnum-overflow on fixnum args.
+;(define (bit-field-replace newfield n start end)
+; (bit-field-replace-same (arithmetic-shift newfield start) n start end))
+
+;;; This three-line version won't fixnum-overflow on fixnum args.
+(define (bit-field-replace n newfield start end)
+ (let ((m (mask start end)))
+ (bitwise-ior (bitwise-and n (bitwise-not (arithmetic-shift m start)))
+ (arithmetic-shift (bitwise-and newfield m) start))))
+
+(define (bit-field-replace-same to from start end)
+ (bitwise-if (arithmetic-shift (mask start end) start) from to))
+
+;; Simple definition
+;(define (first-set-bit i)
+; (and (not (zero? i))
+; (let lp ((j 0) (i start))
+; (if (bit-set? i 0) j
+; (lp (+ j 1) (arithmetic-shift i 1))))))
+
+;;; Clever definition, assuming you have a fast BIT-COUNT.
+(define (first-set-bit i) (- (bit-count (bitwise-xor i (- i 1))) 1))
diff --git a/module/srfi/srfi-151/bitwise-60.scm b/module/srfi/srfi-151/bitwise-60.scm
new file mode 100644
index 000000000..3f91cd632
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-60.scm
@@ -0,0 +1,70 @@
+;;;; bitwise-60 - SRFI-60 procedures without SRFI-33 analogues, renamed
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define (bit-field-rotate n count start end)
+ (define width (- end start))
+ (set! count (modulo count width))
+ (let ((mask (bitwise-not (arithmetic-shift -1 width))))
+ (define zn (bitwise-and mask (arithmetic-shift n (- start))))
+ (bitwise-ior (arithmetic-shift
+ (bitwise-ior (bitwise-and mask (arithmetic-shift zn count))
+ (arithmetic-shift zn (- count width)))
+ start)
+ (bitwise-and (bitwise-not (arithmetic-shift mask start)) n))))
+
+(define (bit-reverse k n)
+ (do ((m (if (negative? n) (bitwise-not n) n) (arithmetic-shift m -1))
+ (k (+ -1 k) (+ -1 k))
+ (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
+ ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
+
+
+(define (bit-field-reverse n start end)
+ (define width (- end start))
+ (let ((mask (bitwise-not (arithmetic-shift -1 width))))
+ (define zn (bitwise-and mask (arithmetic-shift n (- start))))
+ (bitwise-ior (arithmetic-shift (bit-reverse width zn) start)
+ (bitwise-and (bitwise-not (arithmetic-shift mask start)) n))))
+
+(define (copy-bit index to bool)
+ (if bool
+ (bitwise-ior to (arithmetic-shift 1 index))
+ (bitwise-and to (bitwise-not (arithmetic-shift 1 index)))))
+
+(define (bits->list k . len)
+ (if (null? len)
+ (do ((k k (arithmetic-shift k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((<= k 0) (reverse lst)))
+ (do ((idx (+ -1 (car len)) (+ -1 idx))
+ (k k (arithmetic-shift k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((negative? idx) (reverse lst)))))
+
+(define (list->bits bools)
+ (do ((bs (reverse bools) (cdr bs))
+ (acc 0 (+ acc acc (if (car bs) 1 0))))
+ ((null? bs) acc)))
+
+(define (bits . bools)
+ (list->bits bools))
+
+(define (bitwise-if mask n0 n1)
+ (bitwise-ior (bitwise-and mask n0)
+ (bitwise-and (bitwise-not mask) n1)))
diff --git a/module/srfi/srfi-151/bitwise-other.scm b/module/srfi/srfi-151/bitwise-other.scm
new file mode 100644
index 000000000..7f7b9b96e
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-other.scm
@@ -0,0 +1,62 @@
+;;;; bitwise-other - functions not from SRFI 33 or SRFI 60
+;;; Copyright John Cowan 2017
+
+;; 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 bits->vector
+ (case-lambda
+ ((i) (list->vector (bits->list i)))
+ ((i len) (list->vector (bits->list i len)))))
+
+(define (vector->bits vector) (list->bits (vector->list vector)))
+
+(define (bit-swap n1 n2 i)
+ (let ((n1-bit (bit-set? n1 i))
+ (n2-bit (bit-set? n2 i)))
+ (copy-bit n2 (copy-bit n1 i n2-bit) n1-bit)))
+
+(define (bitwise-fold proc seed i)
+ (let ((len (integer-length i)))
+ (let loop ((n 0) (r seed))
+ (if (= n len)
+ r
+ (loop (+ n 1) (proc (bit-set? n i) r))))))
+
+(define (bitwise-for-each proc i)
+ (let ((len (integer-length i)))
+ (let loop ((n 0))
+ (when (< n len)
+ (proc (bit-set? n i))
+ (loop (+ n 1))))))
+
+(define (bitwise-unfold stop? mapper successor seed)
+ (let loop ((n 0) (result 0) (state seed))
+ (if (stop? state)
+ result
+ (loop (+ n 1)
+ (copy-bit n result (mapper state))
+ (successor state)))))
+
+(define (make-bitwise-generator i)
+ (lambda ()
+ (let ((bit (bit-set? 0 i)))
+ (set! i (arithmetic-shift i -1))
+ bit)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 13eb1f24f..f51db8830 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -165,6 +165,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-125.test \
tests/srfi-126.test \
tests/srfi-128.test \
+ tests/srfi-151.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -214,6 +215,7 @@ EXTRA_DIST = \
tests/srfi-125-test.scm \
tests/srfi-126-test.scm \
tests/srfi-128-test.scm \
+ tests/srfi-151-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-151-test.scm b/test-suite/tests/srfi-151-test.scm
new file mode 100644
index 000000000..b5f6d32cd
--- /dev/null
+++ b/test-suite/tests/srfi-151-test.scm
@@ -0,0 +1,381 @@
+;; Copyright (C) John Cowan (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.
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library. A 'test-begin' call is added.
+(use-modules (srfi srfi-151)
+ (srfi srfi-64))
+
+(define-syntax-rule (test arg ...)
+ (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+ (test-end))
+
+(test-begin "srfi-151")
+;;; END Guile-specific modifications.
+
+(test-group "bitwise"
+ (test-group "bitwise/basic"
+ (test "test-1" -1 (bitwise-not 0))
+ (test "test-122" 0 (bitwise-not -1))
+ (test "test-248" -11 (bitwise-not 10))
+ (test "test-249" 36 (bitwise-not -37))
+ (test "test-2" 0 (bitwise-and #b0 #b1))
+ (test "test-10" 1680869008 (bitwise-and -193073517 1689392892))
+ (test "test-20" 3769478 (bitwise-and 1694076839 -4290775858))
+ (test "test-115" 6 (bitwise-and 14 6))
+ (test "test-251" 10 (bitwise-and 11 26))
+ (test "test-254" 4 (bitwise-and 37 12))
+ (test "test-288" 1 (bitwise-and #b1 #b1))
+ (test "test-289" 0 (bitwise-and #b1 #b10))
+ (test "test-290" #b10 (bitwise-and #b11 #b10))
+ (test "test-291" #b101 (bitwise-and #b101 #b111))
+ (test "test-292" #b111 (bitwise-and -1 #b111))
+ (test "test-293" #b110 (bitwise-and -2 #b111))
+ (test "test-294" 3769478 (bitwise-and -4290775858 1694076839))
+ (test "test-11" -4294967295 (bitwise-ior 1 (- -1 #xffffffff)))
+ (test "test-12" -18446744073709551615 (bitwise-ior 1 (- -1 #xffffffffffffffff)))
+ (test "test-117" 14 (bitwise-ior 10 12))
+ (test "test-250" 11 (bitwise-ior 3 10))
+ (test "test-13" -4294967126 (bitwise-xor #b10101010 (- -1 #xffffffff)))
+ (test "test-15" -18446744073709551446 (bitwise-xor #b10101010 (- -1 #xffffffffffffffff)))
+ (test "test-16" -2600468497 (bitwise-ior 1694076839 -4290775858))
+ (test "test-17" -184549633 (bitwise-ior -193073517 1689392892))
+ (test "test-18" -2604237975 (bitwise-xor 1694076839 -4290775858))
+ (test "test-19" -1865418641 (bitwise-xor -193073517 1689392892))
+ (test "test-119" 6 (bitwise-xor 10 12))
+ (test "test-252" 9 (bitwise-xor 3 10))
+ (test "test-14" (bitwise-not -4294967126) (bitwise-eqv #b10101010 (- -1 #xffffffff)))
+ (test "test-253" -42 (bitwise-eqv 37 12))
+ (test "test-27" -1 (bitwise-nand 0 0))
+ (test "test-28" -1 (bitwise-nand 0 -1))
+ (test "test-29" -124 (bitwise-nand -1 123))
+ (test "test-326" -11 (bitwise-nand 11 26))
+ (test "test-327" -28 (bitwise-nor 11 26))
+ (test "test-317" 0 (bitwise-nor -1 123))
+ (test "test-328" 16 (bitwise-andc1 11 26))
+ (test "test-329" 1 (bitwise-andc2 11 26))
+ (test "test-330" -2 (bitwise-orc1 11 26))
+ (test "test-30" -1 (bitwise-nor 0 0))
+ (test "test-31" 0 (bitwise-nor 0 -1))
+ (test "test-22" 0 (bitwise-andc1 0 0))
+ (test "test-23" -1 (bitwise-andc1 0 -1))
+ (test "test-24" 123 (bitwise-andc1 0 123))
+ (test "test-25" 0 (bitwise-andc2 0 0))
+ (test "test-26" -1 (bitwise-andc2 -1 0))
+ (test "test-318" -1 (bitwise-orc1 0 0))
+ (test "test-319" -1 (bitwise-orc1 0 -1))
+ (test "test-320" 0 (bitwise-orc1 -1 0))
+ (test "test-321" -124 (bitwise-orc1 123 0))
+ (test "test-322" -1 (bitwise-orc2 0 0))
+ (test "test-323" -1 (bitwise-orc2 -1 0))
+ (test "test-324" 0 (bitwise-orc2 0 -1))
+ (test "test-325" -124 (bitwise-orc2 0 123))
+ )
+ (test-group "bitwise/integer"
+ (test "test-78" #x1000000000000000100000000000000000000000000000000
+ (arithmetic-shift #x100000000000000010000000000000000 64))
+ (test "test-79" #x8e73b0f7da0e6452c810f32b809079e5
+ (arithmetic-shift #x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b -64))
+ (test "test-196" 2 (arithmetic-shift 1 1))
+ (test "test-197" 0 (arithmetic-shift 1 -1))
+ (test "test-331" 1 (arithmetic-shift 1 0))
+ (test "test-333" 4 (arithmetic-shift 1 2))
+ (test "test-334" 8 (arithmetic-shift 1 3))
+ (test "test-335" 16 (arithmetic-shift 1 4))
+ (test "test-336" (expt 2 31) (arithmetic-shift 1 31))
+ (test "test-337" (expt 2 32) (arithmetic-shift 1 32))
+ (test "test-338" (expt 2 33) (arithmetic-shift 1 33))
+ (test "test-339" (expt 2 63) (arithmetic-shift 1 63))
+ (test "test-340" (expt 2 64) (arithmetic-shift 1 64))
+ (test "test-341" (expt 2 65) (arithmetic-shift 1 65))
+ (test "test-342" (expt 2 127) (arithmetic-shift 1 127))
+ (test "test-343" (expt 2 128) (arithmetic-shift 1 128))
+ (test "test-344" (expt 2 129) (arithmetic-shift 1 129))
+ (test "test-345" 3028397001194014464 (arithmetic-shift 11829675785914119 8))
+ (test "test-346" -1 (arithmetic-shift -1 0))
+ (test "test-347" -2 (arithmetic-shift -1 1))
+ (test "test-348" -4 (arithmetic-shift -1 2))
+ (test "test-349" -8 (arithmetic-shift -1 3))
+ (test "test-350" -16 (arithmetic-shift -1 4))
+ (test "test-351" (- (expt 2 31)) (arithmetic-shift -1 31))
+ (test "test-352" (- (expt 2 32)) (arithmetic-shift -1 32))
+ (test "test-353" (- (expt 2 33)) (arithmetic-shift -1 33))
+ (test "test-354" (- (expt 2 63)) (arithmetic-shift -1 63))
+ (test "test-355" (- (expt 2 64)) (arithmetic-shift -1 64))
+ (test "test-356" (- (expt 2 65)) (arithmetic-shift -1 65))
+ (test "test-357" (- (expt 2 127)) (arithmetic-shift -1 127))
+ (test "test-358" (- (expt 2 128)) (arithmetic-shift -1 128))
+ (test "test-359" (- (expt 2 129)) (arithmetic-shift -1 129))
+ (test "test-360" 0 (arithmetic-shift 1 -63))
+ (test "test-361" 0 (arithmetic-shift 1 -64))
+ (test "test-362" 0 (arithmetic-shift 1 -65))
+ (test "test-255" 32 (arithmetic-shift 8 2))
+ (test "test-256" 4 (arithmetic-shift 4 0))
+ (test "test-257" 4 (arithmetic-shift 8 -1))
+ (test "test-258" -79 (arithmetic-shift -100000000000000000000000000000000 -100))
+ (test "test-135" 2 (bit-count 12))
+ (test "test-263" 0 (integer-length 0))
+ (test "test-264" 1 (integer-length 1))
+ (test "test-265" 0 (integer-length -1))
+ (test "test-266" 3 (integer-length 7))
+ (test "test-267" 3 (integer-length -7))
+ (test "test-268" 4 (integer-length 8))
+ (test "test-269" 3 (integer-length -8))
+ (test "test-125" 9 (bitwise-if 3 1 8))
+ (test "test-126" 0 (bitwise-if 3 8 1))
+ (test "test-373" 3 (bitwise-if 1 1 2))
+ (test "test-378" #b00110011 (bitwise-if #b00111100 #b11110000 #b00001111))
+ )
+ (test-group "bitwise/single"
+ (test "test-160" #t (bit-set? 0 1))
+ (test "test-161" #f (bit-set? 1 1))
+ (test "test-162" #f (bit-set? 1 8))
+ (test "test-163" #t (bit-set? 10000 -1))
+ (test "test-167" #t (bit-set? 1000 -1))
+ (test "test-541" #t (bit-set? 64 #x10000000000000000))
+ (test "test-542" #f (bit-set? 64 1))
+ (test "test-272" #t (bit-set? 3 10))
+ (test "test-273" #t (bit-set? 2 6))
+ (test "test-274" #f (bit-set? 0 6))
+ (test "test-168" 0 (copy-bit 0 0 #f))
+ (test "test-169" 0 (copy-bit 30 0 #f))
+ (test "test-170" 0 (copy-bit 31 0 #f))
+ (test "test-171" 0 (copy-bit 62 0 #f))
+ (test "test-172" 0 (copy-bit 63 0 #f))
+ (test "test-173" 0 (copy-bit 128 0 #f))
+ (test "test-174" -1 (copy-bit 0 -1 #t))
+ (test "test-175" -1 (copy-bit 30 -1 #t))
+ (test "test-176" -1 (copy-bit 31 -1 #t))
+ (test "test-177" -1 (copy-bit 62 -1 #t))
+ (test "test-178" -1 (copy-bit 63 -1 #t))
+ (test "test-179" -1 (copy-bit 128 -1 #t))
+ (test "test-180" 1 (copy-bit 0 0 #t))
+ (test "test-181" #x106 (copy-bit 8 6 #t))
+ (test "test-182" 6 (copy-bit 8 6 #f))
+ (test "test-183" -2 (copy-bit 0 -1 #f))
+ (test "test-184" 0 (copy-bit 128 #x100000000000000000000000000000000 #f))
+ (test "test-185" #x100000000000000000000000000000000
+ (copy-bit 128 #x100000000000000000000000000000000 #t))
+ (test "test-186" #x100000000000000000000000000000000
+ (copy-bit 64 #x100000000000000000000000000000000 #f))
+ (test "test-187" #x-100000000000000000000000000000000
+ (copy-bit 64 #x-100000000000000000000000000000000 #f))
+ (test "test-188" #x-100000000000000000000000000000000
+ (copy-bit 256 #x-100000000000000000000000000000000 #t))
+ (test "test-276" #b100 (copy-bit 2 0 #t))
+ (test "test-277" #b1011 (copy-bit 2 #b1111 #f))
+ (test "test-379" #b1 (copy-bit 0 0 #t))
+ (test "test-100" #b1011 (bit-swap 1 2 #b1101))
+ (test "test-101" #b1011 (bit-swap 2 1 #b1101))
+ (test "test-382" #b1110 (bit-swap 0 1 #b1101))
+ (test "test-102" #b10000000101 (bit-swap 3 10 #b1101))
+ (test "test-278" 1 (bit-swap 0 2 4))
+ (test "test-129" #t (any-bit-set? 3 6))
+ (test "test-130" #f (any-bit-set? 3 12))
+ (test "test-133" #t (every-bit-set? 4 6))
+ (test "test-134" #f (every-bit-set? 7 6))
+ (test "test-141" -1 (first-set-bit 0))
+ (test "test-142" 0 (first-set-bit 1))
+ (test "test-143" 0 (first-set-bit 3))
+ (test "test-144" 2 (first-set-bit 4))
+ (test "test-145" 1 (first-set-bit 6))
+ (test "test-146" 0 (first-set-bit -1))
+ (test "test-147" 1 (first-set-bit -2))
+ (test "test-148" 0 (first-set-bit -3))
+ (test "test-149" 2 (first-set-bit -4))
+ (test "test-150" 128 (first-set-bit #x100000000000000000000000000000000))
+ (test "test-280" 1 (first-set-bit 2))
+ (test "test-282" 3 (first-set-bit 40))
+ (test "test-283" 2 (first-set-bit -28))
+ (test "test-284" 99 (first-set-bit (expt 2 99)))
+ (test "test-285" 99 (first-set-bit (expt -2 99)))
+ )
+ (test-group "bitwise/field"
+ (test "test-189" 0 (bit-field 6 0 1))
+ (test "test-190" 3 (bit-field 6 1 3))
+ (test "test-191" 1 (bit-field 6 2 999))
+ (test "test-192" 1 (bit-field #x100000000000000000000000000000000 128 129))
+ (test "test-363" #b1010 (bit-field #b1101101010 0 4))
+ (test "test-364" #b101101 (bit-field #b1101101010 3 9))
+ (test "test-365" #b10110 (bit-field #b1101101010 4 9))
+ (test "test-366" #b110110 (bit-field #b1101101010 4 10))
+ (test "test-367" #t (bit-field-any? #b101101 0 2))
+ (test "test-368" #t (bit-field-any? #b101101 2 4))
+ (test "test-369" #f (bit-field-any? #b101101 1 2))
+ (test "test-370" #f (bit-field-every? #b101101 0 2))
+ (test "test-371" #t (bit-field-every? #b101101 2 4))
+ (test "test-372" #t (bit-field-every? #b101101 0 1))
+ (test "test-374" #b100000 (bit-field-clear #b101010 1 4))
+ (test "test-375" #b101110 (bit-field-set #b101010 1 4))
+ (test "test-193" #b111 (bit-field-replace #b110 1 0 1))
+ (test "test-194" #b110 (bit-field-replace #b110 1 1 2))
+ (test "test-195" #b010 (bit-field-replace #b110 1 1 3))
+ (test "test-376" #b100100 (bit-field-replace #b101010 #b010 1 4))
+ (test "test-377" #b1001 (bit-field-replace-same #b1111 #b0000 1 3))
+ (test "test-200" #b110 (bit-field-rotate #b110 1 1 2))
+ (test "test-201" #b1010 (bit-field-rotate #b110 1 2 4))
+ (test "test-202" #b1011 (bit-field-rotate #b0111 -1 1 4))
+ (test "test-203" #b0 (bit-field-rotate #b0 128 0 256))
+ (test "test-204" #b1 (bit-field-rotate #b1 128 1 256))
+ (test "test-205" #x100000000000000000000000000000000
+ (bit-field-rotate #x100000000000000000000000000000000 128 0 64))
+ (test "test-206" #x100000000000000000000000000000008
+ (bit-field-rotate #x100000000000000000000000000000001 3 0 64))
+ (test "test-207" #x100000000000000002000000000000000
+ (bit-field-rotate #x100000000000000000000000000000001 -3 0 64))
+ (test "test-208" #b110 (bit-field-rotate #b110 0 0 10))
+ (test "test-209" #b110 (bit-field-rotate #b110 0 0 256))
+ (test "test-475" 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129))
+ (test "test-211" 6 (bit-field-reverse 6 1 3))
+ (test "test-212" 12 (bit-field-reverse 6 1 4))
+ (test "test-213" #x80000000 (bit-field-reverse 1 0 32))
+ (test "test-214" #x40000000 (bit-field-reverse 1 0 31))
+ (test "test-215" #x20000000 (bit-field-reverse 1 0 30))
+ (test "test-216" (bitwise-ior (arithmetic-shift -1 32) #xFBFFFFFF)
+ (bit-field-reverse -2 0 27))
+ (test "test-217" (bitwise-ior (arithmetic-shift -1 32) #xF7FFFFFF)
+ (bit-field-reverse -2 0 28))
+ (test "test-218" (bitwise-ior (arithmetic-shift -1 32) #xEFFFFFFF)
+ (bit-field-reverse -2 0 29))
+ (test "test-219" (bitwise-ior (arithmetic-shift -1 32) #xDFFFFFFF)
+ (bit-field-reverse -2 0 30))
+ (test "test-220" (bitwise-ior (arithmetic-shift -1 32) #xBFFFFFFF)
+ (bit-field-reverse -2 0 31))
+ (test "test-221" (bitwise-ior (arithmetic-shift -1 32) #x7FFFFFFF)
+ (bit-field-reverse -2 0 32))
+ (test "test-222" 5 (bit-field-reverse #x140000000000000000000000000000000 0 129))
+ )
+ (test-group "bitwise/conversion"
+ (test "test-103" '(#t #f #t #f #t #t #t) (bits->list #b1110101))
+ (test "test-104" '(#f #t #f #t) (bits->list #b111010 4))
+ (test "test-106" #b1110101 (list->bits '(#t #f #t #f #t #t #t)))
+ (test "test-107" #b111010100 (list->bits '(#f #f #t #f #t #f #t #t #t)))
+ (test "test-223" '(#t #t) (bits->list 3))
+ (test "test-224" '(#f #t #t #f) (bits->list 6 4))
+ (test "test-225" '(#f #t) (bits->list 6 2))
+ (test "test-226" '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
+ (bits->list 1 128))
+ (test "test-228" '(#f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
+ (bits->list #x100000000000000000000000000000000))
+ (test "test-229" 6 (list->bits '(#f #t #t)))
+ (test "test-230" 12 (list->bits '(#f #f #t #t)))
+ (test "test-231" 6 (list->bits '(#f #t #t #f)))
+ (test "test-232" 2 (list->bits '(#f #t)))
+ (test "test-233" 1 (list->bits
+ '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)))
+ (test "test-234" #x100000000000000000000000000000000
+ (list->bits
+ '(#f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)))
+ (test "test-235" #x03FFFFFF (list->bits '(#t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-236" #x07FFFFFF (list->bits '(#t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-237" #x0FFFFFFF (list->bits '(#t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-238" #x1FFFFFFF (list->bits '(#t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-239" #x3FFFFFFF (list->bits '(#t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-240" #x7FFFFFFF (list->bits '(#t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-241" #xFFFFFFFF (list->bits '(#t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-242" #x1FFFFFFFF (list->bits '(#t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-490" 1 (list->bits '(#t #f)))
+ (test "test-108" #b1110101 (vector->bits '#(#t #f #t #f #t #t #t)))
+ (test "test-109" #b00011010100 (vector->bits '#(#f #f #t #f #t #f #t #t)))
+ (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))
+ (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))
+ (test "test-110" #b1110101 (bits #t #f #t #f #t #t #t))
+ (test "test-243" 0 (bits))
+ (test "test-111" #b111010100 (bits #f #f #t #f #t #f #t #t #t))
+ )
+ (test-group "bitwise/fold"
+ (test "test-112" '(#t #f #t #f #t #t #t) (bitwise-fold cons '() #b1010111))
+ (test "test-113" 5
+ (let ((count 0))
+ (bitwise-for-each (lambda (b) (if b (set! count (+ count 1))))
+ #b1010111)
+ count))
+ (test "test-114" #b101010101
+ (bitwise-unfold (lambda (i) (= i 10)) even? (lambda (i) (+ i 1)) 0))
+ (let ((g (make-bitwise-generator #b110)))
+ (test "test-244a" #f (g))
+ (test "test-244b" #t (g))
+ (test "test-244c" #t (g))
+ (test "test-244d" #f (g)))
+ )
+)
+(test-exit)
diff --git a/test-suite/tests/srfi-151.test b/test-suite/tests/srfi-151.test
new file mode 100644
index 000000000..6c535b39e
--- /dev/null
+++ b/test-suite/tests/srfi-151.test
@@ -0,0 +1,46 @@
+;;;; srfi-151.test --- Test suite for SRFI-151. -*- 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-151)
+ #:use-module (srfi srfi-64))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-151-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 6+ messages in thread
end of thread, other threads:[~2023-11-18 6:05 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-11-18 6:05 [PATCH v3 1/6] module: Add srfi-126 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 2/6] tests: Add new compile-file tests Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 3/6] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 4/6] module: Add srfi-128 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 5/6] module: Add srfi-125 Maxim Cournoyer
2023-11-18 6:05 ` [PATCH v3 6/6] module: Add srfi-151 Maxim Cournoyer
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).