From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v7 15/16] module: Add SRFI 178.
Date: Mon, 4 Dec 2023 16:45:20 -0500 [thread overview]
Message-ID: <20231204215143.3146-16-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231204215143.3146-1-maxim.cournoyer@gmail.com>
* module/srfi/srfi-178.sld: New file.
* am/bootstrap.am (SOURCES): Register it.
* module/srfi/srfi-178/convert.scm
* module/srfi/srfi-178/fields.scm
* module/srfi/srfi-178/gen-acc.scm
* module/srfi/srfi-178/logic-ops.scm
* module/srfi/srfi-178/macros.scm
* module/srfi/srfi-178/map2list.scm
* module/srfi/srfi-178/quasi-ints.scm
* module/srfi/srfi-178/quasi-strs.scm
* module/srfi/srfi-178/unfolds.scm
* module/srfi/srfi-178/wrappers.scm: New module implementation files.
* am/bootstrap.am (NOCOMP_SOURCES): Register them.
* test-suite/tests/srfi-178.test: New test.
* test-suite/Makefile.am (SCM_TESTS): Register it.
* test-suite/tests/srfi-178-test/constructors.scm
* test-suite/tests/srfi-178-test/conversions.scm
* test-suite/tests/srfi-178-test/fields.scm
* test-suite/tests/srfi-178-test/gen-accum.scm
* test-suite/tests/srfi-178-test/iterators.scm
* test-suite/tests/srfi-178-test/logic-ops.scm
* test-suite/tests/srfi-178-test/mutators.scm
* test-suite/tests/srfi-178-test/quasi-ints.scm
* test-suite/tests/srfi-178-test/quasi-string.scm
* test-suite/tests/srfi-178-test/selectors.scm: New test implementation
files.
* test-suite/Makefile.am (EXTRA_DIST): Register them.
* doc/ref/srfi-modules.texi (SRFI 178): New subsection.
* NEWS: Update news.
---
Changes in v7:
- Register prerequisites for srfi/srfi-160/*.go in am/bootstrap.am
NEWS | 1 +
am/bootstrap.am | 12 +
doc/ref/guile.texi | 4 +-
doc/ref/srfi-modules.texi | 604 ++++++++++++++++++
module/srfi/srfi-178.sld | 105 +++
module/srfi/srfi-178/convert.scm | 83 +++
module/srfi/srfi-178/fields.scm | 88 +++
module/srfi/srfi-178/gen-acc.scm | 25 +
module/srfi/srfi-178/logic-ops.scm | 105 +++
module/srfi/srfi-178/macros.scm | 26 +
module/srfi/srfi-178/map2list.scm | 27 +
module/srfi/srfi-178/quasi-ints.scm | 54 ++
module/srfi/srfi-178/quasi-strs.scm | 88 +++
module/srfi/srfi-178/unfolds.scm | 44 ++
module/srfi/srfi-178/wrappers.scm | 285 +++++++++
test-suite/Makefile.am | 11 +
.../tests/srfi-178-test/constructors.scm | 88 +++
.../tests/srfi-178-test/conversions.scm | 108 ++++
test-suite/tests/srfi-178-test/fields.scm | 98 +++
test-suite/tests/srfi-178-test/gen-accum.scm | 72 +++
test-suite/tests/srfi-178-test/iterators.scm | 150 +++++
test-suite/tests/srfi-178-test/logic-ops.scm | 125 ++++
test-suite/tests/srfi-178-test/mutators.scm | 79 +++
test-suite/tests/srfi-178-test/quasi-ints.scm | 41 ++
.../tests/srfi-178-test/quasi-string.scm | 62 ++
test-suite/tests/srfi-178-test/selectors.scm | 13 +
test-suite/tests/srfi-178.test | 147 +++++
27 files changed, 2543 insertions(+), 2 deletions(-)
create mode 100644 module/srfi/srfi-178.sld
create mode 100644 module/srfi/srfi-178/convert.scm
create mode 100644 module/srfi/srfi-178/fields.scm
create mode 100644 module/srfi/srfi-178/gen-acc.scm
create mode 100644 module/srfi/srfi-178/logic-ops.scm
create mode 100644 module/srfi/srfi-178/macros.scm
create mode 100644 module/srfi/srfi-178/map2list.scm
create mode 100644 module/srfi/srfi-178/quasi-ints.scm
create mode 100644 module/srfi/srfi-178/quasi-strs.scm
create mode 100644 module/srfi/srfi-178/unfolds.scm
create mode 100644 module/srfi/srfi-178/wrappers.scm
create mode 100644 test-suite/tests/srfi-178-test/constructors.scm
create mode 100644 test-suite/tests/srfi-178-test/conversions.scm
create mode 100644 test-suite/tests/srfi-178-test/fields.scm
create mode 100644 test-suite/tests/srfi-178-test/gen-accum.scm
create mode 100644 test-suite/tests/srfi-178-test/iterators.scm
create mode 100644 test-suite/tests/srfi-178-test/logic-ops.scm
create mode 100644 test-suite/tests/srfi-178-test/mutators.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-ints.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-string.scm
create mode 100644 test-suite/tests/srfi-178-test/selectors.scm
create mode 100644 test-suite/tests/srfi-178.test
diff --git a/NEWS b/NEWS
index c36b55643..b1a21c59b 100644
--- a/NEWS
+++ b/NEWS
@@ -28,6 +28,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 125), a mutators library
** Add (srfi 151), a bitwise operations library
** Add (srfi 160), an homogeneous numeric vector library
+** Add (srfi 178), a bitvector library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 0a27432f9..acbf17f0b 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -74,6 +74,7 @@ srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \
srfi/srfi-160/s64.go srfi/srfi-160/s8.go srfi/srfi-160/u16.go \
srfi/srfi-160/u32.go srfi/srfi-160/u64.go \
srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go
+srfi/srfi-178.go: srfi/srfi-151.go srfi/srfi-160/u8.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -384,6 +385,7 @@ SOURCES = \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
+ srfi/srfi-178.sld \
\
statprof.scm \
\
@@ -505,6 +507,16 @@ NOCOMP_SOURCES = \
srfi/srfi-160/u16-impl.scm \
srfi/srfi-160/u32-impl.scm \
srfi/srfi-160/u64-impl.scm \
+ srfi/srfi-178/macros.scm \
+ srfi/srfi-178/convert.scm \
+ srfi/srfi-178/fields.scm \
+ srfi/srfi-178/gen-acc.scm \
+ srfi/srfi-178/logic-ops.scm \
+ srfi/srfi-178/map2list.scm \
+ srfi/srfi-178/quasi-ints.scm \
+ srfi/srfi-178/quasi-strs.scm \
+ srfi/srfi-178/unfolds.scm \
+ srfi/srfi-178/wrappers.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 3226ee53b..22d234b1b 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,8 +24,8 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-Additionally, the documentation of the 125, 126, 128, 151 and 160 SRFI
-modules is adapted from their specification text, which is made
+Additionally, the documentation of the 125, 126, 128, 151, 160 and 178
+SRFI modules is adapted from their specification text, which is made
available under the following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 23e030b99..216a4e045 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -72,6 +72,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 151:: Bitwise Operations.
* SRFI 160:: Homogeneous numeric vectors.
* SRFI-171:: Transducers.
+* SRFI 178:: Bitvectors.
@end menu
@@ -9362,6 +9363,609 @@ The generator version of list-reduce. It reduces over @code{gen} until
it returns the EOF object
@end deffn
+@node SRFI 178
+@subsection SRFI 178: Bitvector library
+@cindex SRFI 178
+
+@menu
+* SRFI 178 Abstract::
+* SRFI 178 Rationale::
+* SRFI 178 Notation::
+* SRFI 178 Bit conversion::
+* SRFI 178 Constructors::
+* SRFI 178 Predicates::
+* SRFI 178 Selectors::
+* SRFI 178 Iteration::
+* SRFI 178 Prefixes suffixes trimming padding::
+* SRFI 178 Mutators::
+* SRFI 178 Conversion::
+* SRFI 178 Generators::
+* SRFI 178 Basic operations::
+* SRFI 178 Quasi-integer operations::
+* SRFI 178 Bit field operations::
+* SRFI 178 Bitvector literals::
+@end menu
+
+@node SRFI 178 Abstract
+@subsubsection SRFI 178 Abstract
+
+This SRFI describes a set of operations on homogeneous bitvectors.
+Operations analogous to those provided on the other homogeneous vector
+types described in
+@url{https://srfi.schemers.org/srfi-160/srfi-160.html, SRFI 160} are
+provided, along with operations analogous to the bitwise operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}.
+
+@node SRFI 178 Rationale
+@subsubsection SRFI 178 Rationale
+
+Bitvectors were excluded from the final draft of SRFI 160 because they
+are the only type of homogeneous numeric vectors for which bitwise
+operations make sense. In addition, there are two ways to view them: as
+vectors of exact integers limited to the values 0 and 1, and as vectors
+of booleans. This SRFI is designed to allow bitvectors to be viewed in
+either way.
+
+@node SRFI 178 Notation
+@subsubsection SRFI 178 Notation
+
+Bitvectors are disjoint from all other Scheme types with the possible
+exception of u1vectors, if the Scheme implementation supports them.
+
+The procedures of this SRFI that accept single bits or lists of bits can
+be passed any of the values 0, 1, #f, #t. Procedures that return a bit
+or a list of bits come in two flavors: one ending in @samp{/int} that
+returns an exact integer, and one ending in @samp{/bool} that returns a
+boolean.
+
+Mapping and folding procedures also come in two flavors: those ending in
+@samp{/int} pass exact integers to their procedure arguments, whereas
+those ending in @samp{/bool} pass booleans to theirs.
+
+Procedures whose names end in @samp{!} are the same as the corresponding
+procedures without @samp{!}, except that the first bitvector argument is
+mutated and an unspecified result is returned. Consequently, only the
+non-@samp{!} version is documented below.
+
+It is an error unless all bitvector arguments passed to procedures that
+accept more than one are of the same length (except as otherwise noted).
+
+In the section containing specifications of procedures, the following
+notation is used to specify parameters and return values:
+
+@table @asis
+@item (@var{f} @var{arg@sub{1}} @var{arg@sub{2}} @dots{}) -> something
+A procedure @var{f} that takes the parameters @var{arg@sub{1}}
+@var{arg@sub{2}} @dots{} and returns a value of the type
+@code{something}. If two values are returned, two types are specified.
+If @code{something} is @code{unspecified}, then @var{f} returns a single
+implementation-dependent value; this SRFI does not specify what it
+returns, and in order to write portable code, the return value should be
+ignored.
+
+@item @var{vec}
+An heterogeneous vector; that is, it must satisfy the predicate
+@code{vector?}.
+
+@item @var{bvec}, @var{to}, @var{from}
+A bitvector, i.e., it must satisfy the predicate @code{bitvector?}. In
+@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{to} is the
+destination and @var{from} is the source.
+
+@item @var{i}, @var{j}, @var{start}, @var{at}
+An exact nonnegative integer less than the length of the bitvector. In
+@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{at} refers
+to the destination and @var{start} to the source.
+
+@item @var{end}
+An exact nonnegative integer not less than @var{start}. This indicates
+the index directly before which traversal will stop --- processing will
+occur until the index of the vector is one less than @var{end}. It is
+the open right side of a range.
+
+@item @var{f}
+A procedure taking one or more arguments, which returns (except as noted
+otherwise) exactly one value.
+
+@item @var{=}
+An equivalence procedure.
+
+@item @var{obj}, @var{seed}, @var{knil}
+Any Scheme object.
+
+@item @var{[something]}
+An optional argument; it needn't necessarily be applied.
+@var{something} needn't necessarily be one thing; for example, this
+usage of it is perfectly valid:
+
+@example
+[@var{start} [@var{end}]]
+@end example
+
+@noindent
+and is indeed used quite often.
+
+@item @var{something} @dots{}
+Zero or more @var{something}s are allowed to be arguments.
+
+@item @var{something@sub{1}} @var{something@sub{2}} @dots{}
+One or more @var{something}s must be arguments.
+@end table
+
+All procedures that return bitvectors, vectors, or lists newly allocate
+their results, except those that end in @samp{!}. However, a
+zero-length value need not be separately allocated.
+
+Except as otherwise noted, the semantics of each procedure are those of
+the corresponding SRFI 133 or SRFI 151 procedure.
+
+@node SRFI 178 Bit conversion
+@subsubsection SRFI 178 Bit conversion
+
+@deffn {Scheme Procedure} bit->integer bit -> exact integer
+
+Returns 0 if @var{bit} is 0 or @code{#f} and 1 if @var{bit} is 1 or
+@code{#t}.
+@end deffn
+
+@deffn {Scheme Procedure} bit->boolean bit -> boolean
+
+Returns @code{#f} if @var{bit} is 0 or @code{#f} and @code{#t} if
+@var{bit} is 1 or @code{#t}.
+@end deffn
+
+@node SRFI 178 Constructors
+@subsubsection SRFI 178 Constructors
+
+@deffn {Scheme Procedure} make-bitvector size [bit] -> bitvector
+
+Returns a bitvector whose length is @var{size}. If @var{bit} is provided,
+all the elements of the bitvector are initialized to it.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector value @dots{} -> bitvector
+
+Returns a bitvector initialized with @var{values}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-unfold f length seed @dots{} -> bitvector
+
+Creates a vector whose length is @var{length} and iterates across each
+index @var{k} between 0 and @var{length}, applying @var{f} at each
+iteration to the current index and current states, in that order, to
+receive @var{n} + 1 values: the bit to put in the @var{k}th slot of the
+new vector and new states for the next iteration. On the first call to
+@var{f}, the states' values are the @var{seeds}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-unfold-right f length seed -> bitvector
+
+The same as @code{bitvector-unfold}, but initializes the bitvector from
+right to left.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-copy bvec [start [end]] -> bitvector
+
+Makes a copy of the portion of @var{bvec} from @var{start} to @var{end} and
+returns it.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-reverse-copy bvec [start [end]] -> bitvector
+
+The same as @code{bitvector-copy}, but in reverse order.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-append bvec @dots{} -> bitvector
+
+Returns a bitvector containing all the elements of the @var{bvecs} in
+order.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-concatenate list-of-bitvectors -> bitvector
+
+The same as @code{bitvector-append}, but takes a list of bitvectors
+rather than multiple arguments.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-append-subbitvectors [bvec start end] @dots{} -> bitvector
+
+Concatenates the result of applying @code{bitvector-copy} to each
+triplet of @var{bvec}, @var{start}, @var{end} arguments.
+@end deffn
+
+@node SRFI 178 Predicates
+@subsubsection SRFI 178 Predicates
+
+@deffn {Scheme Procedure} bitvector? obj -> boolean
+
+Returns @code{#t} if @var{obj} is a bitvector, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-empty? bvec -> boolean
+
+Returns @code{#t} if @var{bvec} has a length of zero, and @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector=? bvec @dots{} -> boolean
+
+Compares the @var{bvecs} for element-wise equality, using @code{eqv?} to
+do the comparisons, and returns @code{#t} or @code{#f} accordingly.
+@end deffn
+
+@node SRFI 178 Selectors
+@subsubsection SRFI 178 Selectors
+
+@deffn {Scheme Procedure} bitvector-ref/int bvec i -> integer
+@deffnx {Scheme Procedure} bitvector-ref/bool bvec i -> boolean
+
+Returns the @var{i}th element of @var{bvec} as an exact integer or
+boolean, respectively.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-length bvec -> exact nonnegative integer
+
+Returns the length of @var{bvec}.
+@end deffn
+
+@node SRFI 178 Iteration
+@subsubsection SRFI 178 Iteration
+
+@deffn {Scheme Procedure} bitvector-take bvec n -> bitvector
+@deffnx {Scheme Procedure} bitvector-take-right bvec n -> bitvector
+
+Returns a bitvector containing the first/last @var{n} elements of
+@var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-drop bvec n -> bitvector
+@deffnx {Scheme Procedure} bitvector-drop-right bvec n -> bitvector
+
+Returns a bitvector containing all except the first/last @var{n}
+elements of @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-segment bvec n -> list
+
+Returns a list of bitvectors, each of which contains @var{n} consecutive
+elements of @var{bvec}. The last bitvector may be shorter than @var{n}.
+It is an error if @var{n} is not an exact positive integer.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-fold/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold-right/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold-right/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+
+Folds @var{kons} over the elements of @var{bvec} in
+increasing/decreasing order using @var{knil} as the initial value. The
+kons procedure is called with the states first and the new element last,
+as in SRFIs 43, 133, and 160.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-map/int f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector
+@deffnx {Scheme Procedure} bitvector-map/bool f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector
+@deffnx {Scheme Procedure} bitvector-map!/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-map!/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-map- > list/int f bvec@sub{1} bvec@sub{2} @dots{} -> list
+@deffnx {Scheme Procedure} bitvector-map- > list/bool f bvec@sub{1} bvec@sub{2} @dots{} -> list
+@deffnx {Scheme Procedure} bitvector-for-each/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-for-each/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+
+Iterate over the corresponding elements of the @var{bvecs} and apply
+@var{f} to each, returning respectively: a bitvector of the results, an
+undefined value with the results placed back in @var{bvec1}, a list of
+the results, and an undefined value with no change to @var{bvec1}.
+@end deffn
+
+@node SRFI 178 Prefixes suffixes trimming padding
+@subsubsection SRFI 178 Prefixes, suffixes, trimming, padding
+
+@deffn {Scheme Procedure} bitvector-prefix-length bvec1 bvec2 -> index
+@deffnx {Scheme Procedure} bitvector-suffix-length bvec1 bvec2 -> index
+
+Return the number of elements that are equal in the prefix/suffix
+of the two @i{bvecs}, which are allowed to be of different lengths.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-prefix? bvec1 bvec2 -> boolean
+@deffnx {Scheme Procedure} bitvector-suffix? bvec1 bvec2 -> boolean
+
+Returns @code{#t} if @var{bvec1} is a prefix/suffix of @var{bvec2}, and
+@code{#f} otherwise. The arguments are allowed to be of different
+lengths.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-pad bit bvec length -> bvec
+@deffnx {Scheme Procedure} bitvector-pad-right bit bvec length -> bvec
+
+Returns a copy of @var{bvec} with leading/trailing elements equal to
+@var{bit} added (if necessary) so that the length of the result is
+@var{length}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-trim bit bvec -> bvec
+@deffnx {Scheme Procedure} bitvector-trim-right bit bvec -> bvec
+@deffnx {Scheme Procedure} bitvector-trim-both bit bvec -> bvec
+
+Returns a copy of @var{bvec} with leading/trailing/both elements equal to
+@var{bit} removed.
+@end deffn
+
+@node SRFI 178 Mutators
+@subsubsection SRFI 178 Mutators
+
+@deffn {Scheme Procedure} bitvector-set! bvec i bit -> unspecified
+
+Sets the @var{i}th element of @var{bvec} to @var{bit}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-swap! bvec i j -> unspecified
+
+Interchanges the @var{i}th and @var{j}th elements of @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-reverse! bvec [start [end]] -> unspecified
+
+Reverses the portion of @var{bvec} from @var{start} to @var{end}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-copy! to at from [start [end]] -> unspecified
+
+Copies the portion of @var{from} from @var{start} to @var{end} onto
+@var{to}, starting at index @var{at}.
+@end deffn
+
+
+@deffn {Scheme Procedure} bitvector-reverse-copy! to at from [start [end]] -> unspecified
+
+The same as @code{bitvector-copy!}, but copies in reverse.
+@end deffn
+
+@node SRFI 178 Conversion
+@subsubsection SRFI 178 Conversion
+
+@deffn {Scheme Procedure} bitvector->list/int bvec [start [end]] -> list of integers
+@deffnx {Scheme Procedure} bitvector->list/bool bvec [start [end]] -> list of booleans
+@deffnx {Scheme Procedure} reverse-bitvector->list/int bvec [start [end]] -> list of integers
+@deffnx {Scheme Procedure} reverse-bitvector->list/bool bvec [start [end]] -> list of booleans
+@deffnx {Scheme Procedure} list->bitvector list -> bitvector
+@deffnx {Scheme Procedure} reverse-list->bitvector list -> bitvector
+@deffnx {Scheme Procedure} bitvector->vector/int bvec [start [end]] -> vector of integers
+@deffnx {Scheme Procedure} bitvector->vector/bool bvec [start [end]] -> vector of booleans
+@deffnx {Scheme Procedure} reverse-bitvector->vector/int bvec [start [end]] -> vector of integers
+@deffnx {Scheme Procedure} reverse-bitvector->vector/bool bvec [start [end]] -> vector of booleans
+@deffnx {Scheme Procedure} vector->bitvector vec [start [end]] -> bitvector
+@deffnx {Scheme Procedure} reverse-vector->bitvector vec [start [end]] -> bitvector
+
+Returns a list, bitvector, or heterogeneous vector with the same
+elements as the argument, in reverse order where specified.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector->string bvec -> string
+
+Returns a string beginning with @samp{"#*"} and followed by the values
+of @var{bvec} represented as 0 and 1 characters. This is the Common
+Lisp representation of a bitvector.
+@end deffn
+
+@deffn {Scheme Procedure} string->bitvector string -> bitvector
+
+Parses a string in the format generated by @code{bitvector->string} and
+returns the corresponding bitvector, or @code{#f} if the string is not
+in this format.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector->integer bitvector
+
+Returns a non-negative exact integer whose bits, starting with the least
+significant bit as bit 0, correspond to the values in @var{bitvector}.
+This ensures compatibility with the integers-as-bits operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}.
+@end deffn
+
+@deffn {Scheme Procedure} integer->bitvector integer [len]
+
+Returns a bitvector whose length is @var{len} whose values correspond to
+the bits of @var{integer}, a non-negative exact integer, starting with
+the least significant bit as bit 0. This ensures compatibility with the
+integers-as-bits operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}
+
+The default value of @var{len} is @samp{(integer-length @var{integer})}.
+If the value of @var{len} is less than the default, the resulting
+bitvector cannot be converted back by @code{bitvector->integer}
+correctly.
+@end deffn
+
+@node SRFI 178 Generators
+@subsubsection SRFI 178 Generators
+
+@deffn {Scheme Procedure} make-bitvector/int-generator bitvector
+@deffnx {Scheme Procedure} make-bitvector/bool-generator bitvector
+
+Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI
+158} generator that generates all the values of @var{bitvector} in
+order. Note that the generator is finite.
+@end deffn
+
+@deffn {Scheme Procedure} make-bitvector-accumulator
+
+Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI
+158} accumulator that collects all the bits it is invoked on. When
+invoked on an end-of-file object, returns a bitvector containing all the
+bits in order.
+@end deffn
+
+@node SRFI 178 Basic operations
+@subsubsection SRFI 178 Basic operations
+
+@deffn {Scheme Procedure} bitvector-not bvec
+@deffnx {Scheme Procedure} bitvector-not! bvec
+
+Returns the element-wise complement of @var{bvec}; that is, each value
+is changed to the opposite value.
+@end deffn
+
+The following ten procedures correspond to the useful set of non-trivial
+two-argument boolean functions. For each such function, the
+corresponding bitvector operator maps that function across two or more
+bitvectors in an element-wise fashion. The core idea of this group of
+functions is this element-wise "lifting" of the set of dyadic boolean
+functions to bitvector parameters.
+
+@deffn {Scheme Procedure} bitvector-and bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-and! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-ior bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-ior! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-xor bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-xor! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-eqv bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-eqv! bvec1 bvec2 bvec @dots{}
+
+These operations are associative.
+
+The @code{bitvector-eqv} procedure produces the complement of the
+@code{bitvector-xor} procedure. When applied to three arguments, it
+does @emph{not} produce a @code{#t} value everywhere that @var{a},
+@var{b} and @var{c} all agree. That is, it does @emph{not} produce:
+
+@lisp
+ (bitvector-ior (bitvector-and a b c)
+ (bitvector-and (bitvector-not a)
+ (bitvector-not b)
+ (bitvector-not c)))
+@end lisp
+
+Rather, it produces @samp{(bitvector-eqv @var{a} (bitvector-eqv @var{b}
+@var{c}))} or the equivalent @samp{(bitvector-eqv (bitvector-eqv @var{a}
+@var{b}) @var{c})}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-nand bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nand! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nor bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nor! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc1 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc1! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc2 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc2! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc1 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc1! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc2 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc2! bvec1 bvec2
+
+These operations are not associative.
+@end deffn
+
+@node SRFI 178 Quasi-integer operations
+@subsubsection SRFI 178 Quasi-integer operations
+
+@deffn {Scheme Procedure} bitvector-logical-shift bvec count bit
+
+Returns a bitvector equal in length to @var{bvec} containing the logical
+left shift (toward lower indices) when @var{count}>=0 or the right shift
+(toward upper indices) when @var{count}<0. Newly vacated elements are
+filled with @var{bit}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-count bit bvec
+
+Returns the number of @var{bit} values in @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-count-run bit bvec i
+
+Returns the number of consecutive @var{bit} values in @var{bvec},
+starting at index @var{i}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-if if-bitvector then-bitvector else-bitvector
+
+Returns a bitvector that merges the bitvectors @var{then-bitvector} and
+@var{else-bitvector}, with the bitvector @var{if-bitvector} determining
+from which bitvector to take each value. That is, if the @var{k}th
+value of @var{if-bitvector} is @code{#t} (or 1, depending in how you
+look at it), then the @var{k}th bit of the result is the @var{k}th bit
+of @var{then-bitvector}, otherwise the @var{k}th bit of
+@var{else-bitvector}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-first-bit bit bvec
+
+Return the index of the first (smallest index) @var{bit} value in
+@var{bvec}. Return @code{-1} if @var{bvec} contains no values equal to
+@var{bit}.
+@end deffn
+
+@node SRFI 178 Bit field operations
+@subsubsection SRFI 178 Bit field operations
+
+These procedures operate on a contiguous field of bits (a "byte" in
+Common Lisp parlance) in a given bitvector. The @var{start} and
+@var{end} arguments, which are not optional, are non-negative exact
+integers specifying the field: it is the @var{end} --- @var{start} bits
+running from bit @var{start} to bit @samp{@var{end} - 1}.
+
+@deffn {Scheme Procedure} bitvector-field-any? bvec start end
+
+Returns @code{#t} if any of the field's bits are set in @var{bvec}, and
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-every? bvec start end
+
+Returns @code{#f} if any of the field's bits are not set in @var{bvec},
+and @code{#t} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-clear bvec start end
+@deffnx {Scheme Procedure} bitvector-field-clear! bvec start end
+@deffnx {Scheme Procedure} bitvector-field-set bvec start end
+@deffnx {Scheme Procedure} bitvector-field-set! bvec start end
+
+Returns a bitvector containing @var{bvec} with the field's bits set
+appropriately.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-replace dest source start end
+@deffnx {Scheme Procedure} bitvector-field-replace! dest source start end
+
+Returns a bitvector containing @var{dest} with the field replaced by the
+first @var{end-start} bits in @var{source}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-replace-same dest source start end
+@deffnx {Scheme Procedure} bitvector-field-replace-same! dest source start end
+
+Returns a bitvector containing @var{dest} with its field replaced by
+the corresponding field in @var{source}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-rotate bvec count start end
+
+Returns @var{bvec} with the field cyclically permuted by @var{count}
+bits towards higher indices when @var{count} is negative, and toward
+lower indices otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-flip bvec start end
+@deffnx {Scheme Procedure} bitvector-field-flip! bvec start end
+
+Returns @var{bvec} with the bits in the field flipped: that is, each
+value is replaced by the opposite value. There is no SRFI 151
+equivalent.
+@end deffn
+
+@node SRFI 178 Bitvector literals
+@subsubsection SRFI 178 Bitvector literals
+
+The compact string representation used by @code{bitvector->string} and
+@code{string->bitvector} may be supported by the standard @code{read}
+and @code{write} procedures and by the program parser, so that programs
+can contain references to literal bitvectors. On input, it is an error
+if such a literal is not followed by a <delimiter> or the end of input.
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/module/srfi/srfi-178.sld b/module/srfi/srfi-178.sld
new file mode 100644
index 000000000..e0d991ee7
--- /dev/null
+++ b/module/srfi/srfi-178.sld
@@ -0,0 +1,105 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define-library (srfi 178)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (srfi 151))
+ (import (srfi 160 u8))
+
+ (cond-expand
+ ((library (srfi 133))
+ (import (only (srfi 133) vector-unfold)))
+ (else
+ (begin
+ ;; The "seedless" case is all we need.
+ (define (vector-unfold f len)
+ (let ((res (make-vector len)))
+ (let lp ((i 0))
+ (cond ((= i len) res)
+ (else (vector-set! res i (f i))
+ (lp (+ i 1))))))))))
+
+ (export bit->integer bit->boolean ; Bit conversion
+
+ ;; Constructors
+ make-bitvector bitvector bitvector-unfold
+ bitvector-unfold-right bitvector-copy
+ bitvector-reverse-copy bitvector-append bitvector-concatenate
+ bitvector-append-subbitvectors
+
+ ;; Predicates
+ bitvector? bitvector-empty? bitvector=?
+
+ ;; Selectors
+ bitvector-ref/int bitvector-ref/bool bitvector-length
+
+ ;; Iteration
+ bitvector-take bitvector-take-right
+ bitvector-drop bitvector-drop-right bitvector-segment
+ bitvector-fold/int bitvector-fold/bool bitvector-fold-right/int
+ bitvector-fold-right/bool bitvector-map/int bitvector-map/bool
+ bitvector-map!/int bitvector-map!/bool bitvector-map->list/int
+ bitvector-map->list/bool bitvector-for-each/int
+ bitvector-for-each/bool
+
+ ;; Prefixes, suffixes, trimming, padding
+ bitvector-prefix-length
+ bitvector-suffix-length bitvector-prefix? bitvector-suffix?
+ bitvector-pad bitvector-pad-right bitvector-trim
+ bitvector-trim-right bitvector-trim-both
+
+ ;; Mutators
+ bitvector-set!
+ bitvector-swap! bitvector-reverse!
+ bitvector-copy! bitvector-reverse-copy!
+
+ ;; Conversion
+ bitvector->list/int
+ bitvector->list/bool reverse-bitvector->list/int
+ reverse-bitvector->list/bool list->bitvector
+ reverse-list->bitvector bitvector->vector/int
+ bitvector->vector/bool vector->bitvector bitvector->string
+ string->bitvector bitvector->integer integer->bitvector
+ reverse-vector->bitvector reverse-bitvector->vector/int
+ reverse-bitvector->vector/bool
+
+ ;; Generators and accumulators
+ make-bitvector/int-generator make-bitvector/bool-generator
+ make-bitvector-accumulator
+
+ ;; Basic operations
+ bitvector-not bitvector-not!
+ bitvector-and bitvector-and! bitvector-ior bitvector-ior!
+ bitvector-xor bitvector-xor! bitvector-eqv bitvector-eqv!
+ bitvector-nand bitvector-nand! bitvector-nor bitvector-nor!
+ bitvector-andc1 bitvector-andc1! bitvector-andc2
+ bitvector-andc2! bitvector-orc1 bitvector-orc1!
+ bitvector-orc2 bitvector-orc2!
+
+ ;; Quasi-integer operations
+ bitvector-logical-shift
+ bitvector-count bitvector-if
+ bitvector-first-bit bitvector-count-run
+
+ ;; Bit field operations
+ bitvector-field-any? bitvector-field-every?
+ bitvector-field-clear bitvector-field-clear!
+ bitvector-field-set bitvector-field-set!
+ bitvector-field-replace-same bitvector-field-replace-same!
+ bitvector-field-rotate bitvector-field-flip
+ bitvector-field-flip!
+ bitvector-field-replace bitvector-field-replace!
+ )
+
+ (include "srfi-178/macros.scm")
+ (include "srfi-178/convert.scm")
+ (include "srfi-178/fields.scm")
+ (include "srfi-178/gen-acc.scm")
+ (include "srfi-178/logic-ops.scm")
+ (include "srfi-178/map2list.scm")
+ (include "srfi-178/quasi-ints.scm")
+ (include "srfi-178/quasi-strs.scm")
+ (include "srfi-178/unfolds.scm")
+ (include "srfi-178/wrappers.scm")
+)
diff --git a/module/srfi/srfi-178/convert.scm b/module/srfi/srfi-178/convert.scm
new file mode 100644
index 000000000..86f61b950
--- /dev/null
+++ b/module/srfi/srfi-178/convert.scm
@@ -0,0 +1,83 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; Bit conversions
+
+(define (bit->integer bit) (I bit))
+
+(define (bit->boolean bit) (B bit))
+
+(define (bitvector->string bvec)
+ (let loop ((i (- (bitvector-length bvec) 1))
+ (r '()))
+ (if (< i 0)
+ (list->string (cons #\# (cons #\* r)))
+ (loop (- i 1)
+ (cons (if (bitvector-ref/bool bvec i) #\1 #\0) r)))))
+
+(define (string->bitvector str)
+ (call/cc
+ (lambda (return)
+ (and
+ (> (string-length str) 1)
+ (char=? (string-ref str 0) #\#)
+ (char=? (string-ref str 1) #\*)
+ (bitvector-unfold
+ (lambda (ri si)
+ (case (string-ref str si)
+ ((#\0) (values 0 (+ si 1)))
+ ((#\1) (values 1 (+ si 1)))
+ (else (return #f))))
+ (- (string-length str) 2)
+ 2)))))
+
+;;;; Bitvector/integer conversions
+
+(define (bitvector->integer bvec)
+ (bitvector-fold-right/int (lambda (r b) (+ (* r 2) b)) 0 bvec))
+
+(define integer->bitvector
+ (case-lambda
+ ((int) (integer->bitvector int (integer-length int)))
+ ((int len)
+ (bitvector-unfold
+ (lambda (_ int)
+ (values (bit-set? 0 int) (arithmetic-shift int -1)))
+ len
+ int))))
+
+;;; Additional vector conversions
+
+(define reverse-vector->bitvector
+ (case-lambda
+ ((vec) (reverse-vector->bitvector vec 0 (vector-length vec)))
+ ((vec start) (reverse-vector->bitvector vec start (vector-length vec)))
+ ((vec start end)
+ (bitvector-unfold
+ (lambda (i)
+ (vector-ref vec (- end 1 i)))
+ (- end start)))))
+
+(define reverse-bitvector->vector/int
+ (case-lambda
+ ((bvec)
+ (reverse-bitvector->vector/int bvec 0 (bitvector-length bvec)))
+ ((bvec start)
+ (reverse-bitvector->vector/int bvec start (bitvector-length bvec)))
+ ((bvec start end)
+ (let ((u8vec (U bvec)))
+ (vector-unfold (lambda (i)
+ (u8vector-ref u8vec (- end 1 i)))
+ (- end start))))))
+
+(define reverse-bitvector->vector/bool
+ (case-lambda
+ ((bvec)
+ (reverse-bitvector->vector/bool bvec 0 (bitvector-length bvec)))
+ ((bvec start)
+ (reverse-bitvector->vector/bool bvec start (bitvector-length bvec)))
+ ((bvec start end)
+ (let ((u8vec (U bvec)))
+ (vector-unfold (lambda (i)
+ (B (u8vector-ref u8vec (- end 1 i))))
+ (- end start))))))
diff --git a/module/srfi/srfi-178/fields.scm b/module/srfi/srfi-178/fields.scm
new file mode 100644
index 000000000..e2c172e0e
--- /dev/null
+++ b/module/srfi/srfi-178/fields.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-field-any? bvec start end)
+ (let lp ((i start))
+ (and (< i end)
+ (or (bitvector-ref/bool bvec i)
+ (lp (+ i 1))))))
+
+(define (bitvector-field-every? bvec start end)
+ (let lp ((i start))
+ (or (>= i end)
+ (and (bitvector-ref/bool bvec i)
+ (lp (+ i 1))))))
+
+(define (%bitvector-field-modify bvec bit start end)
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ bit
+ (bitvector-ref/int bvec i)))
+ (bitvector-length bvec)))
+
+(define (bitvector-field-clear bvec start end)
+ (%bitvector-field-modify bvec 0 start end))
+
+(define (%bitvector-fill!/int bvec int start end)
+ (u8vector-fill! (U bvec) int start end))
+
+(define (bitvector-field-clear! bvec start end)
+ (%bitvector-fill!/int bvec 0 start end))
+
+(define (bitvector-field-set bvec start end)
+ (%bitvector-field-modify bvec 1 start end))
+
+(define (bitvector-field-set! bvec start end)
+ (%bitvector-fill!/int bvec 1 start end))
+
+(define (bitvector-field-replace dest source start end)
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ (bitvector-ref/int source (- i start))
+ (bitvector-ref/int dest i)))
+ (bitvector-length dest)))
+
+(define (bitvector-field-replace! dest source start end)
+ (bitvector-copy! dest start source 0 (- end start)))
+
+(define (bitvector-field-replace-same dest source start end)
+ (bitvector-unfold
+ (lambda (i)
+ (bitvector-ref/int (if (and (>= i start) (< i end))
+ source
+ dest)
+ i))
+ (bitvector-length dest)))
+
+(define (bitvector-field-replace-same! dest source start end)
+ (bitvector-copy! dest start source start end))
+
+(define (bitvector-field-rotate bvec count start end)
+ (if (zero? count)
+ bvec
+ (let ((field-len (- end start)))
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ (bitvector-ref/int
+ bvec
+ (+ start (floor-remainder (+ (- i start) count) field-len)))
+ (bitvector-ref/int bvec i)))
+ (bitvector-length bvec)))))
+
+(define (bitvector-field-flip bvec start end)
+ (bitvector-unfold
+ (lambda (i)
+ (I (if (and (>= i start) (< i end))
+ (not (bitvector-ref/bool bvec i))
+ (bitvector-ref/bool bvec i))))
+ (bitvector-length bvec)))
+
+(define (bitvector-field-flip! bvec start end)
+ (let lp ((i start))
+ (unless (>= i end)
+ (bitvector-set! bvec i (not (bitvector-ref/bool bvec i)))
+ (lp (+ i 1)))))
+
diff --git a/module/srfi/srfi-178/gen-acc.scm b/module/srfi/srfi-178/gen-acc.scm
new file mode 100644
index 000000000..863f5358c
--- /dev/null
+++ b/module/srfi/srfi-178/gen-acc.scm
@@ -0,0 +1,25 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (%make-bitvector-generator bvec ref-proc)
+ (let ((len (bitvector-length bvec))
+ (i 0))
+ (lambda ()
+ (if (= i len)
+ (eof-object)
+ (let ((r (ref-proc bvec i)))
+ (set! i (+ i 1))
+ r)))))
+
+(define (make-bitvector/int-generator bvec)
+ (%make-bitvector-generator bvec bitvector-ref/int))
+
+(define (make-bitvector/bool-generator bvec)
+ (%make-bitvector-generator bvec bitvector-ref/bool))
+
+(define (make-bitvector-accumulator)
+ (let ((r '()))
+ (lambda (x)
+ (if (eof-object? x)
+ (reverse-list->bitvector r)
+ (set! r (cons x r))))))
diff --git a/module/srfi/srfi-178/logic-ops.scm b/module/srfi/srfi-178/logic-ops.scm
new file mode 100644
index 000000000..b14b357da
--- /dev/null
+++ b/module/srfi/srfi-178/logic-ops.scm
@@ -0,0 +1,105 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (u1-not a)
+ (- 1 a))
+
+(define (bitvector-not avec)
+ (bitvector-map/int u1-not avec))
+
+(define (bitvector-not! avec)
+ (bitvector-map!/int u1-not avec))
+
+(define (u1-and . args)
+ (I (apply * args)))
+
+(define (bitvector-and . vecs)
+ (apply bitvector-map/int u1-and vecs))
+
+(define (bitvector-and! . vecs)
+ (apply bitvector-map!/int u1-and vecs))
+
+(define (u1-ior . args)
+ (I (apply + args)))
+
+(define (bitvector-ior . vecs)
+ (apply bitvector-map/int u1-ior vecs))
+
+(define (bitvector-ior! . vecs)
+ (apply bitvector-map!/int u1-ior vecs))
+
+(define (u1-xor . args)
+ (I (odd? (apply + args))))
+
+(define (bitvector-xor . vecs)
+ (apply bitvector-map/int u1-xor vecs))
+
+(define (bitvector-xor! . vecs)
+ (apply bitvector-map!/int u1-xor vecs))
+
+(define (u1-eqv . args)
+ (let ((xor-value (apply u1-xor args)))
+ (if (odd? (length args))
+ xor-value
+ (u1-not xor-value))))
+
+(define (bitvector-eqv . vecs)
+ (apply bitvector-map/int u1-eqv vecs))
+
+(define (bitvector-eqv! . vecs)
+ (apply bitvector-map!/int u1-eqv vecs))
+
+(define (u1-nand a b)
+ (u1-not (u1-and a b)))
+
+(define (bitvector-nand a b)
+ (bitvector-map/int u1-nand a b))
+
+(define (bitvector-nand! a b)
+ (bitvector-map!/int u1-nand a b))
+
+(define (u1-nor a b)
+ (u1-not (u1-ior a b)))
+
+(define (bitvector-nor a b)
+ (bitvector-map/int u1-nor a b))
+
+(define (bitvector-nor! a b)
+ (bitvector-map!/int u1-nor a b))
+
+(define (u1-andc1 a b)
+ (u1-and (u1-not a) b))
+
+(define (bitvector-andc1 a b)
+ (bitvector-map/int u1-andc1 a b))
+
+(define (bitvector-andc1! a b)
+ (bitvector-map!/int u1-andc1 a b))
+
+(define (u1-andc2 a b)
+ (u1-and a (u1-not b)))
+
+(define (bitvector-andc2 a b)
+ (bitvector-map/int u1-andc2 a b))
+
+(define (bitvector-andc2! a b)
+ (bitvector-map!/int u1-andc2 a b))
+
+(define (u1-orc1 a b)
+ (u1-ior (u1-not a) b))
+
+(define (bitvector-orc1 a b)
+ (bitvector-map/int u1-orc1 a b))
+
+(define (bitvector-orc1! a b)
+ (bitvector-map!/int u1-orc1 a b))
+
+(define (u1-orc2 a b)
+ (u1-ior a (u1-not b)))
+
+(define (bitvector-orc2 a b)
+ (bitvector-map/int u1-orc2 a b))
+
+(define (bitvector-orc2! a b)
+ (bitvector-map!/int u1-orc2 a b))
+
diff --git a/module/srfi/srfi-178/macros.scm b/module/srfi/srfi-178/macros.scm
new file mode 100644
index 000000000..9e5900512
--- /dev/null
+++ b/module/srfi/srfi-178/macros.scm
@@ -0,0 +1,26 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;;; SRFI 178 macros for internal use
+
+;;; Bitvector type definition
+;;; W wraps a u8vector as a bitvector, U unwraps it again
+
+(define-record-type <bitvector>
+ (W u8vec)
+ bitvector?
+ (u8vec U))
+
+;; Convert a bit to an integer
+(define-syntax I
+ (syntax-rules ()
+ ((I bit)
+ (cond
+ ((eqv? bit 0) 0)
+ ((not bit) 0)
+ (else 1)))))
+
+;; Convert a bit to a bool
+(define-syntax B
+ (syntax-rules ()
+ ((B bit) (not (or (eqv? bit 0) (not bit))))))
diff --git a/module/srfi/srfi-178/map2list.scm b/module/srfi/srfi-178/map2list.scm
new file mode 100644
index 000000000..7118f59cc
--- /dev/null
+++ b/module/srfi/srfi-178/map2list.scm
@@ -0,0 +1,27 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define bitvector-map->list/int
+ (case-lambda
+ ((f bvec) ; fast path
+ (bitvector-fold-right/int (lambda (xs b) (cons (f b) xs))
+ '()
+ bvec))
+ ((f . bvecs)
+ (apply bitvector-fold-right/int
+ (lambda (xs . bs) (cons (apply f bs) xs))
+ '()
+ bvecs))))
+
+(define bitvector-map->list/bool
+ (case-lambda
+ ((f bvec) ; fast path
+ (bitvector-fold-right/bool (lambda (xs b) (cons (f b) xs))
+ '()
+ bvec))
+ ((f . bvecs)
+ (apply bitvector-fold-right/bool
+ (lambda (xs . bs) (cons (apply f bs) xs))
+ '()
+ bvecs))))
+
diff --git a/module/srfi/srfi-178/quasi-ints.scm b/module/srfi/srfi-178/quasi-ints.scm
new file mode 100644
index 000000000..f66e4ee27
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-ints.scm
@@ -0,0 +1,54 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-logical-shift bvec count bit)
+ (cond ((positive? count)
+ (%bitvector-left-shift bvec count (I bit)))
+ ((negative? count)
+ (%bitvector-right-shift bvec (- count) (I bit)))
+ (else bvec)))
+
+(define (%bitvector-left-shift bvec count bit)
+ (let ((len (bitvector-length bvec)))
+ (bitvector-unfold
+ (lambda (i)
+ (let ((i* (+ i count)))
+ (if (< i* len) (bitvector-ref/int bvec i*) bit)))
+ len)))
+
+(define (%bitvector-right-shift bvec count bit)
+ (bitvector-unfold
+ (lambda (i)
+ (if (< i count)
+ bit
+ (bitvector-ref/int bvec (- i count))))
+ (bitvector-length bvec)))
+
+(define (bitvector-count bit bvec)
+ (let ((int (I bit)))
+ (bitvector-fold/int (lambda (n b) (if (= b int) (+ n 1) n))
+ 0
+ bvec)))
+
+(define (bitvector-count-run bit bvec index)
+ (let ((int (I bit))
+ (len (bitvector-length bvec)))
+ (let lp ((i index) (c 0))
+ (if (or (>= i len) (not (= int (bitvector-ref/int bvec i))))
+ c
+ (lp (+ i 1) (+ c 1))))))
+
+(define (bitvector-if if-bvec then-bvec else-bvec)
+ (bitvector-map/bool (lambda (bit then-bit else-bit)
+ (if bit then-bit else-bit))
+ if-bvec
+ then-bvec
+ else-bvec))
+
+(define (bitvector-first-bit bit bvec)
+ (let ((int (I bit)) (len (bitvector-length bvec)))
+ (let lp ((i 0))
+ (cond ((>= i len) -1)
+ ((= int (bitvector-ref/int bvec i)) i)
+ (else (lp (+ i 1)))))))
+
diff --git a/module/srfi/srfi-178/quasi-strs.scm b/module/srfi/srfi-178/quasi-strs.scm
new file mode 100644
index 000000000..2d63b43ad
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-strs.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-prefix-length bvec1 bvec2)
+ (let ((end (min (bitvector-length bvec1) (bitvector-length bvec2))))
+ (if (eqv? bvec1 bvec2)
+ end
+ (let lp ((i 0))
+ (if (or (>= i end)
+ (not (= (bitvector-ref/int bvec1 i)
+ (bitvector-ref/int bvec2 i))))
+ i
+ (lp (+ i 1)))))))
+
+(define (bitvector-suffix-length bvec1 bvec2)
+ (let ((end1 (bitvector-length bvec1))
+ (end2 (bitvector-length bvec2)))
+ (let* ((delta (min end1 end2))
+ (start (- end1 delta)))
+ (if (eqv? bvec1 bvec2)
+ delta
+ (let lp ((i (- end1 1)) (j (- end2 1)))
+ (if (or (< i start)
+ (not (= (bitvector-ref/int bvec1 i)
+ (bitvector-ref/int bvec2 j))))
+ (- (- end1 i) 1)
+ (lp (- i 1) (- j 1))))))))
+
+(define (bitvector-prefix? bvec1 bvec2)
+ (let ((len1 (bitvector-length bvec1)))
+ (and (<= len1 (bitvector-length bvec2))
+ (= (bitvector-prefix-length bvec1 bvec2) len1))))
+
+(define (bitvector-suffix? bvec1 bvec2)
+ (let ((len1 (bitvector-length bvec1)))
+ (and (<= len1 (bitvector-length bvec2))
+ (= (bitvector-suffix-length bvec1 bvec2) len1))))
+
+(define (bitvector-pad bit bvec len)
+ (let ((old-len (bitvector-length bvec)))
+ (if (<= len old-len)
+ bvec
+ (let ((result (make-bitvector len bit)))
+ (bitvector-copy! result (- len old-len) bvec)
+ result))))
+
+(define (bitvector-pad-right bit bvec len)
+ (if (<= len (bitvector-length bvec))
+ bvec
+ (let ((result (make-bitvector len bit)))
+ (bitvector-copy! result 0 bvec)
+ result)))
+
+(define (%bitvector-skip bvec bit)
+ (let ((len (bitvector-length bvec))
+ (int (bit->integer bit)))
+ (let lp ((i 0))
+ (and (< i len)
+ (if (= int (bitvector-ref/int bvec i))
+ (lp (+ i 1))
+ i)))))
+
+(define (%bitvector-skip-right bvec bit)
+ (let ((len (bitvector-length bvec))
+ (int (bit->integer bit)))
+ (let lp ((i (- len 1)))
+ (and (>= i 0)
+ (if (= int (bitvector-ref/int bvec i))
+ (lp (- i 1))
+ i)))))
+
+(define (bitvector-trim bit bvec)
+ (cond ((%bitvector-skip bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec skip (bitvector-length bvec))))
+ (else (bitvector))))
+
+(define (bitvector-trim-right bit bvec)
+ (cond ((%bitvector-skip-right bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec 0 (+ skip 1))))
+ (else (bitvector))))
+
+(define (bitvector-trim-both bit bvec)
+ (cond ((%bitvector-skip bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec skip (+ 1 (%bitvector-skip-right bvec bit)))))
+ (else (bitvector))))
diff --git a/module/srfi/srfi-178/unfolds.scm b/module/srfi/srfi-178/unfolds.scm
new file mode 100644
index 000000000..fa5956926
--- /dev/null
+++ b/module/srfi/srfi-178/unfolds.scm
@@ -0,0 +1,44 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; unfold
+
+;;; These procedures work by building temporary lists, then converting
+;;; them to vectors. This uses more space than pre-allocating a bitvector
+;;; and filling it, but it's referentially transparent: there's no way
+;;; to capture a partially-filled bitvector through continuation tricks.
+
+;; Unfold a list. f is passed the current index and list of seeds
+;; on each step, and must return a bit and new seeds on each step.
+(define (%unfold/index f len seeds)
+ (letrec
+ ((build
+ (lambda (i seeds)
+ (if (= i len)
+ '()
+ (let-values (((b . seeds*) (apply f i seeds)))
+ (cons b (build (+ i 1) seeds*)))))))
+
+ (build 0 seeds)))
+
+(define (bitvector-unfold f len . seeds)
+ (list->bitvector (%unfold/index f len seeds)))
+
+;;;; unfold-right
+
+;; Unfold a list from the right. f is passed the current index and
+;; list of seeds on each step, and must return a bit and new seeds
+;; on each step.
+(define (%unfold-right/index f len seeds)
+ (letrec
+ ((build
+ (lambda (i seeds res)
+ (if (< i 0)
+ res
+ (let-values (((b . seeds*) (apply f i seeds)))
+ (build (- i 1) seeds* (cons b res)))))))
+
+ (build (- len 1) seeds '())))
+
+(define (bitvector-unfold-right f len . seeds)
+ (list->bitvector (%unfold-right/index f len seeds)))
diff --git a/module/srfi/srfi-178/wrappers.scm b/module/srfi/srfi-178/wrappers.scm
new file mode 100644
index 000000000..bb439dd12
--- /dev/null
+++ b/module/srfi/srfi-178/wrappers.scm
@@ -0,0 +1,285 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; SRFI 178 procedures that are just wrappers
+
+(define make-bitvector
+ (case-lambda
+ ((size) (W (make-u8vector size)))
+ ((size bit) (W (make-u8vector size (I bit))))))
+
+(define bitvector-copy
+ (case-lambda
+ ((bvec) (W (u8vector-copy (U bvec))))
+ ((bvec start) (W (u8vector-copy (U bvec) start)))
+ ((bvec start end) (W (u8vector-copy (U bvec) start end)))))
+
+(define bitvector-reverse-copy
+ (case-lambda
+ ((bvec) (W (u8vector-reverse-copy (U bvec))))
+ ((bvec start) (W (u8vector-reverse-copy (U bvec) start)))
+ ((bvec start end) (W (u8vector-reverse-copy (U bvec) start end)))))
+
+(define (bitvector-append . bvecs)
+ (bitvector-concatenate bvecs))
+
+(define (bitvector-concatenate bvecs)
+ (W (u8vector-concatenate (map U bvecs))))
+
+(define (bitvector-append-subbitvectors . args)
+ (W (apply u8vector-append-subvectors
+ (map (lambda (x) (if (bitvector? x) (U x) x)) args))))
+
+(define (bitvector-empty? bvec)
+ (eqv? 0 (u8vector-length (U bvec))))
+
+(define (bitvector=? . bvecs)
+ (apply u8vector= (map U bvecs)))
+
+(define (bitvector-ref/int bvec i)
+ (u8vector-ref (U bvec) i))
+
+(define (bitvector-ref/bool bvec i)
+ (B (u8vector-ref (U bvec) i)))
+
+(define (bitvector-length bvec)
+ (u8vector-length (U bvec)))
+
+(define (bitvector-take bvec n)
+ (W (u8vector-take (U bvec) n)))
+
+(define (bitvector-take-right bvec n)
+ (W (u8vector-take-right (U bvec) n)))
+
+(define (bitvector-drop bvec n)
+ (W (u8vector-drop (U bvec) n)))
+
+(define (bitvector-drop-right bvec n)
+ (W (u8vector-drop-right (U bvec) n)))
+
+(define (bitvector-segment bvec n)
+ (unless (and (integer? n) (positive? n))
+ (error "bitvector-segment: not a positive integer" n))
+ (map W (u8vector-segment (U bvec) n)))
+
+(define bitvector-fold/int
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold kons knil (U bvec))) ; fast path
+ ((kons knil . bvecs)
+ (apply u8vector-fold kons knil (map U bvecs)))))
+
+(define bitvector-fold/bool
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold (lambda (x b) (kons x (B b))) ; fast path
+ knil
+ (U bvec)))
+ ((kons knil . bvecs)
+ (apply u8vector-fold
+ (lambda (x . bits)
+ (apply kons x (map bit->boolean bits)))
+ knil
+ (map U bvecs)))))
+
+(define bitvector-fold-right/int
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold-right kons knil (U bvec))) ; fast path
+ ((kons knil . bvecs)
+ (apply u8vector-fold-right kons knil (map U bvecs)))))
+
+(define bitvector-fold-right/bool
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold-right (lambda (x bit) (kons x (B bit))) ; fast path
+ knil
+ (U bvec)))
+ ((kons knil . bvecs)
+ (apply u8vector-fold-right
+ (lambda (x . bits)
+ (apply kons x (map bit->boolean bits)))
+ knil
+ (map U bvecs)))))
+
+(define bitvector-map/int
+ (case-lambda
+ ((f bvec)
+ (W (u8vector-map f (U bvec)))) ; one-bitvector fast path
+ ((f bvec1 bvec2)
+ (%bitvector-map2/int f bvec1 bvec2)) ; two-bitvector fast path
+ ((f . bvecs)
+ (W (apply u8vector-map f (map U bvecs)))))) ; normal path
+
+;; Tuned two-bitvector version, mainly for binary logical ops.
+(define (%bitvector-map2/int f bvec1 bvec2)
+ (let ((u8vec1 (U bvec1))
+ (u8vec2 (U bvec2)))
+ (bitvector-unfold
+ (lambda (i)
+ (f (u8vector-ref u8vec1 i) (u8vector-ref u8vec2 i)))
+ (bitvector-length bvec1))))
+
+(define bitvector-map/bool
+ (case-lambda
+ ((f bvec) ; one-bitvector fast path
+ (W (u8vector-map (lambda (n) (I (f (B n)))) (U bvec))))
+ ((f bvec1 bvec2) ; two-bitvector fast path
+ (%bitvector-map2/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2))
+ ((f . bvecs) ; normal path (ugh)
+ (W (apply u8vector-map
+ (lambda ns (I (apply f (map bit->boolean ns))))
+ (map U bvecs))))))
+
+(define bitvector-map!/int
+ (case-lambda
+ ((f bvec)
+ (u8vector-map! f (U bvec))) ; one-bitvector fast path
+ ((f bvec1 bvec2)
+ (%bitvector-map2!/int f bvec1 bvec2)) ; two-bitvector fast path
+ ((f . bvecs)
+ (apply u8vector-map! f (map U bvecs))))) ; normal path
+
+;; Tuned two-bitvector version, mainly for binary logical ops.
+(define (%bitvector-map2!/int f bvec1 bvec2)
+ (let ((len (bitvector-length bvec1))
+ (u8vec1 (U bvec1))
+ (u8vec2 (U bvec2)))
+ (let lp ((i 0))
+ (unless (>= i len)
+ (u8vector-set! u8vec1 i (f (u8vector-ref u8vec1 i)
+ (u8vector-ref u8vec2 i)))
+ (lp (+ i 1))))
+ bvec1))
+
+(define bitvector-map!/bool
+ (case-lambda
+ ((f bvec) ; one-bitvector fast path
+ (u8vector-map! (lambda (n) (I (f (B n)))) (U bvec)))
+ ((f bvec1 bvec2) ; two-bitvector fast path
+ (%bitvector-map2!/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2))
+ ((f . bvecs) ; normal path (ugh)
+ (apply u8vector-map!
+ (lambda ns (I (apply f (map bit->boolean ns))))
+ (map U bvecs)))))
+
+(define bitvector-for-each/int
+ (case-lambda
+ ((f bvec)
+ (u8vector-for-each f (U bvec))) ; fast path
+ ((f . bvecs)
+ (apply u8vector-for-each f (map U bvecs)))))
+
+(define bitvector-for-each/bool
+ (case-lambda
+ ((f bvec)
+ (u8vector-for-each (lambda (n) (f (B n))) (U bvec))) ; fast path
+ ((f . bvecs)
+ (apply u8vector-for-each
+ (lambda ns (apply f (map bit->boolean ns)))
+ (map U bvecs)))))
+
+(define (bitvector-set! bvec i bit)
+ (u8vector-set! (U bvec) i (I bit)))
+
+(define (bitvector-swap! bvec i j)
+ (u8vector-swap! (U bvec) i j))
+
+
+(define bitvector-reverse!
+ (case-lambda
+ ((bvec)
+ (u8vector-reverse! (U bvec)))
+ ((bvec start)
+ (u8vector-reverse! (U bvec) start))
+ ((bvec start end)
+ (u8vector-reverse! (U bvec) start end))))
+
+(define bitvector-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-copy! (U to) at (U from)))
+ ((to at from start)
+ (u8vector-copy! (U to) at (U from) start))
+ ((to at from start end)
+ (u8vector-copy! (U to) at (U from) start end))))
+
+(define bitvector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-reverse-copy! (U to) at (U from)))
+ ((to at from start)
+ (u8vector-reverse-copy! (U to) at (U from) start))
+ ((to at from start end)
+ (u8vector-reverse-copy! (U to) at (U from) start end))))
+
+(define bitvector->list/int
+ (case-lambda
+ ((bvec)
+ (u8vector->list (U bvec)))
+ ((bvec start)
+ (u8vector->list (U bvec) start))
+ ((bvec start end)
+ (u8vector->list (U bvec) start end))))
+
+(define bitvector->list/bool
+ (case-lambda
+ ((bvec)
+ (map bit->boolean (u8vector->list (U bvec))))
+ ((bvec start)
+ (map bit->boolean (u8vector->list (U bvec) start)))
+ ((bvec start end)
+ (map bit->boolean (u8vector->list (U bvec) start end)))))
+
+(define reverse-bitvector->list/int
+ (case-lambda
+ ((bvec)
+ (reverse-u8vector->list (U bvec)))
+ ((bvec start)
+ (reverse-u8vector->list (U bvec) start))
+ ((bvec start end)
+ (reverse-u8vector->list (U bvec) start end))))
+
+(define reverse-bitvector->list/bool
+ (case-lambda
+ ((bvec)
+ (map bit->boolean (reverse-u8vector->list (U bvec))))
+ ((bvec start)
+ (map bit->boolean (reverse-u8vector->list (U bvec) start)))
+ ((bvec start end)
+ (map bit->boolean (reverse-u8vector->list (U bvec) start end)))))
+
+(define bitvector->vector/int
+ (case-lambda
+ ((bvec)
+ (u8vector->vector (U bvec)))
+ ((bvec start)
+ (u8vector->vector (U bvec) start))
+ ((bvec start end)
+ (u8vector->vector (U bvec) start end))))
+
+(define bitvector->vector/bool
+ (case-lambda
+ ((bvec)
+ (vector-map bit->boolean (u8vector->vector (U bvec))))
+ ((bvec start)
+ (vector-map bit->boolean (u8vector->vector (U bvec) start)))
+ ((bvec start end)
+ (vector-map bit->boolean (u8vector->vector (U bvec) start end)))))
+
+(define (list->bitvector list)
+ (W (list->u8vector (map bit->integer list))))
+
+(define (reverse-list->bitvector list)
+ (W (reverse-list->u8vector (map bit->integer list))))
+
+(define (bitvector . bits) (list->bitvector bits))
+
+(define vector->bitvector
+ (case-lambda
+ ((vec)
+ (W (vector->u8vector (vector-map bit->integer vec))))
+ ((vec start)
+ (W (vector->u8vector (vector-map bit->integer vec) start)))
+ ((vec start end)
+ (W (vector->u8vector (vector-map bit->integer vec) start end)))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 1afac2bca..6ee26e869 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -169,6 +169,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-160-base.test \
tests/srfi-160.test \
tests/srfi-171.test \
+ tests/srfi-178.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
@@ -220,6 +221,16 @@ EXTRA_DIST = \
tests/srfi-151-test.scm \
tests/srfi-160-base-test.scm \
tests/srfi-160-test.scm \
+ tests/srfi-178-test/constructors.scm \
+ tests/srfi-178-test/conversions.scm \
+ tests/srfi-178-test/fields.scm \
+ tests/srfi-178-test/gen-accum.scm \
+ tests/srfi-178-test/iterators.scm \
+ tests/srfi-178-test/logic-ops.scm \
+ tests/srfi-178-test/mutators.scm \
+ tests/srfi-178-test/quasi-ints.scm \
+ tests/srfi-178-test/quasi-string.scm \
+ tests/srfi-178-test/selectors.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-178-test/constructors.scm b/test-suite/tests/srfi-178-test/constructors.scm
new file mode 100644
index 000000000..3e133703a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/constructors.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-constructors)
+ (print-header "Checking constructors...")
+
+ (check (bitvector-length (make-bitvector 8)) => 8)
+ (check (bitvector= (make-bitvector 4 0) (bitvector 0 0 0 0)) => #t)
+ (check (bitvector= (make-bitvector 4 #t) (bitvector 1 1 1 1)) => #t)
+
+ ;;; unfolds
+
+ (check (bitvector=
+ (bitvector-unfold (lambda (_) 0) 4)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ b) (values b (not b))) 4 #f)
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ b c)
+ (values (and b c) (not b) c))
+ 4
+ #t
+ #t)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_) 0) 4)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_ b) (values b (not b))) 4 #f)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_ b c)
+ (values (and b c) (not b) c))
+ 4
+ #t
+ #t)
+ (bitvector 0 1 0 1))
+ => #t)
+
+ ;;; copy
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= bvec (bitvector-copy bvec)) => #t)
+ (check (eqv? bvec (bitvector-copy bvec)) => #f)) ; fresh copy?
+ (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 1) (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 2 4) (bitvector 1 0))
+ => #t)
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (equal? (bitvector->list/int (bitvector-reverse-copy bvec))
+ (reverse (bitvector->list/int bvec)))
+ => #t)
+ (check (eqv? bvec (bitvector-reverse-copy bvec)) => #f)) ; fresh copy?
+ (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 2 4)
+ (bitvector 0 1))
+ => #t)
+
+ ;;; append & concatenate
+
+ (check (bitvector=
+ (bitvector-append (bitvector 1 0) (bitvector 0 1))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-append (bitvector 1 0) (bitvector 0 1) (bitvector))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-concatenate
+ (list (bitvector 1 0) (bitvector 0 1) (bitvector)))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-append-subbitvectors (bitvector 1 0 0 1) 0 2
+ (bitvector 1 1 1 1) 2 4)
+ (bitvector 1 0 1 1))
+ => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/conversions.scm b/test-suite/tests/srfi-178-test/conversions.scm
new file mode 100644
index 000000000..7d3b3f232
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/conversions.scm
@@ -0,0 +1,108 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bitvector-conversions)
+ (print-header "Checking bitvector conversions...")
+
+ ;;; lists
+
+ (check (bitvector->list/int (bitvector)) => '())
+ (check (bitvector->list/int (bitvector 1 0 1 0)) => '(1 0 1 0))
+ (check (bitvector->list/int (bitvector 1 0 1 0) 2) => '(1 0))
+ (check (bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(0 1))
+ (check (bitvector->list/bool (bitvector)) => '())
+ (check (bitvector->list/bool (bitvector 1 0 1 0)) => '(#t #f #t #f))
+ (check (bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#t #f))
+ (check (bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#f #t))
+
+ (check (reverse-bitvector->list/int (bitvector)) => '())
+ (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 2) => '(0 1))
+ (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(1 0))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (equal? (reverse-bitvector->list/int bvec)
+ (reverse (bitvector->list/int bvec)))
+ => #t)
+ (check (equal? (reverse-bitvector->list/bool bvec)
+ (reverse (bitvector->list/bool bvec)))
+ => #t))
+ (check (reverse-bitvector->list/bool (bitvector)) => '())
+ (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#f #t))
+ (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#t #f))
+
+ (check (bitvector= (list->bitvector '(1 0 #t #f)) (bitvector 1 0 1 0)) => #t)
+ (let ((bs '(1 0 1 0)))
+ (check (equal? bs (bitvector->list/int (list->bitvector bs))) => #t)
+ (check (equal? bs
+ (reverse-bitvector->list/int
+ (reverse-list->bitvector bs)))
+ => #t))
+ (check (bitvector= (reverse-list->bitvector '(1 0 #t #f)) (bitvector 0 1 0 1))
+ => #t)
+
+ ;;; vectors
+
+ (check (bitvector->vector/int (bitvector)) => #())
+ (check (bitvector->vector/int (bitvector 1 0 1 0)) => #(1 0 1 0))
+ (check (bitvector->vector/int (bitvector 1 0 1 0) 1) => #(0 1 0))
+ (check (bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(0 1))
+ (check (bitvector->vector/bool (bitvector)) => #())
+ (check (bitvector->vector/bool (bitvector 1 0 1 0)) => #(#t #f #t #f))
+ (check (bitvector->vector/bool (bitvector 1 0 1 0) 1) => #(#f #t #f))
+ (check (bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#f #t))
+
+ (check (reverse-bitvector->vector/int (bitvector)) => #())
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0)) => #(0 1 0 1))
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 2) => #(0 1))
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(1 0))
+ (check (reverse-bitvector->vector/bool (bitvector)) => #())
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0))
+ => #(#f #t #f #t))
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 2) => #(#f #t))
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#t #f))
+
+ (check (bitvector-empty? (vector->bitvector #())) => #t)
+ (check (bitvector= (vector->bitvector #(1 0 #t #f))
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector= (vector->bitvector #(1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (vector->bitvector #(1 0 1 0) 1 3)
+ (bitvector 0 1))
+ => #t)
+ (check (bitvector-empty? (reverse-vector->bitvector #())) => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 #t #f))
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 2)
+ (bitvector 0 1))
+ => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 1 3)
+ (bitvector 1 0))
+ => #t)
+
+ ;;; strings
+
+ (check (bitvector->string (bitvector 1 0 1 0)) => "#*1010")
+ (check (bitvector->string (bitvector)) => "#*")
+ (check (bitvector= (string->bitvector "#*1010") (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector-empty? (string->bitvector "#*")) => #t)
+ (check (string->bitvector "") => #f)
+ (check (string->bitvector "1010") => #f)
+ (check (string->bitvector "#") => #f)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (string->bitvector (bitvector->string bvec))
+ bvec)
+ => #t))
+
+ ;;; integers
+
+ ;; Remember, these are little-endian!
+ (check (bitvector->integer (bitvector 0 1 0 1)) => #xa)
+ (check (bitvector->integer (bitvector 1 0 1 0 1 1 0 1)) => #xb5)
+ (check (bitvector= (integer->bitvector #xa) (bitvector 0 1 0 1)) => #t)
+ (check (bitvector= (integer->bitvector #xb5) (bitvector 1 0 1 0 1 1 0 1))
+ => #t)
+ (check (bitvector= (integer->bitvector #xb5 4) (bitvector 1 0 1 0)) => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/fields.scm b/test-suite/tests/srfi-178-test/fields.scm
new file mode 100644
index 000000000..bde5f4aaf
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/fields.scm
@@ -0,0 +1,98 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bit-field-operations)
+ (print-header "Checking bit field operations...")
+
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 0 4) => #t)
+ (check (bitvector-field-any? (bitvector 0 0 0 0) 0 4) => #f)
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 1 3) => #t)
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 2 4) => #f)
+
+ (check (bitvector-field-every? (make-bitvector 4 1) 0 4) => #t)
+ (check (bitvector-field-every? (bitvector 1 1 1 0) 0 4) => #f)
+ (check (bitvector-field-every? (bitvector 1 1 0 0) 0 2) => #t)
+ (check (bitvector-field-every? (bitvector 1 1 0 0) 2 4) => #f)
+
+ (check (bitvector= (bitvector-field-clear (make-bitvector 4 1) 0 2)
+ (bitvector 0 0 1 1))
+ => #t)
+ (let ((bvec (make-bitvector 4 1)))
+ (check (bitvector= (begin (bitvector-field-clear! bvec 0 2) bvec)
+ (bitvector 0 0 1 1))
+ => #t))
+ (check (bitvector= (bitvector-field-set (make-bitvector 4 0) 0 2)
+ (bitvector 1 1 0 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check (bitvector= (begin (bitvector-field-set! bvec 0 2) bvec)
+ (bitvector 1 1 0 0))
+ => #t))
+
+ ;;; replace-same and replace
+
+ (check
+ (bitvector=
+ (bitvector-field-replace-same (make-bitvector 4 0)
+ (make-bitvector 4 1)
+ 1
+ 3)
+ (bitvector 0 1 1 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check
+ (bitvector= (begin
+ (bitvector-field-replace-same! bvec
+ (make-bitvector 4 1)
+ 1
+ 3)
+ bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+ (check
+ (bitvector=
+ (bitvector-field-replace (make-bitvector 4 0) (bitvector 1 0 0 0) 1 3)
+ (bitvector 0 1 0 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check
+ (bitvector= (begin
+ (bitvector-field-replace! bvec (make-bitvector 4 1) 1 3)
+ bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+
+ ;;; rotate
+
+ (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) 1 0 4)
+ (bitvector 0 0 1 1))
+ => #t)
+ (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) -1 0 4)
+ (bitvector 1 1 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) 2 2 6)
+ (bitvector 1 0 1 0 0 1 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) -3 2 6)
+ (bitvector 1 0 1 1 0 0 1 0))
+ => #t)
+
+ ;;; flip
+
+ (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 0 4)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 2 4)
+ (bitvector 0 1 1 0))
+ => #t)
+ (let ((bvec (bitvector 0 1 0 1)))
+ (check (bitvector= (begin (bitvector-field-flip! bvec 0 4) bvec)
+ (bitvector 1 0 1 0))
+ => #t))
+ (let ((bvec (bitvector 0 1 0 1)))
+ (check (bitvector= (begin (bitvector-field-flip! bvec 2 4) bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/gen-accum.scm b/test-suite/tests/srfi-178-test/gen-accum.scm
new file mode 100644
index 000000000..ab14912f3
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/gen-accum.scm
@@ -0,0 +1,72 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-generators-and-accumulators)
+ (define test-bvec (bitvector 1 0 1 1 0 1 0 1))
+ (print-header "Checking generators and accumulators...")
+
+ ;;; Generators
+
+ (check (eof-object? ((make-bitvector/int-generator (bitvector)))) => #t)
+ (check (eof-object? ((make-bitvector/bool-generator (bitvector)))) => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ g) (values (g) g))
+ (bitvector-length test-bvec)
+ (make-bitvector/int-generator test-bvec))
+ test-bvec)
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ g) (values (g) g))
+ (bitvector-length test-bvec)
+ (make-bitvector/bool-generator test-bvec))
+ test-bvec)
+ => #t)
+
+ ;;; Accumulator
+
+ (check (bitvector-empty? ((make-bitvector-accumulator) (eof-object)))
+ => #t)
+ ;; Accumulate integers.
+ (check (bitvector= test-bvec
+ (let ((acc (make-bitvector-accumulator)))
+ (bitvector-for-each/int acc test-bvec)
+ (acc (eof-object))))
+ => #t)
+ ;; Accumulate booleans.
+ (check (bitvector= test-bvec
+ (let ((acc (make-bitvector-accumulator)))
+ (bitvector-for-each/bool acc test-bvec)
+ (acc (eof-object))))
+ => #t)
+
+ ;;; Generator/accumulator identities
+
+ ;; Accumulating generated values yields the original structure.
+ (check (bitvector=
+ (let ((gen (make-bitvector/int-generator test-bvec))
+ (acc (make-bitvector-accumulator)))
+ (generator-for-each acc gen)
+ (acc (eof-object)))
+ test-bvec)
+ => #t)
+
+ ;; Generating accumulated values yields the original values.
+ ;; Integer generator.
+ (let ((lis (bitvector->list/int test-bvec)))
+ (check (equal?
+ (let ((acc (make-bitvector-accumulator)))
+ (for-each acc lis)
+ (generator->list
+ (make-bitvector/int-generator (acc (eof-object)))))
+ lis)
+ => #t))
+ ;; Boolean generator.
+ (let ((lis (bitvector->list/bool test-bvec)))
+ (check (equal?
+ (let ((acc (make-bitvector-accumulator)))
+ (for-each acc lis)
+ (generator->list
+ (make-bitvector/bool-generator (acc (eof-object)))))
+ lis)
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/iterators.scm b/test-suite/tests/srfi-178-test/iterators.scm
new file mode 100644
index 000000000..239572b6a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/iterators.scm
@@ -0,0 +1,150 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-iterators)
+ (print-header "Checking iteration...")
+
+ ;;; take & take-right
+
+ (check (bitvector= (bitvector-take (bitvector 1 0 1 0) 2)
+ (bitvector 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-take (bitvector 1 0) 0)) => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-take bvec (bitvector-length bvec))
+ bvec)
+ => #t)
+ (check (bitvector= (bitvector-take-right bvec (bitvector-length bvec))
+ bvec)
+ => #t))
+ (check (bitvector= (bitvector-take-right (bitvector 1 0 1 0) 3)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-take-right (bitvector 1 0) 0)) => #t)
+
+ ;;; drop & drop-right
+
+ (check (bitvector= (bitvector-drop (bitvector 1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector-empty? (bitvector-drop bvec (bitvector-length bvec)))
+ => #t)
+ (check (bitvector= (bitvector-drop bvec 0) bvec) => #t)
+ (check (bitvector= (bitvector-drop-right bvec 0) bvec) => #t)
+ (check (bitvector-empty?
+ (bitvector-drop-right bvec (bitvector-length bvec)))
+ => #t))
+ (check (bitvector= (bitvector-drop-right (bitvector 1 0 1 0) 1)
+ (bitvector 1 0 1))
+ => #t)
+
+ ;;; segment
+
+ (check (bitvector= (car (bitvector-segment (bitvector 1 0 1 0) 2))
+ (bitvector 1 0))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-concatenate (bitvector-segment bvec 1))
+ bvec)
+ => #t))
+\f
+ ;;; fold
+
+ (check (bitvector-fold/int + 0 (bitvector)) => 0)
+ (check (bitvector-fold/int + 0 (bitvector 1)) => 1)
+ (check (bitvector-fold/bool proc-or #f (bitvector)) => #f)
+ (check (bitvector-fold/bool proc-or #f (bitvector #t)) => #t)
+ (check (bitvector-fold-right/int + 0 (bitvector)) => 0)
+ (check (bitvector-fold-right/int + 0 (bitvector 1)) => 1)
+ (check (bitvector-fold-right/bool proc-or #f (bitvector)) => #f)
+ (check (bitvector-fold-right/bool proc-or #f (bitvector #t)) => #t)
+
+ ;;; map
+
+ (check (bitvector-empty? (bitvector-map/int values (bitvector))) => #t)
+ (check (bitvector= (bitvector-map/int (constantly 1) (bitvector 0 0 1))
+ (bitvector 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-map/int (lambda (a b c) b)
+ (bitvector 1 0 0)
+ (bitvector 0 1 0)
+ (bitvector 0 0 1))
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-map/bool values (bitvector))) => #t)
+ (check (bitvector= (bitvector-map/bool (constantly #t)
+ (bitvector #f #f #t))
+ (bitvector #t #t #t))
+ => #t)
+ (check (bitvector= (bitvector-map/bool (lambda (a b c) b)
+ (bitvector #t #f #f)
+ (bitvector #f #t #f)
+ (bitvector #f #f #t))
+ (bitvector #f #t #f))
+ => #t)
+
+ ;;; map!
+
+ (check (let ((bvec (bitvector)))
+ (bitvector-map!/int values bvec)
+ (bitvector-empty? bvec))
+ => #t)
+ (check (let ((bvec (bitvector 1 0 1 0)))
+ (bitvector-map!/int (constantly 1) bvec)
+ (bitvector= bvec (bitvector 1 1 1 1)))
+ => #t)
+ (check (let ((bvec1 (bitvector 1 0 0))
+ (bvec2 (bitvector 0 1 0))
+ (bvec3 (bitvector 0 0 1)))
+ (bitvector-map!/int (lambda (a b c) b) bvec1 bvec2 bvec3)
+ (bitvector= bvec1 bvec2))
+ => #t)
+ (check (let ((bvec (bitvector)))
+ (bitvector-map!/bool values bvec)
+ (bitvector-empty? bvec))
+ => #t)
+ (check (let ((bvec (bitvector #t #f #t #f)))
+ (bitvector-map!/bool (constantly #t) bvec)
+ (bitvector= bvec (bitvector #t #t #t #t)))
+ => #t)
+ (check (let ((bvec1 (bitvector #t #f #f))
+ (bvec2 (bitvector #f #t #f))
+ (bvec3 (bitvector #f #f #t)))
+ (bitvector-map!/bool (lambda (a b c) b) bvec1 bvec2 bvec3)
+ (bitvector= bvec1 bvec2))
+ => #t)
+
+\f
+ ;;; map->list
+
+ (check (bitvector-map->list/bool values (bitvector)) => '())
+ (check (bitvector-map->list/int (constantly 1) (bitvector 1 0 0)) => '(1 1 1))
+ (check (bitvector-map->list/int list (bitvector 1 0) (bitvector 0 1))
+ => '((1 0) (0 1)))
+ (check (bitvector-map->list/bool values (bitvector)) => '())
+ (check (bitvector-map->list/bool (constantly #t) (bitvector 1 0 0))
+ => '(#t #t #t))
+ (check (bitvector-map->list/bool list (bitvector 1 0) (bitvector 0 1))
+ => '((#t #f) (#f #t)))
+
+ ;;; for-each
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (let ((c 0))
+ (bitvector-for-each/int (lambda (_) (set! c (+ c 1))) bvec)
+ c)
+ => (bitvector-length bvec))
+ (check (let ((lis '()))
+ (bitvector-for-each/int (lambda (b) (set! lis (cons b lis))) bvec)
+ lis)
+ => (reverse-bitvector->list/int bvec))
+ (check (let ((c 0))
+ (bitvector-for-each/bool (lambda (_) (set! c (+ c 1))) bvec)
+ c)
+ => (bitvector-length bvec))
+ (check (let ((lis '()))
+ (bitvector-for-each/bool (lambda (b) (set! lis (cons b lis))) bvec)
+ lis)
+ => (reverse-bitvector->list/bool bvec)))
+)
diff --git a/test-suite/tests/srfi-178-test/logic-ops.scm b/test-suite/tests/srfi-178-test/logic-ops.scm
new file mode 100644
index 000000000..e68fdebda
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/logic-ops.scm
@@ -0,0 +1,125 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bitwise-operations)
+ (define test-bvec1 (bitvector 1 0 1 0))
+ (define test-bvec2 (bitvector 1 1 0 0))
+ (define test-bvec3 (bitvector 0 0 1 1))
+ (print-header "Checking bitwise operations...")
+
+ ;;; not
+
+ (check (bitvector= (bitvector-not test-bvec1) (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-not (bitvector-not test-bvec1))
+ test-bvec1)
+ => #t)
+
+ ;;; Associative operations
+
+ (check (bitvector= (bitvector-and test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector= (bitvector-ior test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 1 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-xor test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-eqv test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 1 0 1))
+ => #t)
+
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-and! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 0 0 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-ior! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 1 1 1 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-xor! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 1 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-eqv! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 1 0 1))
+ => #t))
+\f
+ ;;; Non-associative binary operations
+
+ (check (bitvector= (bitvector-nand test-bvec1 test-bvec2)
+ (bitvector 0 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-nor test-bvec1 test-bvec2)
+ (bitvector 0 0 0 1))
+ => #t)
+ (check (bitvector= (bitvector-andc1 test-bvec1 test-bvec2)
+ (bitvector 0 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector-andc2 test-bvec1 test-bvec2)
+ (bitvector 0 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-orc1 test-bvec1 test-bvec2)
+ (bitvector 1 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-orc2 test-bvec1 test-bvec2)
+ (bitvector 1 0 1 1))
+ => #t)
+
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-nand! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 1 1 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-nor! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 0 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-andc1! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-andc2! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 0 1 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-orc1! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 1 1 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-orc2! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 1 0 1 1))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/mutators.scm b/test-suite/tests/srfi-178-test/mutators.scm
new file mode 100644
index 000000000..281a67cdd
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/mutators.scm
@@ -0,0 +1,79 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-mutators)
+ (print-header "Checking mutators...")
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-set! bvec 1 1) bvec)
+ (bitvector 1 1 1 0))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-set! bvec 0 #f) bvec)
+ (bitvector 0 0 1 0))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-swap! bvec 0 1) bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+
+ ;;; reverse!
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec) bvec)
+ (bitvector 0 1 0 1))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec 2) bvec)
+ (bitvector 1 0 0 1))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec 1 3) bvec)
+ (bitvector 1 1 0 0))
+ => #t))
+
+ ;;; copy!
+
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 0 (bitvector 1 0)) bvec)
+ (bitvector 1 0 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 1 0) 1) bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 0 1) 0 2) bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+
+ ;;; reverse-copy!
+
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 0 (bitvector 1 0))
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 0 1) 1)
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 1 1) 0 2)
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/quasi-ints.scm b/test-suite/tests/srfi-178-test/quasi-ints.scm
new file mode 100644
index 000000000..8f59ff1cc
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-ints.scm
@@ -0,0 +1,41 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-quasi-integer-operations)
+ (print-header "Checking quasi-integer operations...")
+
+ (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) 2 0)
+ (bitvector 1 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) -2 #t)
+ (bitvector 1 1 1 0))
+ => #t)
+
+ (check (bitvector-count 1 (make-bitvector 8 1)) => 8)
+ (check (bitvector-count #t (make-bitvector 8 0)) => 0)
+ (check (bitvector-count 1 (bitvector 1 1 0 1 1 0 0 0)) => 4)
+
+ (check (bitvector-count-run 1 (make-bitvector 8 1) 0) => 8)
+ (check (bitvector-count-run #t (make-bitvector 8 0) 4) => 0)
+ (check (bitvector-count-run 1 (bitvector 0 1 1 1) 1) => 3)
+
+ (let ((then-bvec (bitvector 1 0 1 0))
+ (else-bvec (bitvector 0 0 0 1)))
+ (check
+ (bitvector= (bitvector-if (make-bitvector 4 1) then-bvec else-bvec)
+ then-bvec)
+ => #t)
+ (check
+ (bitvector= (bitvector-if (make-bitvector 4 0) then-bvec else-bvec)
+ else-bvec)
+ => #t))
+ (check (bitvector= (bitvector-if (bitvector 1 1 0 0)
+ (bitvector 0 1 1 1)
+ (bitvector 0 0 1 0))
+ (bitvector 0 1 1 0))
+ => #t)
+
+ (check (bitvector-first-bit 0 (make-bitvector 4 0)) => 0)
+ (check (bitvector-first-bit #t (bitvector 0 0 1 0)) => 2)
+ (check (bitvector-first-bit #f (make-bitvector 4 1)) => -1)
+)
diff --git a/test-suite/tests/srfi-178-test/quasi-string.scm b/test-suite/tests/srfi-178-test/quasi-string.scm
new file mode 100644
index 000000000..2da77466a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-string.scm
@@ -0,0 +1,62 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-quasi-string-ops)
+ (print-header "Checking quasi-string operations...")
+
+ ;;; prefix & suffix
+
+ (check (bitvector-prefix-length (bitvector 1 0 0) (bitvector 1 0 1)) => 2)
+ (check (bitvector-prefix-length (bitvector) (bitvector 1 0 1)) => 0)
+ (let ((bvec (bitvector 1 0 1)))
+ (check (= (bitvector-prefix-length bvec bvec) (bitvector-length bvec))
+ => #t)
+ (check (= (bitvector-suffix-length bvec bvec) (bitvector-length bvec))
+ => #t))
+ (check (bitvector-suffix-length (bitvector 1 0 0) (bitvector 0 0 0)) => 2)
+ (check (bitvector-suffix-length (bitvector) (bitvector 1 0 1)) => 0)
+
+ (check (bitvector-prefix? (bitvector 1) (bitvector 1 0)) => #t)
+ (check (bitvector-prefix? (bitvector 0) (bitvector 1 0)) => #f)
+ (check (bitvector-suffix? (bitvector 0) (bitvector 1 0)) => #t)
+ (check (bitvector-suffix? (bitvector 1) (bitvector 1 0)) => #f)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector-prefix? bvec bvec) => #t)
+ (check (bitvector-suffix? bvec bvec) => #t))
+
+ ;;; pad & trim
+
+ (check (bitvector=
+ (bitvector-pad 0 (bitvector 1) 4)
+ (bitvector 0 0 0 1))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-pad 0 bvec (bitvector-length bvec))
+ bvec)
+ => #t)
+ (check (bitvector= (bitvector-pad-right 0 bvec (bitvector-length bvec))
+ bvec)
+ => #t))
+ (check (bitvector=
+ (bitvector-pad-right 0 (bitvector 1) 4)
+ (bitvector 1 0 0 0))
+ => #t)
+ (check (bitvector= (bitvector-trim 0 (bitvector 0 0 0 1))
+ (bitvector 1))
+ => #t)
+ (check (bitvector= (bitvector-trim 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 0 0))
+ (bitvector 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-both 1 (bitvector 1 0 1))
+ (bitvector 0))
+ => #t)
+ (check (bitvector= (bitvector-trim-both 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/selectors.scm b/test-suite/tests/srfi-178-test/selectors.scm
new file mode 100644
index 000000000..f37894702
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/selectors.scm
@@ -0,0 +1,13 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-selectors)
+ (print-header "Checking selectors...")
+
+ (check (bitvector-length (bitvector)) => 0)
+ (check (bitvector-length (bitvector 1 0 1 0)) => 4)
+ (check (bitvector-ref/int (bitvector 1 0 1 0) 0) => 1)
+ (check (bitvector-ref/int (bitvector 1 0 1 0) 3) => 0)
+ (check (bitvector-ref/bool (bitvector 1 0 1 0) 0) => #t)
+ (check (bitvector-ref/bool (bitvector 1 0 1 0) 3) => #f))
+
diff --git a/test-suite/tests/srfi-178.test b/test-suite/tests/srfi-178.test
new file mode 100644
index 000000000..4ab6c6708
--- /dev/null
+++ b/test-suite/tests/srfi-178.test
@@ -0,0 +1,147 @@
+;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe
+
+;;; 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.
+
+(import (scheme base))
+(import (scheme write))
+(import (srfi 178))
+
+;;; START Guile-specific customizations to use Guile's own test runner.
+(import (srfi 64))
+
+(define report (@@ (test-suite lib) report))
+
+(define-syntax check
+ (syntax-rules (=>)
+ ((check expr => expected)
+ (test-equal expected expr))))
+
+(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))
+;;; END Guile-specific customizations to use Guile's own test runner.
+
+(cond-expand
+ ((library (srfi 158))
+ (import (only (srfi 158) generator-for-each generator->list)))
+ (else
+ (begin
+ (define (generator-for-each proc g)
+ (let ((v (g)))
+ (unless (eof-object? v)
+ (proc v)
+ (generator-for-each proc g))))
+
+ (define (generator->list g)
+ (let ((v (g)))
+ (if (eof-object? v)
+ '()
+ (cons v (generator->list g))))))))
+
+(define (print-header message)
+ (newline)
+ (display ";;; ")
+ (display message)
+ (newline))
+
+;;;; Utility
+
+(define (proc-or a b) (or a b))
+
+(define (constantly x) (lambda (_) x))
+
+(define bitvector= bitvector=?)
+
+(define (check-bit-conversions)
+ (print-header "Checking bit conversions...")
+
+ (check (bit->integer 0) => 0)
+ (check (bit->integer 1) => 1)
+ (check (bit->integer #f) => 0)
+ (check (bit->integer #t) => 1)
+ (check (bit->boolean 0) => #f)
+ (check (bit->boolean 1) => #t)
+ (check (bit->boolean #f) => #f)
+ (check (bit->boolean #t) => #t))
+
+(define (check-predicates)
+ (print-header "Checking predicates...")
+
+ (check (bitvector? (bitvector)) => #t)
+ (check (bitvector? (make-bitvector 1)) => #t)
+
+ (check (bitvector-empty? (bitvector)) => #t)
+ (check (bitvector-empty? (bitvector 1)) => #f)
+
+ (check (bitvector= (bitvector) (bitvector)) => #t)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 0)) => #t)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 1)) => #f)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0)) => #f)
+ (check (bitvector= (bitvector 1 0 0)
+ (bitvector 1 0 0)
+ (bitvector 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector 1 0 0)
+ (bitvector 1 0 1)
+ (bitvector 1 0 0))
+ => #f))
+
+(include "srfi-178-test/constructors.scm")
+(include "srfi-178-test/iterators.scm")
+(include "srfi-178-test/selectors.scm")
+(include "srfi-178-test/conversions.scm")
+(include "srfi-178-test/mutators.scm")
+(include "srfi-178-test/quasi-string.scm")
+(include "srfi-178-test/gen-accum.scm")
+(include "srfi-178-test/logic-ops.scm")
+(include "srfi-178-test/quasi-ints.scm")
+(include "srfi-178-test/fields.scm")
+
+(define (check-all)
+ ;; Check predicates, bitvector conversions, and selectors first,
+ ;; since they're used extensively in later tests.
+ (check-predicates)
+ (check-bitvector-conversions)
+ (check-selectors)
+ (check-bit-conversions)
+ (check-constructors)
+ (check-iterators)
+ (check-quasi-string-ops)
+ (check-mutators)
+ (check-bitwise-operations)
+ (check-quasi-integer-operations)
+ (check-bit-field-operations))
+
+(test-with-runner (guile-test-runner)
+ (test-begin "SRFI 178")
+ (check-all)
+ (test-end "SRFI 178"))
--
2.41.0
next prev parent reply other threads:[~2023-12-04 21:45 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-12-04 21:45 [PATCH v7 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 08/16] module: Add SRFI 126 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 09/16] module: Add SRFI 128 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 10/16] module: Add (scheme comparator) Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 11/16] module: Add (scheme sort) Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 12/16] module: Add SRFI 125 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 13/16] module: Add SRFI 151 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 14/16] module: Add SRFI 160 Maxim Cournoyer
2023-12-04 21:45 ` Maxim Cournoyer [this message]
2023-12-04 21:45 ` [PATCH v7 16/16] module: Add SRFI 209 Maxim Cournoyer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20231204215143.3146-16-maxim.cournoyer@gmail.com \
--to=maxim.cournoyer@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).