From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v4 10/10] module: Add SRFI 160.
Date: Wed, 22 Nov 2023 22:25:21 -0500 [thread overview]
Message-ID: <20231123032659.5637-11-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231123032659.5637-1-maxim.cournoyer@gmail.com>
* module/srfi/srfi-160/base.sld
* module/srfi/srfi-160/base/c128-vector2list.scm
* module/srfi/srfi-160/base/c64-vector2list.scm
* module/srfi/srfi-160/base/complex.scm
* module/srfi/srfi-160/base/f32-vector2list.scm
* module/srfi/srfi-160/base/f64-vector2list.scm
* module/srfi/srfi-160/base/r7rec.scm
* module/srfi/srfi-160/base/s16-vector2list.scm
* module/srfi/srfi-160/base/s32-vector2list.scm
* module/srfi/srfi-160/base/s64-vector2list.scm
* module/srfi/srfi-160/base/s8-vector2list.scm
* module/srfi/srfi-160/base/u16-vector2list.scm
* module/srfi/srfi-160/base/u32-vector2list.scm
* module/srfi/srfi-160/base/u64-vector2list.scm
* module/srfi/srfi-160/base/u8-vector2list.scm
* module/srfi/srfi-160/base/valid.scm
* module/srfi/srfi-160/c128-impl.scm
* module/srfi/srfi-160/c128.sld
* module/srfi/srfi-160/c64-impl.scm
* module/srfi/srfi-160/c64.sld
* module/srfi/srfi-160/f32-impl.scm
* module/srfi/srfi-160/f32.sld
* module/srfi/srfi-160/f64-impl.scm
* module/srfi/srfi-160/f64.sld
* module/srfi/srfi-160/s16-impl.scm
* module/srfi/srfi-160/s16.sld
* module/srfi/srfi-160/s32-impl.scm
* module/srfi/srfi-160/s32.sld
* module/srfi/srfi-160/s64-impl.scm
* module/srfi/srfi-160/s64.sld
* module/srfi/srfi-160/s8-impl.scm
* module/srfi/srfi-160/s8.sld
* module/srfi/srfi-160/u16-impl.scm
* module/srfi/srfi-160/u16.sld
* module/srfi/srfi-160/u32-impl.scm
* module/srfi/srfi-160/u32.sld
* module/srfi/srfi-160/u64-impl.scm
* module/srfi/srfi-160/u64.sld
* module/srfi/srfi-160/u8-impl.scm
* module/srfi/srfi-160/u8.sld
* test-suite/tests/srfi-160-base-test.scm
* test-suite/tests/srfi-160-base.test
* test-suite/tests/srfi-160-test.scm
* test-suite/tests/srfi-160.test: New files.
* doc/ref/srfi-modules.texi (SRFI 160 Abstract): New subsection.
* test-suite/Makefile.am (SCM_TESTS): Register tests/srfi-160-base.test
and tests/srfi-160.test.
(EXTRA_DIST): Register tests/srfi-160-base-test.scm and
tests/srfi-160-test.scm.
---
(no changes since v1)
am/bootstrap.am | 40 ++
doc/ref/guile.texi | 2 +-
doc/ref/srfi-modules.texi | 638 +++++++++++++++++-
module/srfi/srfi-160/base.sld | 67 ++
.../srfi/srfi-160/base/c128-vector2list.scm | 18 +
module/srfi/srfi-160/base/c64-vector2list.scm | 18 +
module/srfi/srfi-160/base/complex.scm | 111 +++
module/srfi/srfi-160/base/f32-vector2list.scm | 18 +
module/srfi/srfi-160/base/f64-vector2list.scm | 18 +
module/srfi/srfi-160/base/r7rec.scm | 11 +
module/srfi/srfi-160/base/s16-vector2list.scm | 18 +
module/srfi/srfi-160/base/s32-vector2list.scm | 18 +
module/srfi/srfi-160/base/s64-vector2list.scm | 18 +
module/srfi/srfi-160/base/s8-vector2list.scm | 18 +
module/srfi/srfi-160/base/u16-vector2list.scm | 18 +
module/srfi/srfi-160/base/u32-vector2list.scm | 18 +
module/srfi/srfi-160/base/u64-vector2list.scm | 18 +
module/srfi/srfi-160/base/u8-vector2list.scm | 18 +
module/srfi/srfi-160/base/valid.scm | 26 +
module/srfi/srfi-160/c128-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/c128.sld | 48 ++
module/srfi/srfi-160/c64-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/c64.sld | 48 ++
module/srfi/srfi-160/f32-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/f32.sld | 48 ++
module/srfi/srfi-160/f64-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/f64.sld | 48 ++
module/srfi/srfi-160/s16-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/s16.sld | 48 ++
module/srfi/srfi-160/s32-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/s32.sld | 48 ++
module/srfi/srfi-160/s64-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/s64.sld | 48 ++
module/srfi/srfi-160/s8-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/s8.sld | 48 ++
module/srfi/srfi-160/u16-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/u16.sld | 48 ++
module/srfi/srfi-160/u32-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/u32.sld | 48 ++
module/srfi/srfi-160/u64-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/u64.sld | 48 ++
module/srfi/srfi-160/u8-impl.scm | 600 ++++++++++++++++
module/srfi/srfi-160/u8.sld | 48 ++
test-suite/Makefile.am | 4 +
test-suite/tests/srfi-160-base-test.scm | 167 +++++
test-suite/tests/srfi-160-base.test | 47 ++
test-suite/tests/srfi-160-test.scm | 262 +++++++
test-suite/tests/srfi-160.test | 48 ++
48 files changed, 9413 insertions(+), 2 deletions(-)
create mode 100644 module/srfi/srfi-160/base.sld
create mode 100644 module/srfi/srfi-160/base/c128-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/c64-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/complex.scm
create mode 100644 module/srfi/srfi-160/base/f32-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/f64-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/r7rec.scm
create mode 100644 module/srfi/srfi-160/base/s16-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/s32-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/s64-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/s8-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/u16-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/u32-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/u64-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/u8-vector2list.scm
create mode 100644 module/srfi/srfi-160/base/valid.scm
create mode 100644 module/srfi/srfi-160/c128-impl.scm
create mode 100644 module/srfi/srfi-160/c128.sld
create mode 100644 module/srfi/srfi-160/c64-impl.scm
create mode 100644 module/srfi/srfi-160/c64.sld
create mode 100644 module/srfi/srfi-160/f32-impl.scm
create mode 100644 module/srfi/srfi-160/f32.sld
create mode 100644 module/srfi/srfi-160/f64-impl.scm
create mode 100644 module/srfi/srfi-160/f64.sld
create mode 100644 module/srfi/srfi-160/s16-impl.scm
create mode 100644 module/srfi/srfi-160/s16.sld
create mode 100644 module/srfi/srfi-160/s32-impl.scm
create mode 100644 module/srfi/srfi-160/s32.sld
create mode 100644 module/srfi/srfi-160/s64-impl.scm
create mode 100644 module/srfi/srfi-160/s64.sld
create mode 100644 module/srfi/srfi-160/s8-impl.scm
create mode 100644 module/srfi/srfi-160/s8.sld
create mode 100644 module/srfi/srfi-160/u16-impl.scm
create mode 100644 module/srfi/srfi-160/u16.sld
create mode 100644 module/srfi/srfi-160/u32-impl.scm
create mode 100644 module/srfi/srfi-160/u32.sld
create mode 100644 module/srfi/srfi-160/u64-impl.scm
create mode 100644 module/srfi/srfi-160/u64.sld
create mode 100644 module/srfi/srfi-160/u8-impl.scm
create mode 100644 module/srfi/srfi-160/u8.sld
create mode 100644 test-suite/tests/srfi-160-base-test.scm
create mode 100644 test-suite/tests/srfi-160-base.test
create mode 100644 test-suite/tests/srfi-160-test.scm
create mode 100644 test-suite/tests/srfi-160.test
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 95deec208..6310762d0 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -355,6 +355,19 @@ SOURCES = \
srfi/srfi-126.scm \
srfi/srfi-128.sld \
srfi/srfi-151.sld \
+ srfi/srfi-160/base.sld \
+ srfi/srfi-160/c64.sld \
+ srfi/srfi-160/c128.sld \
+ srfi/srfi-160/f32.sld \
+ srfi/srfi-160/f64.sld \
+ srfi/srfi-160/s8.sld \
+ srfi/srfi-160/s16.sld \
+ srfi/srfi-160/s32.sld \
+ srfi/srfi-160/s64.sld \
+ srfi/srfi-160/u8.sld \
+ srfi/srfi-160/u16.sld \
+ srfi/srfi-160/u32.sld \
+ srfi/srfi-160/u64.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -450,6 +463,33 @@ NOCOMP_SOURCES = \
srfi/srfi-151/bitwise-33.scm \
srfi/srfi-151/bitwise-60.scm \
srfi/srfi-151/bitwise-other.scm \
+ srfi/srfi-160/base/c64-vector2list.scm \
+ srfi/srfi-160/base/c128-vector2list.scm \
+ srfi/srfi-160/base/complex.scm \
+ srfi/srfi-160/base/f32-vector2list.scm \
+ srfi/srfi-160/base/f64-vector2list.scm \
+ srfi/srfi-160/base/r7rec.scm \
+ srfi/srfi-160/base/s8-vector2list.scm \
+ srfi/srfi-160/base/s16-vector2list.scm \
+ srfi/srfi-160/base/s32-vector2list.scm \
+ srfi/srfi-160/base/s64-vector2list.scm \
+ srfi/srfi-160/base/u8-vector2list.scm \
+ srfi/srfi-160/base/u16-vector2list.scm \
+ srfi/srfi-160/base/u32-vector2list.scm \
+ srfi/srfi-160/base/u64-vector2list.scm \
+ srfi/srfi-160/base/valid.scm \
+ srfi/srfi-160/c64-impl.scm \
+ srfi/srfi-160/c128-impl.scm \
+ srfi/srfi-160/f32-impl.scm \
+ srfi/srfi-160/f64-impl.scm \
+ srfi/srfi-160/s8-impl.scm \
+ srfi/srfi-160/s16-impl.scm \
+ srfi/srfi-160/s32-impl.scm \
+ srfi/srfi-160/s64-impl.scm \
+ srfi/srfi-160/u8-impl.scm \
+ srfi/srfi-160/u16-impl.scm \
+ srfi/srfi-160/u32-impl.scm \
+ srfi/srfi-160/u64-impl.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 f94c10209..3226ee53b 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,7 +24,7 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-Additionally, the documentation of the 125, 126, 128, and 151 SRFI
+Additionally, the documentation of the 125, 126, 128, 151 and 160 SRFI
modules is adapted from their specification text, which is made
available under the following Expat license:
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index b6782f183..26727c08a 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -3,7 +3,7 @@
@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
@c Free Software Foundation, Inc.
@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer
-@c Copyright (C) 2015-2016 John Cowan
+@c Copyright (C) 2015-2016, 2018 John Cowan
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -8229,6 +8229,642 @@ Return a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI
@end lisp
@end deffn
+@node SRFI 160
+@subsection SRFI 160: Homogeneous numeric vector libraries
+@cindex SRFI 160
+
+@node SRFI 160 Abstract
+@subsubsection SRFI 160 Abstract
+
+This SRFI describes a set of operations on SRFI 4 homogeneous vector
+types (plus a few additional types) that are closely analogous to the
+vector operations library,
+@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}. An
+external representation is specified which may be supported by the
+@code{read} and @code{write} procedures and by the program parser so
+that programs can contain references to literal homogeneous vectors.
+
+@node SRFI 160 Rationale
+@subsubsection SRFI 160 Rationale
+
+Like lists, Scheme vectors are a heterogeneous datatype which impose no
+restriction on the type of the elements. This generality is not needed
+for applications where all the elements are of the same type. The use
+of Scheme vectors is not ideal for such applications because, in the
+absence of a compiler with a fancy static analysis, the representation
+will typically use some form of boxing of the elements which means low
+space efficiency and slower access to the elements. Moreover,
+homogeneous vectors are convenient for interfacing with low-level
+libraries (e.g. binary block I/O) and to interface with foreign
+languages which support homogeneous vectors. Finally, the use of
+homogeneous vectors allows certain errors to be caught earlier.
+
+This SRFI specifies a set of homogeneous vector datatypes which cover
+the most practical cases, that is, where the type of the elements is
+numeric (exact integer or inexact real or complex) and the precision and
+representation is efficiently implemented on the hardware of most
+current computer architectures (8, 16, 32 and 64 bit integers, either
+signed or unsigned, and 32 and 64 bit floating point numbers).
+
+This SRFI extends @url{https://srfi.schemers.org/srfi-4/srfi-4.html,
+SRFI 4} by providing the additional @code{c64vector} and
+@code{c128vector} types, and by providing analogues for almost all of
+the heterogeneous vector procedures of
+@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}. There
+are some additional procedures, most of which are closely analogous to
+the string procedures of
+@url{https://srfi.schemers.org/srfi-152/srfi-152.html, SRFI 152}
+
+Note that there are no conversions between homogeneous vectors and
+strings in this SRFI. In addition, there is no support for u1vectors
+(bitvectors) provided, not because they are not useful, but because they
+are different enough in both specification and implementation to be put
+into a future SRFI of their own.
+
+@node SRFI 160 Datatypes
+@subsubsection SRFI 160 Datatypes
+
+There are eight datatypes of exact integer homogeneous vectors (which will
+be called integer vectors):
+
+@deffn {Scheme Datatypes} s8vector
+
+Signed exact integer in the range -2@sup{7} to 2@sup{7}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} u8vector
+
+Unsigned exact integer in the range 0 to 2@sup{8}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} s16vector
+
+Signed exact integer in the range -2@sup{15} to 2@sup{15}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} u16vector
+
+Unsigned exact integer in the range 0 to 2@sup{16}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} s32vector
+
+Signed exact integer in the range -2@sup{31} to 2@sup{31}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} u32vector
+
+Unsigned exact integer in the range 0 to 2@sup{32}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} s64vector
+
+Signed exact integer in the range -2@sup{63} to 2@sup{63}-1.
+@end deffn
+
+@deffn {Scheme Datatypes} u64vector
+
+Unsigned exact integer in the range 0 to 2@sup{64}-1.
+@end deffn
+
+All are part of SRFI 4.
+
+There are two datatypes of inexact real homogeneous vectors (which will
+be called float vectors):
+
+@deffn {Scheme Datatypes} f32vector
+
+Inexact real, typically 32 bits.
+@end deffn
+
+@deffn {Scheme Datatypes} f64vector
+
+Inexact real, typically 64 bits.
+@end deffn
+
+These are also part of SRFI 4.
+
+@code{f64vector}s must preserve at least as
+much precision and range as @code{f32vector}s.
+
+And there are two datatypes of inexact complex homogeneous vectors
+(which will be called complex vectors):
+
+@deffn {Scheme Datatypes} c64vector
+
+Inexact complex, typically 64 bits.
+@end deffn
+
+@deffn {Scheme Datatypes} c128vector
+
+Inexact complex, typically 128 bits.
+@end deffn
+
+These are @emph{not} part of SRFI 4.
+
+@code{c128vector}s must preserve at least as
+much precision and range as @code{c64vector}s.
+
+Each element of a homogeneous vector must be @i{valid}. That is, for an
+integer vector, it must be an exact integer within the inclusive range
+specified above; for a float vector, it must be an inexact real number;
+and for a complex vector, it must be an inexact complex number. It is
+an error to try to use a constructor or mutator to set an element to an
+invalid value.
+
+@node SRFI 160 Notation
+@subsubsection SRFI 160 Notation
+
+So as not to multiply the number of procedures described in this SRFI
+beyond necessity, a special notational convention is used. The
+description of the procedure @code{make-@@vector} is really shorthand
+for the descriptions of the twelve procedures @code{make-s8vector},
+@code{make-u8vector}, @dots{}, @code{make-c128vector}, all of which are
+exactly the same except that they construct different homogeneous vector
+types. Furthermore, except as otherwise noted, the semantics of each
+procedure are those of the corresponding SRFI 133 procedure, except that
+it is an error to attempt to insert an invalid value into a homogeneous
+vector. Consequently, only a brief description of each procedure is
+given, and SRFI 133 (or in some cases SRFI 152) should be consulted for
+the details. It is worth mentioning, however, that all the procedures
+that return one or more vectors (homogeneous or heterogeneous)
+invariably return newly allocated vectors specifically.
+
+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{}) -> @var{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
+@var{something}. If two values are returned, two types are specified.
+If @var{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}
+Must be a heterogeneous vector, i.e. it must satisfy the predicate
+@code{vector?}
+
+@item @var{@@vec}, @var{@@to}, @var{@@from}
+Must be a homogeneous vector, i.e. it must satisfy the predicate
+@code{@@vector?} In @code{@@vector-copy!} and
+@code{reverse-@@vector-copy!}, @var{@@to} is the destination and
+@var{@@from} is the source.
+
+@item @var{i}, @var{j}, @var{start}, @var{at}
+Must be an exact nonnegative integer less than the length of the
+@@vector. In @code{@@vector-copy!} and @code{reverse-@@vector-copy!},
+@var{at} refers to the destination and @var{start} to the source.
+
+@item @var{end}
+Must be an exact nonnegative integer not less than @var{start} and not
+greater than the length of the vector. 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}
+Must be a procedure taking one or more arguments, which returns (except
+as noted otherwise) exactly one value.
+
+@item @var{pred}
+Must be a procedure taking one or more arguments that returns one value,
+which is treated as a boolean.
+
+@item @var{=}
+Must be an equivalence procedure.
+
+@item @var{obj}, @var{seed}, @var{nil}
+Any Scheme object.
+
+@item @var{fill}, @var{value}
+Any number that is valid with respect to the @var{@@vec}.
+
+@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
+[start [end]]
+@end example
+
+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{}
+At least one @var{something} must be arguments.
+@end table
+
+@node SRFI 160 Packaging
+@subsubsection SRFI 160 Packaging
+
+For each @@vector type, there is a corresponding library named
+@code{(srfi@tie{}srfi-160@tie{}@@)}, and if an implementation provides a
+given type, it must provide that library as well. In addition, the
+library @code{(srfi@tie{}srfi-160@tie{}base)} provides a few basic
+procedures for all @@vector types. If a particular type is not provided
+by an implementation, then it is an error to call the corresponding
+procedures in this library.
+
+@quotation note
+There is no library named @code{(srfi@tie{}srfi-160)}.
+@end quotation
+
+@node SRFI 160 Procedures
+@subsubsection SRFI 160 Procedures
+
+The procedures shared with SRFI 4 are marked with [SRFI@tie{}4]. The
+procedures with the same semantics as SRFI 133 are marked with
+[SRFI@tie{}133] unless they are already marked with [SRFI@tie{}4]. The
+procedures analogous to SRFI 152 string procedures are marked with
+[SRFI@tie{}152].
+
+@subsubheading Constructors
+
+@deffn {Scheme Procedure} make-@@vector size [fill] -> @@vector [SRFI@tie{}4]
+
+Returns a @@vector whose length is @var{size}. If @var{fill} is provided,
+all the elements of the @@vector are initialized to it.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector value @dots{} -> @@vector [SRFI@tie{}4]
+
+Returns a @@vector initialized with @var{values}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-unfold f length seed -> @@vector [SRFI@tie{}133]
+
+Creates a vector whose length is @var{length} and iterates across each
+index @var{k} between 0 and @var{length} - 1, applying @var{f} at each
+iteration to the current index and current state, in that order, to
+receive two values: the element to put in the @var{k}th slot of
+the new vector and a new state for the next iteration. On the first
+call to @var{f}, the state's value is @var{seed}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-unfold-right f length seed -> @@vector [SRFI@tie{}133]
+
+The same as @code{@@vector-unfold}, but initializes the @@vector from
+right to left.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-copy @@vec [start [end]] -> @@vector [SRFI@tie{}133]
+
+Makes a copy of the portion of @var{@@vec} from @var{start} to @var{end}
+and returns it.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-reverse-copy @@vec [start [end]] -> @@vector [SRFI@tie{}133]
+
+The same as @code{@@vector-copy}, but in reverse order.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-append @@vec @dots{} -> @@vector [SRFI@tie{}133]
+
+Returns a @@vector containing all the elements of the @var{@@vecs} in
+order.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-concatenate list-of-@@vectors -> @@vector [SRFI@tie{}133]
+
+The same as @code{@@vector-append}, but takes a list of @@vectors rather
+than multiple arguments.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-append-subvectors [@@vec start end] @dots{} -> @@vector [SRFI@tie{}133]
+
+Concatenates the result of applying @code{@@vector-copy} to each triplet
+of @var{@@vec}, @var{start}, @var{end} arguments, but may be implemented
+more efficiently.
+@end deffn
+
+@subsubheading Predicates
+
+@deffn {Scheme Procedure} @@? obj -> boolean
+
+Returns @code{#t} if @var{obj} is a valid element of an
+@@vector, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector? obj -> boolean [SRFI@tie{}4]
+
+Returns @code{#t} if @var{obj} is a @@vector, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-empty? @@vec -> boolean [SRFI@tie{}133]
+
+Returns @code{#t} if @var{@@vec} has a length of zero, and @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector= @@vec @dots{} -> boolean [SRFI@tie{}133]
+
+Compares the @var{@@vecs} for elementwise equality, using @code{=} to do
+the comparisons. Returns @code{#f} unless all @@vectors are the same
+length.
+@end deffn
+
+@subsubheading Selectors
+
+@deffn {Scheme Procedure} @@vector-ref @@vec i -> value [SRFI@tie{}4]
+
+Returns the @var{i}th element of @var{@@vec}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-length @@vec -> exact nonnegative integer [SRFI@tie{}4]
+
+Returns the length of @i{@@vec}.
+@end deffn
+
+@subsubheading Iteration
+
+@deffn {Scheme Procedure} @@vector-take @@vec n -> @@vector [SRFI@tie{}152]
+@deffnx {Scheme Procedure} @@vector-take-right @@vec n -> @@vector [SRFI@tie{}152]
+
+Returns a @@vector containing the first/last @var{n} elements of
+@var{@@vec}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-drop @@vec n -> @@vector [SRFI@tie{}152]
+@deffnx {Scheme Procedure} @@vector-drop-right @@vec n -> @@vector [SRFI@tie{}152]
+
+Returns a @@vector containing all except the first/last @var{n} elements
+of @var{@@vec}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-segment @@vec n -> list [SRFI@tie{}152]
+
+Returns a list of @@vectors, each of which contains @var{n} consecutive
+elements of @var{@@vec}. The last @@vector may be shorter than @var{n}.
+It is an error if @var{n} is not an exact positive integer.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-fold kons knil @@vec @@vec2 @dots{} -> object [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector-fold-right kons knil @@vec @@vec2 @dots{} -> object [SRFI@tie{}133]
+
+When one @@vector argument @var{@@vec} is given, folds @var{kons} over the
+elements of @var{@@vec} in increasing/decreasing order using @var{knil} as
+the initial value. The @var{kons} procedure is called with the state
+first and the element second, as in SRFIs 43 and 133 (heterogeneous
+vectors). This is the opposite order to that used in SRFI 1 (lists) and
+the various string SRFIs.
+
+When multiple @@vector arguments are given, @var{kons} is called with
+the current state value and each value from all the vectors;
+@code{@@vector-fold} scans elements from left to right, while
+@code{@@vector-fold-right} does from right to left. If the lengths of
+vectors differ, only the portion of each vector up to the length of the
+shortest vector is scanned.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-map f @@vec @@vec2 @dots{} -> @@vector [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector-map! f @@vec @@vec2 @dots{} -> unspecified [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector-for-each f @@vec @@vec2 @dots{} -> unspecified [SRFI@tie{}133]
+
+Iterate over the elements of @var{@@vec} and apply @var{f} to each,
+returning respectively a @@vector of the results, an undefined value
+with the results placed back in @var{@@vec}, and an undefined value with
+no change to @var{@@vec}.
+
+If more than one vector is passed, @var{f} gets one element from each
+vector as arguments. If the lengths of the vectors differ, iteration
+stops at the end of the shortest vector. For @code{@@vector-map!}, only
+@var{@@vec} is modified even when multiple vectors are passed.
+
+If @code{@@vector-map} or @code{@@vector-map!} returns more than once
+(i.e. because of a continuation captured by @var{f}), the values
+returned or stored by earlier returns may be mutated.
+
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-count pred? @@vec @@vec2 @dots{} -> exact nonnegative integer [SRFI@tie{}133]
+
+Call @var{pred?} on each element of @var{@@vec} and return the number of
+calls that return true.
+
+When multiple vectors are given, @var{pred?} must take
+the same number of arguments as the number of vectors, and
+corresponding elements from each vector are given for each iteration,
+which stops at the end of the shortest vector.
+
+@end deffn
+
+
+@deffn {Scheme Procedure} @@vector-cumulate f knil @@vec -> @@vector [SRFI@tie{}133]
+
+Like @code{@@vector-fold}, but returns a @@vector of partial results
+rather than just the final result.
+@end deffn
+
+@subsubheading Searching
+
+@deffn {Scheme Procedure} @@vector-take-while pred? @@vec -> @@vector [SRFI@tie{}152]
+@deffnx {Scheme Procedure} @@vector-take-while-right pred? @@vec -> @@vector [SRFI@tie{}152]
+
+Return the shortest prefix/suffix of @var{@@vec} all of whose elements
+satisfy @var{pred?}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-drop-while pred? @@vec -> @@vector [SRFI@tie{}152]
+@deffnx {Scheme Procedure} @@vector-drop-while-right pred? @@vec -> @@vector [SRFI@tie{}152]
+
+Drops the longest initial prefix/suffix of @var{@@vec} such that all its
+elements satisfy @var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-index pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector-index-right pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133]
+
+Return the index of the first/last element of @var{@@vec} that satisfies
+@var{pred?}.
+
+When multiple vectors are passed, @var{pred?} must take the same number of
+arguments as the number of vectors, and corresponding elements from each
+vector are passed for each iteration. If the lengths of vectors differ,
+@code{@@vector-index} stops iteration at the end of the shortest one.
+Lengths of vectors must be the same for @code{@@vector-index-right}
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-skip pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector-skip-right pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133]
+
+Returns the index of the first/last element of @var{@@vec} that does not
+satisfy @var{pred?}.
+
+When multiple vectors are passed, @var{pred?} must take the same number
+of arguments as the number of vectors, and corresponding elements from
+each vector are passed for each iteration. If the lengths of vectors
+differ, @code{@@vector-skip} stops iteration at the end of the shortest
+one. Lengths of vectors must be the same for @code{@@vector-skip-right}
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-any pred? @@vec @@vec2 @dots{} -> value or boolean [SRFI@tie{}133]
+
+Returns first non-false result of applying @var{pred?} on a element from
+the @var{@@vec}, or @code{#f} if there is no such element. If
+@var{@@vec} is empty, returns @code{#t}.
+
+When multiple vectors are passed, @var{pred?} must take the same number
+of arguments as the number of vectors, and corresponding elements from
+each vector are passed for each iteration. If the lengths of vectors
+differ, it stops at the end of the shortest one.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-every pred? @@vec @@vec2 @dots{} -> value or boolean [SRFI@tie{}133]
+
+If all elements from @var{@@vec} satisfy @var{pred?}, return the last
+result of @var{pred?}. If not all do, return @code{#f} If @var{@@vec}
+is empty, return @code{#t}.
+
+When multiple vectors are passed, @var{pred?} must take the same number
+of arguments as the number of vectors, and corresponding elements from
+each vector is passed for each iteration. If the lengths of vectors
+differ, it stops at the end of the shortest one.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-partition pred? @@vec -> @@vector and integer [SRFI@tie{}133]
+
+Returns a @@vector of the same type as @var{@@vec}, but with all
+elements satisfying @var{pred?} in the leftmost part of the vector and
+the other elements in the remaining part. The order of elements is
+otherwise preserved. Returns two values, the new @@vector and the
+number of elements satisfying @var{pred?}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-filter pred? @@vec -> @@vector [SRFI@tie{}152]
+@deffnx {Scheme Procedure} @@vector-remove pred? @@vec -> @@vector [SRFI@tie{}152]
+
+Return an @@vector containing the elements of @@vec that satisfy / do
+not satisfy @var{pred?}.
+@end deffn
+
+@subsubheading Mutators
+
+@deffn {Scheme Procedure} @@vector-set! @@vec i value -> unspecified [SRFI@tie{}4]
+
+Sets the @var{i}th element of @var{@@vec} to @var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-swap! @@vec i j -> unspecified [SRFI@tie{}133]
+
+Interchanges the @var{i}th and @var{j}th elements of @var{@@vec}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-fill! @@vec fill [start [end]] -> unspecified [SRFI@tie{}133]
+
+Fills the portion of @var{@@vec} from @var{start} to @var{end} with the
+value @var{fill}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-reverse! @@vec [start [end]] -> unspecified [SRFI@tie{}133]
+
+Reverses the portion of @var{@@vec} from @var{start} to @var{end}.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-copy! @@to at @@from [start [end]] -> unspecified [SRFI@tie{}133]
+
+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} @@vector-reverse-copy! @@to at @@from [start [end]] -> unspecified [SRFI@tie{}133]
+
+The same as @code{@@vector-copy!}, but copies in reverse.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-unfold! f @@vec start end seed -> @@vector [SRFI@tie{}133]
+
+Like @code{vector-unfold}, but the elements are copied into the vector
+@var{@@vec} starting at element @var{start} rather than into a newly
+allocated vector. Terminates when @var{end} - @var{start} elements have
+been generated.
+@end deffn
+
+@deffn {Scheme Procedure} @@vector-unfold-right! f @@vec start end seed -> @@vector [SRFI@tie{}133]
+
+The same as @code{@@vector-unfold!}, but initializes the @@vector from
+right to left.
+@end deffn
+
+@subsubheading Conversion
+
+@deffn {Scheme Procedure} @@vector->list @@vec [start [end]] -> proper-list [SRFI@tie{}4 plus start and end]
+@deffnx {Scheme Procedure} reverse-@@vector->list @@vec [start [end]] -> proper-list [SRFI@tie{}133]
+@deffnx {Scheme Procedure} list->@@vector proper-list -> @@vector
+@deffnx {Scheme Procedure} reverse-list->@@vector proper-list -> @@vector [SRFI@tie{}133]
+@deffnx {Scheme Procedure} @@vector->vector @@vec [start [end]] -> vector
+@deffnx {Scheme Procedure} vector->@@vector vec [start [end]] -> @@vector
+
+Returns a list, @@vector, or heterogeneous vector with the same elements
+as the argument, in reverse order where specified.
+@end deffn
+
+@subsubheading Generators
+
+@deffn {Scheme Procedure} make-@@vector-generator @@vector
+
+Returns a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI
+121} generator that generates all the values of @emph{@@vector} in order.
+Note that the generator is finite.
+@end deffn
+
+@subsubheading Comparators
+
+@deffn {Scheme Variable} @@vector-comparator
+
+Variable containing a
+@url{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI 128}
+comparator whose components provide ordering and hashing of @@vectors.
+@end deffn
+
+@subsubheading Output
+
+@deffn {Scheme Procedure} write-@@vector @@vec [port] -> unspecified
+
+Prints to @var{port} (the current output port by default) a representation of
+@var{@@vec} in the lexical syntax explained below.
+@end deffn
+
+@node SRFI 160 Optional lexical syntax
+@subsubsection SRFI 160 Optional lexical syntax
+
+Each homogeneous vector datatype has an external representation which
+may be supported by the @code{read} and @code{write} procedures and by
+the program parser. Conformance to this SRFI does not in itself require
+support for these external representations.
+
+For each value of @code{@@} in @math{{s8, u8, s16, u16, s32, u32, s64,
+u64, f32, f64, c64, c128}}, if the datatype @code{@@vector} is
+supported, then the external representation of instances of the datatype
+@code{@@vector} is @code{#@@(elements @dots{})}.
+
+@noindent
+For example, @code{#u8(0 #e1e2 #xff)} is a @code{u8vector} of length 3
+containing 0, 100 and 255; @code{#f64(-1.5)} is an @code{f64vector} of
+length 1 containing -1.5.
+
+@quotation note
+The syntax for float vectors conflicts with R5RS, which parses
+@code{#f32()} as 3 objects: @code{#f}, @code{32} and @code{()}. For
+this reason, conformance to this SRFI implies this minor non-conformance
+to R5RS.
+@end quotation
+
+This external representation is also available in program source code.
+For example, @samp{(set! x '#u8(1 2 3))} will set @code{x} to the object
+@code{#u8(1 2 3)}. Literal homogeneous vectors, like heterogeneous
+vectors, are self-evaluating; they do not need to be quoted.
+Homogeneous vectors can appear in quasiquotations but must not contain
+@code{unquote} or @code{unquote-splicing} forms (i.e. @samp{`(,x #u8(1
+2))} is legal but @samp{`#u8(1 ,x 2)} is not). This restriction is to
+accommodate the many Scheme systems that use the @code{read} procedure
+to parse programs.
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-160/base.sld b/module/srfi/srfi-160/base.sld
new file mode 100644
index 000000000..502955503
--- /dev/null
+++ b/module/srfi/srfi-160/base.sld
@@ -0,0 +1,67 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 base)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme complex))
+ (import (only (srfi srfi-151)
+ bitwise-and bitwise-ior
+ bitwise-not arithmetic-shift))
+ ;; SRFI 4 versions of @vector->list don't accept start/end args
+ (import (except (srfi srfi-4)
+ u8vector->list s8vector->list u16vector->list s16vector->list
+ u32vector->list s32vector->list u64vector->list s64vector->list
+ f32vector->list f64vector->list))
+
+ (export
+ make-u8vector make-s8vector make-u16vector make-s16vector
+ make-u32vector make-s32vector make-u64vector make-s64vector
+ make-f32vector make-f64vector make-c64vector make-c128vector )
+ (export
+ u8vector s8vector u16vector s16vector
+ u32vector s32vector u64vector s64vector
+ f32vector f64vector c64vector c128vector )
+ (export
+ u8vector? s8vector? u16vector? s16vector?
+ u32vector? s32vector? u64vector? s64vector?
+ f32vector? f64vector? c64vector? c128vector?)
+ (export
+ u8vector-length s8vector-length u16vector-length s16vector-length
+ u32vector-length s32vector-length u64vector-length s64vector-length
+ f32vector-length f64vector-length c64vector-length c128vector-length)
+ (export
+ u8vector-ref s8vector-ref u16vector-ref s16vector-ref
+ u32vector-ref s32vector-ref u64vector-ref s64vector-ref
+ f32vector-ref f64vector-ref c64vector-ref c128vector-ref)
+ (export
+ u8vector-set! s8vector-set! u16vector-set! s16vector-set!
+ u32vector-set! s32vector-set! u64vector-set! s64vector-set!
+ f32vector-set! f64vector-set! c64vector-set! c128vector-set!)
+ (export
+ u8vector->list s8vector->list u16vector->list s16vector->list
+ u32vector->list s32vector->list u64vector->list s64vector->list
+ f32vector->list f64vector->list c64vector->list c128vector->list)
+ (export
+ list->u8vector list->s8vector list->u16vector list->s16vector
+ list->u32vector list->s32vector list->u64vector list->s64vector
+ list->f32vector list->f64vector list->c64vector list->c128vector)
+ (export
+ u8? s8? u16? s16? u32? s32? u64? s64? f32? f64? c64? c128?)
+
+ (include "base/r7rec.scm")
+ (include "base/complex.scm")
+ (include "base/u8-vector2list.scm")
+ (include "base/s8-vector2list.scm")
+ (include "base/u16-vector2list.scm")
+ (include "base/s16-vector2list.scm")
+ (include "base/u32-vector2list.scm")
+ (include "base/s32-vector2list.scm")
+ (include "base/u64-vector2list.scm")
+ (include "base/s64-vector2list.scm")
+ (include "base/f32-vector2list.scm")
+ (include "base/f64-vector2list.scm")
+ (include "base/c64-vector2list.scm")
+ (include "base/c128-vector2list.scm")
+ (include "base/valid.scm")
+)
diff --git a/module/srfi/srfi-160/base/c128-vector2list.scm b/module/srfi/srfi-160/base/c128-vector2list.scm
new file mode 100644
index 000000000..dcae2be02
--- /dev/null
+++ b/module/srfi/srfi-160/base/c128-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base c128vector->list
+
+(define c128vector->list
+ (case-lambda
+ ((vec) (c128vector->list* vec 0 (c128vector-length vec)))
+ ((vec start) (c128vector->list* vec start (c128vector-length vec)))
+ ((vec start end) (c128vector->list* vec start end))))
+
+(define (c128vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (c128vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/c64-vector2list.scm b/module/srfi/srfi-160/base/c64-vector2list.scm
new file mode 100644
index 000000000..58ab86b0a
--- /dev/null
+++ b/module/srfi/srfi-160/base/c64-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base c64vector->list
+
+(define c64vector->list
+ (case-lambda
+ ((vec) (c64vector->list* vec 0 (c64vector-length vec)))
+ ((vec start) (c64vector->list* vec start (c64vector-length vec)))
+ ((vec start end) (c64vector->list* vec start end))))
+
+(define (c64vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (c64vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/complex.scm b/module/srfi/srfi-160/base/complex.scm
new file mode 100644
index 000000000..0226deb14
--- /dev/null
+++ b/module/srfi/srfi-160/base/complex.scm
@@ -0,0 +1,111 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base c64vectors and c128vectors
+
+;;; Main constructor
+
+(define (make-c64vector len . maybe-fill)
+ (define vec (raw-make-c64vector (make-f32vector (* len 2))))
+ (if (not (null? maybe-fill))
+ (c64vector-simple-fill! vec (car maybe-fill)))
+ vec)
+
+(define (make-c128vector len . maybe-fill)
+ (define vec (raw-make-c128vector (make-f64vector (* len 2))))
+ (if (not (null? maybe-fill))
+ (c128vector-simple-fill! vec (car maybe-fill)))
+ vec)
+
+;; Simple fill! (not exported)
+
+(define (c64vector-simple-fill! vec value)
+ (define len (c64vector-length vec))
+ (let loop ((i 0))
+ (if (= i len)
+ vec
+ (begin
+ (c64vector-set! vec i value)
+ (loop (+ i 1))))))
+
+(define (c128vector-simple-fill! vec value)
+ (define len (c128vector-length vec))
+ (let loop ((i 0))
+ (if (= i len)
+ vec
+ (begin
+ (c128vector-set! vec i value)
+ (loop (+ i 1))))))
+
+;;; Variable-argument constructor
+
+(define (c64vector . list)
+ (list->c64vector list))
+
+(define (c128vector . list)
+ (list->c128vector list))
+
+;; Predicate already defined
+
+;; Length
+
+(define (c64vector-length vec)
+ (/ (f32vector-length (bv64 vec)) 2))
+
+(define (c128vector-length vec)
+ (/ (f64vector-length (bv128 vec)) 2))
+
+;; Get element
+
+(define (c64vector-ref vec i)
+ (let ((fvec (bv64 vec))
+ (j (* i 2)))
+ (make-rectangular
+ (f32vector-ref fvec j)
+ (f32vector-ref fvec (+ j 1)))))
+
+(define (c128vector-ref vec i)
+ (let ((fvec (bv128 vec))
+ (j (* i 2)))
+ (make-rectangular
+ (f64vector-ref fvec j)
+ (f64vector-ref fvec (+ j 1)))))
+
+;; Set element
+
+(define (c64vector-set! vec i value)
+ (let ((fvec (bv64 vec))
+ (j (* i 2)))
+ (f32vector-set! fvec j (real-part value))
+ (f32vector-set! fvec (+ j 1) (imag-part value))))
+
+(define (c128vector-set! vec i value)
+ (let ((fvec (bv128 vec))
+ (j (* i 2)))
+ (f64vector-set! fvec j (real-part value))
+ (f64vector-set! fvec (+ j 1) (imag-part value))))
+
+;; List to vec
+
+(define (list->c64vector list)
+ (define len (length list))
+ (define vec (make-c64vector len))
+ (let loop ((i 0) (list list))
+ (if (= i len)
+ vec
+ (begin
+ (c64vector-set! vec i (car list))
+ (loop (+ i 1) (cdr list))))))
+
+(define (list->c128vector list)
+ (define len (length list))
+ (define vec (make-c128vector len))
+ (let loop ((i 0) (list list))
+ (if (= i len)
+ vec
+ (begin
+ (c128vector-set! vec i (car list))
+ (loop (+ i 1) (cdr list))))))
+
+;; Vec to list defined in at-vector2list
+
diff --git a/module/srfi/srfi-160/base/f32-vector2list.scm b/module/srfi/srfi-160/base/f32-vector2list.scm
new file mode 100644
index 000000000..2bc143479
--- /dev/null
+++ b/module/srfi/srfi-160/base/f32-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base f32vector->list
+
+(define f32vector->list
+ (case-lambda
+ ((vec) (f32vector->list* vec 0 (f32vector-length vec)))
+ ((vec start) (f32vector->list* vec start (f32vector-length vec)))
+ ((vec start end) (f32vector->list* vec start end))))
+
+(define (f32vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (f32vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/f64-vector2list.scm b/module/srfi/srfi-160/base/f64-vector2list.scm
new file mode 100644
index 000000000..4615c23a7
--- /dev/null
+++ b/module/srfi/srfi-160/base/f64-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base f64vector->list
+
+(define f64vector->list
+ (case-lambda
+ ((vec) (f64vector->list* vec 0 (f64vector-length vec)))
+ ((vec start) (f64vector->list* vec start (f64vector-length vec)))
+ ((vec start end) (f64vector->list* vec start end))))
+
+(define (f64vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (f64vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/r7rec.scm b/module/srfi/srfi-160/base/r7rec.scm
new file mode 100644
index 000000000..29f463c4c
--- /dev/null
+++ b/module/srfi/srfi-160/base/r7rec.scm
@@ -0,0 +1,11 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;; The representation of complex vectors
+
+(define-record-type <c64vector> (raw-make-c64vector bv) c64vector?
+ (bv bv64))
+
+(define-record-type <c128vector> (raw-make-c128vector bv) c128vector?
+ (bv bv128))
+
diff --git a/module/srfi/srfi-160/base/s16-vector2list.scm b/module/srfi/srfi-160/base/s16-vector2list.scm
new file mode 100644
index 000000000..ce638634a
--- /dev/null
+++ b/module/srfi/srfi-160/base/s16-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base s16vector->list
+
+(define s16vector->list
+ (case-lambda
+ ((vec) (s16vector->list* vec 0 (s16vector-length vec)))
+ ((vec start) (s16vector->list* vec start (s16vector-length vec)))
+ ((vec start end) (s16vector->list* vec start end))))
+
+(define (s16vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (s16vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/s32-vector2list.scm b/module/srfi/srfi-160/base/s32-vector2list.scm
new file mode 100644
index 000000000..d3bdbde57
--- /dev/null
+++ b/module/srfi/srfi-160/base/s32-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base s32vector->list
+
+(define s32vector->list
+ (case-lambda
+ ((vec) (s32vector->list* vec 0 (s32vector-length vec)))
+ ((vec start) (s32vector->list* vec start (s32vector-length vec)))
+ ((vec start end) (s32vector->list* vec start end))))
+
+(define (s32vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (s32vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/s64-vector2list.scm b/module/srfi/srfi-160/base/s64-vector2list.scm
new file mode 100644
index 000000000..8116dd66c
--- /dev/null
+++ b/module/srfi/srfi-160/base/s64-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base s64vector->list
+
+(define s64vector->list
+ (case-lambda
+ ((vec) (s64vector->list* vec 0 (s64vector-length vec)))
+ ((vec start) (s64vector->list* vec start (s64vector-length vec)))
+ ((vec start end) (s64vector->list* vec start end))))
+
+(define (s64vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (s64vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/s8-vector2list.scm b/module/srfi/srfi-160/base/s8-vector2list.scm
new file mode 100644
index 000000000..314cfe11c
--- /dev/null
+++ b/module/srfi/srfi-160/base/s8-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base s8vector->list
+
+(define s8vector->list
+ (case-lambda
+ ((vec) (s8vector->list* vec 0 (s8vector-length vec)))
+ ((vec start) (s8vector->list* vec start (s8vector-length vec)))
+ ((vec start end) (s8vector->list* vec start end))))
+
+(define (s8vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (s8vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/u16-vector2list.scm b/module/srfi/srfi-160/base/u16-vector2list.scm
new file mode 100644
index 000000000..d986091b1
--- /dev/null
+++ b/module/srfi/srfi-160/base/u16-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base u16vector->list
+
+(define u16vector->list
+ (case-lambda
+ ((vec) (u16vector->list* vec 0 (u16vector-length vec)))
+ ((vec start) (u16vector->list* vec start (u16vector-length vec)))
+ ((vec start end) (u16vector->list* vec start end))))
+
+(define (u16vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (u16vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/u32-vector2list.scm b/module/srfi/srfi-160/base/u32-vector2list.scm
new file mode 100644
index 000000000..ce5a5205c
--- /dev/null
+++ b/module/srfi/srfi-160/base/u32-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base u32vector->list
+
+(define u32vector->list
+ (case-lambda
+ ((vec) (u32vector->list* vec 0 (u32vector-length vec)))
+ ((vec start) (u32vector->list* vec start (u32vector-length vec)))
+ ((vec start end) (u32vector->list* vec start end))))
+
+(define (u32vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (u32vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/u64-vector2list.scm b/module/srfi/srfi-160/base/u64-vector2list.scm
new file mode 100644
index 000000000..06063d5da
--- /dev/null
+++ b/module/srfi/srfi-160/base/u64-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base u64vector->list
+
+(define u64vector->list
+ (case-lambda
+ ((vec) (u64vector->list* vec 0 (u64vector-length vec)))
+ ((vec start) (u64vector->list* vec start (u64vector-length vec)))
+ ((vec start end) (u64vector->list* vec start end))))
+
+(define (u64vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (u64vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/u8-vector2list.scm b/module/srfi/srfi-160/base/u8-vector2list.scm
new file mode 100644
index 000000000..fe64596b8
--- /dev/null
+++ b/module/srfi/srfi-160/base/u8-vector2list.scm
@@ -0,0 +1,18 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;;; Implementation of SRFI 160 base u8vector->list
+
+(define u8vector->list
+ (case-lambda
+ ((vec) (u8vector->list* vec 0 (u8vector-length vec)))
+ ((vec start) (u8vector->list* vec start (u8vector-length vec)))
+ ((vec start end) (u8vector->list* vec start end))))
+
+(define (u8vector->list* vec start end)
+ (let loop ((i (- end 1))
+ (list '()))
+ (if (< i start)
+ list
+ (loop (- i 1) (cons (u8vector-ref vec i) list)))))
+
diff --git a/module/srfi/srfi-160/base/valid.scm b/module/srfi/srfi-160/base/valid.scm
new file mode 100644
index 000000000..f00476acb
--- /dev/null
+++ b/module/srfi/srfi-160/base/valid.scm
@@ -0,0 +1,26 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define (u8? n) (and (exact-integer? n) (<= 0 n 255)))
+
+(define (s8? n) (and (exact-integer? n) (<= -128 n 127)))
+
+(define (u16? n) (and (exact-integer? n) (<= 0 n 65535)))
+
+(define (s16? n) (and (exact-integer? n) (<= -32768 n 32767)))
+
+(define (u32? n) (and (exact-integer? n) (<= 0 n 4294967295)))
+
+(define (s32? n) (and (exact-integer? n) (<= -2147483648 n 2147483647)))
+
+(define (u64? n) (and (exact-integer? n) (<= 0 n 18446744073709551615)))
+
+(define (s64? n) (and (exact-integer? n) (<= -9223372036854775808 n 9223372036854775807)))
+
+(define (f32? n) (and (inexact? n) (real? n)))
+
+(define (f64? n) (f32? n))
+
+(define (c64? n) (inexact? n))
+
+(define (c128? n) (inexact? n))
diff --git a/module/srfi/srfi-160/c128-impl.scm b/module/srfi/srfi-160/c128-impl.scm
new file mode 100644
index 000000000..849ee0c9c
--- /dev/null
+++ b/module/srfi/srfi-160/c128-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The c128s appearing in the code are expanded to u8, s8, etc.
+
+;; make-c128vector defined in (srfi 160 base)
+
+;; c128vector defined in (srfi 160 base)
+
+(define (c128vector-unfold f len seed)
+ (let ((v (make-c128vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (c128vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (c128vector-unfold-right f len seed)
+ (let ((v (make-c128vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (c128vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define c128vector-copy
+ (case-lambda
+ ((vec) (c128vector-copy* vec 0 (c128vector-length vec)))
+ ((vec start) (c128vector-copy* vec start (c128vector-length vec)))
+ ((vec start end) (c128vector-copy* vec start end))))
+
+(define (c128vector-copy* vec start end)
+ (let ((v (make-c128vector (- end start))))
+ (c128vector-copy! v 0 vec start end)
+ v))
+
+(define c128vector-copy!
+ (case-lambda
+ ((to at from)
+ (c128vector-copy!* to at from 0 (c128vector-length from)))
+ ((to at from start)
+ (c128vector-copy!* to at from start (c128vector-length from)))
+ ((to at from start end) (c128vector-copy!* to at from start end))))
+
+(define (c128vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (c128vector-set! to at (c128vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define c128vector-reverse-copy
+ (case-lambda
+ ((vec) (c128vector-reverse-copy* vec 0 (c128vector-length vec)))
+ ((vec start) (c128vector-reverse-copy* vec start (c128vector-length vec)))
+ ((vec start end) (c128vector-reverse-copy* vec start end))))
+
+(define (c128vector-reverse-copy* vec start end)
+ (let ((v (make-c128vector (- end start))))
+ (c128vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define c128vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (c128vector-reverse-copy!* to at from 0 (c128vector-length from)))
+ ((to at from start)
+ (c128vector-reverse-copy!* to at from start (c128vector-length from)))
+ ((to at from start end) (c128vector-reverse-copy!* to at from start end))))
+
+(define (c128vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (c128vector-set! to at (c128vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (c128vector-append . vecs)
+ (c128vector-concatenate vecs))
+
+(define (c128vector-concatenate vecs)
+ (let ((v (make-c128vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (c128vector-copy! v at vec 0 (c128vector-length vec))
+ (loop (cdr vecs) (+ at (c128vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (c128vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (c128vector-append-subvectors . args)
+ (let ((v (make-c128vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (c128vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; c128? defined in (srfi 160 base)
+
+;; c128vector? defined in (srfi 160 base)
+
+(define (c128vector-empty? vec)
+ (zero? (c128vector-length vec)))
+
+(define (c128vector= . vecs)
+ (c128vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (c128vector=* vec1 vec2 vecs)
+ (and (c128dyadic-vecs= vec1 0 (c128vector-length vec1)
+ vec2 0 (c128vector-length vec2))
+ (or (null? vecs)
+ (c128vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (c128dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (c128vector-ref vec1 start1))
+ (elt2 (c128vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (c128dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; c128vector-ref defined in (srfi 160 base)
+
+;; c128vector-length defined in (srfi 160 base)
+
+(define (c128vector-take vec n)
+ (let ((v (make-c128vector n)))
+ (c128vector-copy! v 0 vec 0 n)
+ v))
+
+(define (c128vector-take-right vec n)
+ (let ((v (make-c128vector n))
+ (len (c128vector-length vec)))
+ (c128vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (c128vector-drop vec n)
+ (let* ((len (c128vector-length vec))
+ (vlen (- len n))
+ (v (make-c128vector vlen)))
+ (c128vector-copy! v 0 vec n len)
+ v))
+
+(define (c128vector-drop-right vec n)
+ (let* ((len (c128vector-length vec))
+ (rlen (- len n))
+ (v (make-c128vector rlen)))
+ (c128vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (c128vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (c128vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (c128vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%c128vectors-ref vecs i)
+ (map (lambda (v) (c128vector-ref v i)) vecs))
+
+(define (c128vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (c128vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%c128vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (c128vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((r knil) (i (- (c128vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (c128vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%c128vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (c128vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (c128vector-length vec))
+ (v (make-c128vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c128vector-set! v i (f (c128vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs)))
+ (v (make-c128vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c128vector-set! v i (apply f (%c128vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (c128vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c128vector-set! vec i (f (c128vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c128vector-set! vec i (apply f (%c128vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (c128vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (c128vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%c128vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (c128vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (c128vector-length vec)) r)
+ ((pred (c128vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%c128vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (c128vector-cumulate f knil vec)
+ (let* ((len (c128vector-length vec))
+ (v (make-c128vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (c128vector-ref vec i))))
+ (c128vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (c128vector-foreach f vec)
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (c128vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (c128vector-take-while pred vec)
+ (let* ((len (c128vector-length vec))
+ (idx (c128vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (c128vector-copy vec 0 idx*)))
+
+(define (c128vector-take-while-right pred vec)
+ (let* ((len (c128vector-length vec))
+ (idx (c128vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (c128vector-copy vec idx* len)))
+
+(define (c128vector-drop-while pred vec)
+ (let* ((len (c128vector-length vec))
+ (idx (c128vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (c128vector-copy vec idx* len)))
+
+(define (c128vector-drop-while-right pred vec)
+ (let* ((len (c128vector-length vec))
+ (idx (c128vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (c128vector-copy vec 0 (+ 1 idx*))))
+
+(define (c128vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (c128vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%c128vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (c128vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (c128vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%c128vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (c128vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (c128vector-index (lambda (x) (not (pred x))) vec)
+ (apply c128vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (c128vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (c128vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply c128vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (c128vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (c128vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%c128vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (c128vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c128vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (c128vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c128vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%c128vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (c128vector-partition pred vec)
+ (let* ((len (c128vector-length vec))
+ (cnt (c128vector-count pred vec))
+ (r (make-c128vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (c128vector-ref vec i))
+ (c128vector-set! r yes (c128vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (c128vector-set! r no (c128vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (c128vector-filter pred vec)
+ (let* ((len (c128vector-length vec))
+ (cnt (c128vector-count pred vec))
+ (r (make-c128vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (c128vector-ref vec i))
+ (c128vector-set! r j (c128vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (c128vector-remove pred vec)
+ (c128vector-filter (lambda (x) (not (pred x))) vec))
+
+;; c128vector-set! defined in (srfi 160 base)
+
+(define (c128vector-swap! vec i j)
+ (let ((ival (c128vector-ref vec i))
+ (jval (c128vector-ref vec j)))
+ (c128vector-set! vec i jval)
+ (c128vector-set! vec j ival)))
+
+(define c128vector-fill!
+ (case-lambda
+ ((vec fill) (c128vector-fill-some! vec fill 0 (c128vector-length vec)))
+ ((vec fill start) (c128vector-fill-some! vec fill start (c128vector-length vec)))
+ ((vec fill start end) (c128vector-fill-some! vec fill start end))))
+
+(define (c128vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (c128vector-set! vec start fill)
+ (c128vector-fill-some! vec fill (+ start 1) end)))
+
+(define c128vector-reverse!
+ (case-lambda
+ ((vec) (c128vector-reverse-some! vec 0 (c128vector-length vec)))
+ ((vec start) (c128vector-reverse-some! vec start (c128vector-length vec)))
+ ((vec start end) (c128vector-reverse-some! vec start end))))
+
+(define (c128vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (c128vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (c128vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (c128vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (c128vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (c128vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-c128vector->list
+ (case-lambda
+ ((vec) (reverse-c128vector->list* vec 0 (c128vector-length vec)))
+ ((vec start) (reverse-c128vector->list* vec start (c128vector-length vec)))
+ ((vec start end) (reverse-c128vector->list* vec start end))))
+
+(define (reverse-c128vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (c128vector-ref vec i) r)))))
+
+(define (reverse-list->c128vector list)
+ (let* ((len (length list))
+ (r (make-c128vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (c128vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define c128vector->vector
+ (case-lambda
+ ((vec) (c128vector->vector* vec 0 (c128vector-length vec)))
+ ((vec start) (c128vector->vector* vec start (c128vector-length vec)))
+ ((vec start end) (c128vector->vector* vec start end))))
+
+(define (c128vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (c128vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->c128vector
+ (case-lambda
+ ((vec) (vector->c128vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->c128vector* vec start (vector-length vec)))
+ ((vec start end) (vector->c128vector* vec start end))))
+
+(define (vector->c128vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-c128vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (c128vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-c128vector-generator
+ (case-lambda ((vec) (make-c128vector-generator vec 0 (c128vector-length vec)))
+ ((vec start) (make-c128vector-generator vec start (c128vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (c128vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-c128vector
+ (case-lambda
+ ((vec) (write-c128vector* vec (current-output-port)))
+ ((vec port) (write-c128vector* vec port))))
+
+
+(define (write-c128vector* vec port)
+ (display "#c128(" port) ; c128-expansion is blind, so will expand this too
+ (let ((last (- (c128vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (c128vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (c128vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (c128vector< vec1 vec2)
+ (let ((len1 (c128vector-length vec1))
+ (len2 (c128vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (c128vector-ref vec1 i) (c128vector-ref vec2 i))
+ #t)
+ ((> (c128vector-ref vec1 i) (c128vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (c128vector-hash vec)
+ (let ((len (min 256 (c128vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (c128vector-ref vec i)))))))
+
+(define c128vector-comparator
+ (make-comparator c128vector? c128vector= c128vector< c128vector-hash))
diff --git a/module/srfi/srfi-160/c128.sld b/module/srfi/srfi-160/c128.sld
new file mode 100644
index 000000000..d854c2dbb
--- /dev/null
+++ b/module/srfi/srfi-160/c128.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 c128)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-c128vector c128vector
+ c128vector-unfold c128vector-unfold-right
+ c128vector-copy c128vector-reverse-copy
+ c128vector-append c128vector-concatenate
+ c128vector-append-subvectors)
+ ;; Predicates
+ (export c128? c128vector? c128vector-empty? c128vector=)
+ ;; Selectors
+ (export c128vector-ref c128vector-length)
+ ;; Iteration
+ (export c128vector-take c128vector-take-right
+ c128vector-drop c128vector-drop-right
+ c128vector-segment
+ c128vector-fold c128vector-fold-right
+ c128vector-map c128vector-map! c128vector-for-each
+ c128vector-count c128vector-cumulate)
+ ;; Searching
+ (export c128vector-take-while c128vector-take-while-right
+ c128vector-drop-while c128vector-drop-while-right
+ c128vector-index c128vector-index-right c128vector-skip c128vector-skip-right
+ c128vector-any c128vector-every c128vector-partition
+ c128vector-filter c128vector-remove)
+ ;; Mutators
+ (export c128vector-set! c128vector-swap! c128vector-fill! c128vector-reverse!
+ c128vector-copy! c128vector-reverse-copy!
+ c128vector-unfold! c128vector-unfold-right!)
+ ;; Conversion
+ (export c128vector->list list->c128vector
+ reverse-c128vector->list reverse-list->c128vector
+ c128vector->vector vector->c128vector)
+ ;; Misc
+ (export make-c128vector-generator c128vector-comparator write-c128vector)
+
+ (include "c128-impl.scm")
+)
diff --git a/module/srfi/srfi-160/c64-impl.scm b/module/srfi/srfi-160/c64-impl.scm
new file mode 100644
index 000000000..92d0b539e
--- /dev/null
+++ b/module/srfi/srfi-160/c64-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The c64s appearing in the code are expanded to u8, s8, etc.
+
+;; make-c64vector defined in (srfi 160 base)
+
+;; c64vector defined in (srfi 160 base)
+
+(define (c64vector-unfold f len seed)
+ (let ((v (make-c64vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (c64vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (c64vector-unfold-right f len seed)
+ (let ((v (make-c64vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (c64vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define c64vector-copy
+ (case-lambda
+ ((vec) (c64vector-copy* vec 0 (c64vector-length vec)))
+ ((vec start) (c64vector-copy* vec start (c64vector-length vec)))
+ ((vec start end) (c64vector-copy* vec start end))))
+
+(define (c64vector-copy* vec start end)
+ (let ((v (make-c64vector (- end start))))
+ (c64vector-copy! v 0 vec start end)
+ v))
+
+(define c64vector-copy!
+ (case-lambda
+ ((to at from)
+ (c64vector-copy!* to at from 0 (c64vector-length from)))
+ ((to at from start)
+ (c64vector-copy!* to at from start (c64vector-length from)))
+ ((to at from start end) (c64vector-copy!* to at from start end))))
+
+(define (c64vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (c64vector-set! to at (c64vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define c64vector-reverse-copy
+ (case-lambda
+ ((vec) (c64vector-reverse-copy* vec 0 (c64vector-length vec)))
+ ((vec start) (c64vector-reverse-copy* vec start (c64vector-length vec)))
+ ((vec start end) (c64vector-reverse-copy* vec start end))))
+
+(define (c64vector-reverse-copy* vec start end)
+ (let ((v (make-c64vector (- end start))))
+ (c64vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define c64vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (c64vector-reverse-copy!* to at from 0 (c64vector-length from)))
+ ((to at from start)
+ (c64vector-reverse-copy!* to at from start (c64vector-length from)))
+ ((to at from start end) (c64vector-reverse-copy!* to at from start end))))
+
+(define (c64vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (c64vector-set! to at (c64vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (c64vector-append . vecs)
+ (c64vector-concatenate vecs))
+
+(define (c64vector-concatenate vecs)
+ (let ((v (make-c64vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (c64vector-copy! v at vec 0 (c64vector-length vec))
+ (loop (cdr vecs) (+ at (c64vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (c64vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (c64vector-append-subvectors . args)
+ (let ((v (make-c64vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (c64vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; c64? defined in (srfi 160 base)
+
+;; c64vector? defined in (srfi 160 base)
+
+(define (c64vector-empty? vec)
+ (zero? (c64vector-length vec)))
+
+(define (c64vector= . vecs)
+ (c64vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (c64vector=* vec1 vec2 vecs)
+ (and (c64dyadic-vecs= vec1 0 (c64vector-length vec1)
+ vec2 0 (c64vector-length vec2))
+ (or (null? vecs)
+ (c64vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (c64dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (c64vector-ref vec1 start1))
+ (elt2 (c64vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (c64dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; c64vector-ref defined in (srfi 160 base)
+
+;; c64vector-length defined in (srfi 160 base)
+
+(define (c64vector-take vec n)
+ (let ((v (make-c64vector n)))
+ (c64vector-copy! v 0 vec 0 n)
+ v))
+
+(define (c64vector-take-right vec n)
+ (let ((v (make-c64vector n))
+ (len (c64vector-length vec)))
+ (c64vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (c64vector-drop vec n)
+ (let* ((len (c64vector-length vec))
+ (vlen (- len n))
+ (v (make-c64vector vlen)))
+ (c64vector-copy! v 0 vec n len)
+ v))
+
+(define (c64vector-drop-right vec n)
+ (let* ((len (c64vector-length vec))
+ (rlen (- len n))
+ (v (make-c64vector rlen)))
+ (c64vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (c64vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (c64vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (c64vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%c64vectors-ref vecs i)
+ (map (lambda (v) (c64vector-ref v i)) vecs))
+
+(define (c64vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (c64vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%c64vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (c64vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((r knil) (i (- (c64vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (c64vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%c64vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (c64vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (c64vector-length vec))
+ (v (make-c64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c64vector-set! v i (f (c64vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs)))
+ (v (make-c64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c64vector-set! v i (apply f (%c64vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (c64vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c64vector-set! vec i (f (c64vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (c64vector-set! vec i (apply f (%c64vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (c64vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (c64vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%c64vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (c64vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (c64vector-length vec)) r)
+ ((pred (c64vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%c64vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (c64vector-cumulate f knil vec)
+ (let* ((len (c64vector-length vec))
+ (v (make-c64vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (c64vector-ref vec i))))
+ (c64vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (c64vector-foreach f vec)
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (c64vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (c64vector-take-while pred vec)
+ (let* ((len (c64vector-length vec))
+ (idx (c64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (c64vector-copy vec 0 idx*)))
+
+(define (c64vector-take-while-right pred vec)
+ (let* ((len (c64vector-length vec))
+ (idx (c64vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (c64vector-copy vec idx* len)))
+
+(define (c64vector-drop-while pred vec)
+ (let* ((len (c64vector-length vec))
+ (idx (c64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (c64vector-copy vec idx* len)))
+
+(define (c64vector-drop-while-right pred vec)
+ (let* ((len (c64vector-length vec))
+ (idx (c64vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (c64vector-copy vec 0 (+ 1 idx*))))
+
+(define (c64vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (c64vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%c64vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (c64vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (c64vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%c64vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (c64vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (c64vector-index (lambda (x) (not (pred x))) vec)
+ (apply c64vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (c64vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (c64vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply c64vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (c64vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (c64vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%c64vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (c64vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (c64vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (c64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map c64vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%c64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (c64vector-partition pred vec)
+ (let* ((len (c64vector-length vec))
+ (cnt (c64vector-count pred vec))
+ (r (make-c64vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (c64vector-ref vec i))
+ (c64vector-set! r yes (c64vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (c64vector-set! r no (c64vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (c64vector-filter pred vec)
+ (let* ((len (c64vector-length vec))
+ (cnt (c64vector-count pred vec))
+ (r (make-c64vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (c64vector-ref vec i))
+ (c64vector-set! r j (c64vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (c64vector-remove pred vec)
+ (c64vector-filter (lambda (x) (not (pred x))) vec))
+
+;; c64vector-set! defined in (srfi 160 base)
+
+(define (c64vector-swap! vec i j)
+ (let ((ival (c64vector-ref vec i))
+ (jval (c64vector-ref vec j)))
+ (c64vector-set! vec i jval)
+ (c64vector-set! vec j ival)))
+
+(define c64vector-fill!
+ (case-lambda
+ ((vec fill) (c64vector-fill-some! vec fill 0 (c64vector-length vec)))
+ ((vec fill start) (c64vector-fill-some! vec fill start (c64vector-length vec)))
+ ((vec fill start end) (c64vector-fill-some! vec fill start end))))
+
+(define (c64vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (c64vector-set! vec start fill)
+ (c64vector-fill-some! vec fill (+ start 1) end)))
+
+(define c64vector-reverse!
+ (case-lambda
+ ((vec) (c64vector-reverse-some! vec 0 (c64vector-length vec)))
+ ((vec start) (c64vector-reverse-some! vec start (c64vector-length vec)))
+ ((vec start end) (c64vector-reverse-some! vec start end))))
+
+(define (c64vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (c64vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (c64vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (c64vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (c64vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (c64vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-c64vector->list
+ (case-lambda
+ ((vec) (reverse-c64vector->list* vec 0 (c64vector-length vec)))
+ ((vec start) (reverse-c64vector->list* vec start (c64vector-length vec)))
+ ((vec start end) (reverse-c64vector->list* vec start end))))
+
+(define (reverse-c64vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (c64vector-ref vec i) r)))))
+
+(define (reverse-list->c64vector list)
+ (let* ((len (length list))
+ (r (make-c64vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (c64vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define c64vector->vector
+ (case-lambda
+ ((vec) (c64vector->vector* vec 0 (c64vector-length vec)))
+ ((vec start) (c64vector->vector* vec start (c64vector-length vec)))
+ ((vec start end) (c64vector->vector* vec start end))))
+
+(define (c64vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (c64vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->c64vector
+ (case-lambda
+ ((vec) (vector->c64vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->c64vector* vec start (vector-length vec)))
+ ((vec start end) (vector->c64vector* vec start end))))
+
+(define (vector->c64vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-c64vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (c64vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-c64vector-generator
+ (case-lambda ((vec) (make-c64vector-generator vec 0 (c64vector-length vec)))
+ ((vec start) (make-c64vector-generator vec start (c64vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (c64vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-c64vector
+ (case-lambda
+ ((vec) (write-c64vector* vec (current-output-port)))
+ ((vec port) (write-c64vector* vec port))))
+
+
+(define (write-c64vector* vec port)
+ (display "#c64(" port) ; c64-expansion is blind, so will expand this too
+ (let ((last (- (c64vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (c64vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (c64vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (c64vector< vec1 vec2)
+ (let ((len1 (c64vector-length vec1))
+ (len2 (c64vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (c64vector-ref vec1 i) (c64vector-ref vec2 i))
+ #t)
+ ((> (c64vector-ref vec1 i) (c64vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (c64vector-hash vec)
+ (let ((len (min 256 (c64vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (c64vector-ref vec i)))))))
+
+(define c64vector-comparator
+ (make-comparator c64vector? c64vector= c64vector< c64vector-hash))
diff --git a/module/srfi/srfi-160/c64.sld b/module/srfi/srfi-160/c64.sld
new file mode 100644
index 000000000..7f78c8cda
--- /dev/null
+++ b/module/srfi/srfi-160/c64.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 c64)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-c64vector c64vector
+ c64vector-unfold c64vector-unfold-right
+ c64vector-copy c64vector-reverse-copy
+ c64vector-append c64vector-concatenate
+ c64vector-append-subvectors)
+ ;; Predicates
+ (export c64? c64vector? c64vector-empty? c64vector=)
+ ;; Selectors
+ (export c64vector-ref c64vector-length)
+ ;; Iteration
+ (export c64vector-take c64vector-take-right
+ c64vector-drop c64vector-drop-right
+ c64vector-segment
+ c64vector-fold c64vector-fold-right
+ c64vector-map c64vector-map! c64vector-for-each
+ c64vector-count c64vector-cumulate)
+ ;; Searching
+ (export c64vector-take-while c64vector-take-while-right
+ c64vector-drop-while c64vector-drop-while-right
+ c64vector-index c64vector-index-right c64vector-skip c64vector-skip-right
+ c64vector-any c64vector-every c64vector-partition
+ c64vector-filter c64vector-remove)
+ ;; Mutators
+ (export c64vector-set! c64vector-swap! c64vector-fill! c64vector-reverse!
+ c64vector-copy! c64vector-reverse-copy!
+ c64vector-unfold! c64vector-unfold-right!)
+ ;; Conversion
+ (export c64vector->list list->c64vector
+ reverse-c64vector->list reverse-list->c64vector
+ c64vector->vector vector->c64vector)
+ ;; Misc
+ (export make-c64vector-generator c64vector-comparator write-c64vector)
+
+ (include "c64-impl.scm")
+)
diff --git a/module/srfi/srfi-160/f32-impl.scm b/module/srfi/srfi-160/f32-impl.scm
new file mode 100644
index 000000000..59e524bd4
--- /dev/null
+++ b/module/srfi/srfi-160/f32-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The f32s appearing in the code are expanded to u8, s8, etc.
+
+;; make-f32vector defined in (srfi 160 base)
+
+;; f32vector defined in (srfi 160 base)
+
+(define (f32vector-unfold f len seed)
+ (let ((v (make-f32vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (f32vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (f32vector-unfold-right f len seed)
+ (let ((v (make-f32vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (f32vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define f32vector-copy
+ (case-lambda
+ ((vec) (f32vector-copy* vec 0 (f32vector-length vec)))
+ ((vec start) (f32vector-copy* vec start (f32vector-length vec)))
+ ((vec start end) (f32vector-copy* vec start end))))
+
+(define (f32vector-copy* vec start end)
+ (let ((v (make-f32vector (- end start))))
+ (f32vector-copy! v 0 vec start end)
+ v))
+
+(define f32vector-copy!
+ (case-lambda
+ ((to at from)
+ (f32vector-copy!* to at from 0 (f32vector-length from)))
+ ((to at from start)
+ (f32vector-copy!* to at from start (f32vector-length from)))
+ ((to at from start end) (f32vector-copy!* to at from start end))))
+
+(define (f32vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (f32vector-set! to at (f32vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define f32vector-reverse-copy
+ (case-lambda
+ ((vec) (f32vector-reverse-copy* vec 0 (f32vector-length vec)))
+ ((vec start) (f32vector-reverse-copy* vec start (f32vector-length vec)))
+ ((vec start end) (f32vector-reverse-copy* vec start end))))
+
+(define (f32vector-reverse-copy* vec start end)
+ (let ((v (make-f32vector (- end start))))
+ (f32vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define f32vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (f32vector-reverse-copy!* to at from 0 (f32vector-length from)))
+ ((to at from start)
+ (f32vector-reverse-copy!* to at from start (f32vector-length from)))
+ ((to at from start end) (f32vector-reverse-copy!* to at from start end))))
+
+(define (f32vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (f32vector-set! to at (f32vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (f32vector-append . vecs)
+ (f32vector-concatenate vecs))
+
+(define (f32vector-concatenate vecs)
+ (let ((v (make-f32vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (f32vector-copy! v at vec 0 (f32vector-length vec))
+ (loop (cdr vecs) (+ at (f32vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (f32vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (f32vector-append-subvectors . args)
+ (let ((v (make-f32vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (f32vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; f32? defined in (srfi 160 base)
+
+;; f32vector? defined in (srfi 160 base)
+
+(define (f32vector-empty? vec)
+ (zero? (f32vector-length vec)))
+
+(define (f32vector= . vecs)
+ (f32vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (f32vector=* vec1 vec2 vecs)
+ (and (f32dyadic-vecs= vec1 0 (f32vector-length vec1)
+ vec2 0 (f32vector-length vec2))
+ (or (null? vecs)
+ (f32vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (f32dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (f32vector-ref vec1 start1))
+ (elt2 (f32vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (f32dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; f32vector-ref defined in (srfi 160 base)
+
+;; f32vector-length defined in (srfi 160 base)
+
+(define (f32vector-take vec n)
+ (let ((v (make-f32vector n)))
+ (f32vector-copy! v 0 vec 0 n)
+ v))
+
+(define (f32vector-take-right vec n)
+ (let ((v (make-f32vector n))
+ (len (f32vector-length vec)))
+ (f32vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (f32vector-drop vec n)
+ (let* ((len (f32vector-length vec))
+ (vlen (- len n))
+ (v (make-f32vector vlen)))
+ (f32vector-copy! v 0 vec n len)
+ v))
+
+(define (f32vector-drop-right vec n)
+ (let* ((len (f32vector-length vec))
+ (rlen (- len n))
+ (v (make-f32vector rlen)))
+ (f32vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (f32vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (f32vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (f32vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%f32vectors-ref vecs i)
+ (map (lambda (v) (f32vector-ref v i)) vecs))
+
+(define (f32vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (f32vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%f32vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (f32vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((r knil) (i (- (f32vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (f32vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%f32vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (f32vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (f32vector-length vec))
+ (v (make-f32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f32vector-set! v i (f (f32vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs)))
+ (v (make-f32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f32vector-set! v i (apply f (%f32vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (f32vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f32vector-set! vec i (f (f32vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f32vector-set! vec i (apply f (%f32vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (f32vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (f32vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%f32vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (f32vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (f32vector-length vec)) r)
+ ((pred (f32vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%f32vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (f32vector-cumulate f knil vec)
+ (let* ((len (f32vector-length vec))
+ (v (make-f32vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (f32vector-ref vec i))))
+ (f32vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (f32vector-foreach f vec)
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (f32vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (f32vector-take-while pred vec)
+ (let* ((len (f32vector-length vec))
+ (idx (f32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (f32vector-copy vec 0 idx*)))
+
+(define (f32vector-take-while-right pred vec)
+ (let* ((len (f32vector-length vec))
+ (idx (f32vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (f32vector-copy vec idx* len)))
+
+(define (f32vector-drop-while pred vec)
+ (let* ((len (f32vector-length vec))
+ (idx (f32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (f32vector-copy vec idx* len)))
+
+(define (f32vector-drop-while-right pred vec)
+ (let* ((len (f32vector-length vec))
+ (idx (f32vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (f32vector-copy vec 0 (+ 1 idx*))))
+
+(define (f32vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (f32vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%f32vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (f32vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (f32vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%f32vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (f32vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (f32vector-index (lambda (x) (not (pred x))) vec)
+ (apply f32vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (f32vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (f32vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply f32vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (f32vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (f32vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%f32vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (f32vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f32vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (f32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f32vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%f32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (f32vector-partition pred vec)
+ (let* ((len (f32vector-length vec))
+ (cnt (f32vector-count pred vec))
+ (r (make-f32vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (f32vector-ref vec i))
+ (f32vector-set! r yes (f32vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (f32vector-set! r no (f32vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (f32vector-filter pred vec)
+ (let* ((len (f32vector-length vec))
+ (cnt (f32vector-count pred vec))
+ (r (make-f32vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (f32vector-ref vec i))
+ (f32vector-set! r j (f32vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (f32vector-remove pred vec)
+ (f32vector-filter (lambda (x) (not (pred x))) vec))
+
+;; f32vector-set! defined in (srfi 160 base)
+
+(define (f32vector-swap! vec i j)
+ (let ((ival (f32vector-ref vec i))
+ (jval (f32vector-ref vec j)))
+ (f32vector-set! vec i jval)
+ (f32vector-set! vec j ival)))
+
+(define f32vector-fill!
+ (case-lambda
+ ((vec fill) (f32vector-fill-some! vec fill 0 (f32vector-length vec)))
+ ((vec fill start) (f32vector-fill-some! vec fill start (f32vector-length vec)))
+ ((vec fill start end) (f32vector-fill-some! vec fill start end))))
+
+(define (f32vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (f32vector-set! vec start fill)
+ (f32vector-fill-some! vec fill (+ start 1) end)))
+
+(define f32vector-reverse!
+ (case-lambda
+ ((vec) (f32vector-reverse-some! vec 0 (f32vector-length vec)))
+ ((vec start) (f32vector-reverse-some! vec start (f32vector-length vec)))
+ ((vec start end) (f32vector-reverse-some! vec start end))))
+
+(define (f32vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (f32vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (f32vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (f32vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (f32vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (f32vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-f32vector->list
+ (case-lambda
+ ((vec) (reverse-f32vector->list* vec 0 (f32vector-length vec)))
+ ((vec start) (reverse-f32vector->list* vec start (f32vector-length vec)))
+ ((vec start end) (reverse-f32vector->list* vec start end))))
+
+(define (reverse-f32vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (f32vector-ref vec i) r)))))
+
+(define (reverse-list->f32vector list)
+ (let* ((len (length list))
+ (r (make-f32vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (f32vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define f32vector->vector
+ (case-lambda
+ ((vec) (f32vector->vector* vec 0 (f32vector-length vec)))
+ ((vec start) (f32vector->vector* vec start (f32vector-length vec)))
+ ((vec start end) (f32vector->vector* vec start end))))
+
+(define (f32vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (f32vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->f32vector
+ (case-lambda
+ ((vec) (vector->f32vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->f32vector* vec start (vector-length vec)))
+ ((vec start end) (vector->f32vector* vec start end))))
+
+(define (vector->f32vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-f32vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (f32vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-f32vector-generator
+ (case-lambda ((vec) (make-f32vector-generator vec 0 (f32vector-length vec)))
+ ((vec start) (make-f32vector-generator vec start (f32vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (f32vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-f32vector
+ (case-lambda
+ ((vec) (write-f32vector* vec (current-output-port)))
+ ((vec port) (write-f32vector* vec port))))
+
+
+(define (write-f32vector* vec port)
+ (display "#f32(" port) ; f32-expansion is blind, so will expand this too
+ (let ((last (- (f32vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (f32vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (f32vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (f32vector< vec1 vec2)
+ (let ((len1 (f32vector-length vec1))
+ (len2 (f32vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (f32vector-ref vec1 i) (f32vector-ref vec2 i))
+ #t)
+ ((> (f32vector-ref vec1 i) (f32vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (f32vector-hash vec)
+ (let ((len (min 256 (f32vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (f32vector-ref vec i)))))))
+
+(define f32vector-comparator
+ (make-comparator f32vector? f32vector= f32vector< f32vector-hash))
diff --git a/module/srfi/srfi-160/f32.sld b/module/srfi/srfi-160/f32.sld
new file mode 100644
index 000000000..39dbc1caa
--- /dev/null
+++ b/module/srfi/srfi-160/f32.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 f32)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-f32vector f32vector
+ f32vector-unfold f32vector-unfold-right
+ f32vector-copy f32vector-reverse-copy
+ f32vector-append f32vector-concatenate
+ f32vector-append-subvectors)
+ ;; Predicates
+ (export f32? f32vector? f32vector-empty? f32vector=)
+ ;; Selectors
+ (export f32vector-ref f32vector-length)
+ ;; Iteration
+ (export f32vector-take f32vector-take-right
+ f32vector-drop f32vector-drop-right
+ f32vector-segment
+ f32vector-fold f32vector-fold-right
+ f32vector-map f32vector-map! f32vector-for-each
+ f32vector-count f32vector-cumulate)
+ ;; Searching
+ (export f32vector-take-while f32vector-take-while-right
+ f32vector-drop-while f32vector-drop-while-right
+ f32vector-index f32vector-index-right f32vector-skip f32vector-skip-right
+ f32vector-any f32vector-every f32vector-partition
+ f32vector-filter f32vector-remove)
+ ;; Mutators
+ (export f32vector-set! f32vector-swap! f32vector-fill! f32vector-reverse!
+ f32vector-copy! f32vector-reverse-copy!
+ f32vector-unfold! f32vector-unfold-right!)
+ ;; Conversion
+ (export f32vector->list list->f32vector
+ reverse-f32vector->list reverse-list->f32vector
+ f32vector->vector vector->f32vector)
+ ;; Misc
+ (export make-f32vector-generator f32vector-comparator write-f32vector)
+
+ (include "f32-impl.scm")
+)
diff --git a/module/srfi/srfi-160/f64-impl.scm b/module/srfi/srfi-160/f64-impl.scm
new file mode 100644
index 000000000..eab3722aa
--- /dev/null
+++ b/module/srfi/srfi-160/f64-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The f64s appearing in the code are expanded to u8, s8, etc.
+
+;; make-f64vector defined in (srfi 160 base)
+
+;; f64vector defined in (srfi 160 base)
+
+(define (f64vector-unfold f len seed)
+ (let ((v (make-f64vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (f64vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (f64vector-unfold-right f len seed)
+ (let ((v (make-f64vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (f64vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define f64vector-copy
+ (case-lambda
+ ((vec) (f64vector-copy* vec 0 (f64vector-length vec)))
+ ((vec start) (f64vector-copy* vec start (f64vector-length vec)))
+ ((vec start end) (f64vector-copy* vec start end))))
+
+(define (f64vector-copy* vec start end)
+ (let ((v (make-f64vector (- end start))))
+ (f64vector-copy! v 0 vec start end)
+ v))
+
+(define f64vector-copy!
+ (case-lambda
+ ((to at from)
+ (f64vector-copy!* to at from 0 (f64vector-length from)))
+ ((to at from start)
+ (f64vector-copy!* to at from start (f64vector-length from)))
+ ((to at from start end) (f64vector-copy!* to at from start end))))
+
+(define (f64vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (f64vector-set! to at (f64vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define f64vector-reverse-copy
+ (case-lambda
+ ((vec) (f64vector-reverse-copy* vec 0 (f64vector-length vec)))
+ ((vec start) (f64vector-reverse-copy* vec start (f64vector-length vec)))
+ ((vec start end) (f64vector-reverse-copy* vec start end))))
+
+(define (f64vector-reverse-copy* vec start end)
+ (let ((v (make-f64vector (- end start))))
+ (f64vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define f64vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (f64vector-reverse-copy!* to at from 0 (f64vector-length from)))
+ ((to at from start)
+ (f64vector-reverse-copy!* to at from start (f64vector-length from)))
+ ((to at from start end) (f64vector-reverse-copy!* to at from start end))))
+
+(define (f64vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (f64vector-set! to at (f64vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (f64vector-append . vecs)
+ (f64vector-concatenate vecs))
+
+(define (f64vector-concatenate vecs)
+ (let ((v (make-f64vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (f64vector-copy! v at vec 0 (f64vector-length vec))
+ (loop (cdr vecs) (+ at (f64vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (f64vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (f64vector-append-subvectors . args)
+ (let ((v (make-f64vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (f64vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; f64? defined in (srfi 160 base)
+
+;; f64vector? defined in (srfi 160 base)
+
+(define (f64vector-empty? vec)
+ (zero? (f64vector-length vec)))
+
+(define (f64vector= . vecs)
+ (f64vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (f64vector=* vec1 vec2 vecs)
+ (and (f64dyadic-vecs= vec1 0 (f64vector-length vec1)
+ vec2 0 (f64vector-length vec2))
+ (or (null? vecs)
+ (f64vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (f64dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (f64vector-ref vec1 start1))
+ (elt2 (f64vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (f64dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; f64vector-ref defined in (srfi 160 base)
+
+;; f64vector-length defined in (srfi 160 base)
+
+(define (f64vector-take vec n)
+ (let ((v (make-f64vector n)))
+ (f64vector-copy! v 0 vec 0 n)
+ v))
+
+(define (f64vector-take-right vec n)
+ (let ((v (make-f64vector n))
+ (len (f64vector-length vec)))
+ (f64vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (f64vector-drop vec n)
+ (let* ((len (f64vector-length vec))
+ (vlen (- len n))
+ (v (make-f64vector vlen)))
+ (f64vector-copy! v 0 vec n len)
+ v))
+
+(define (f64vector-drop-right vec n)
+ (let* ((len (f64vector-length vec))
+ (rlen (- len n))
+ (v (make-f64vector rlen)))
+ (f64vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (f64vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (f64vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (f64vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%f64vectors-ref vecs i)
+ (map (lambda (v) (f64vector-ref v i)) vecs))
+
+(define (f64vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (f64vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%f64vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (f64vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((r knil) (i (- (f64vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (f64vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%f64vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (f64vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (f64vector-length vec))
+ (v (make-f64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f64vector-set! v i (f (f64vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs)))
+ (v (make-f64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f64vector-set! v i (apply f (%f64vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (f64vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f64vector-set! vec i (f (f64vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f64vector-set! vec i (apply f (%f64vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (f64vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (f64vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%f64vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (f64vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (f64vector-length vec)) r)
+ ((pred (f64vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%f64vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (f64vector-cumulate f knil vec)
+ (let* ((len (f64vector-length vec))
+ (v (make-f64vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (f64vector-ref vec i))))
+ (f64vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (f64vector-foreach f vec)
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (f64vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (f64vector-take-while pred vec)
+ (let* ((len (f64vector-length vec))
+ (idx (f64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (f64vector-copy vec 0 idx*)))
+
+(define (f64vector-take-while-right pred vec)
+ (let* ((len (f64vector-length vec))
+ (idx (f64vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (f64vector-copy vec idx* len)))
+
+(define (f64vector-drop-while pred vec)
+ (let* ((len (f64vector-length vec))
+ (idx (f64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (f64vector-copy vec idx* len)))
+
+(define (f64vector-drop-while-right pred vec)
+ (let* ((len (f64vector-length vec))
+ (idx (f64vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (f64vector-copy vec 0 (+ 1 idx*))))
+
+(define (f64vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (f64vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%f64vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (f64vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (f64vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%f64vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (f64vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (f64vector-index (lambda (x) (not (pred x))) vec)
+ (apply f64vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (f64vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (f64vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply f64vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (f64vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (f64vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%f64vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (f64vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (f64vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (f64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map f64vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%f64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (f64vector-partition pred vec)
+ (let* ((len (f64vector-length vec))
+ (cnt (f64vector-count pred vec))
+ (r (make-f64vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (f64vector-ref vec i))
+ (f64vector-set! r yes (f64vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (f64vector-set! r no (f64vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (f64vector-filter pred vec)
+ (let* ((len (f64vector-length vec))
+ (cnt (f64vector-count pred vec))
+ (r (make-f64vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (f64vector-ref vec i))
+ (f64vector-set! r j (f64vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (f64vector-remove pred vec)
+ (f64vector-filter (lambda (x) (not (pred x))) vec))
+
+;; f64vector-set! defined in (srfi 160 base)
+
+(define (f64vector-swap! vec i j)
+ (let ((ival (f64vector-ref vec i))
+ (jval (f64vector-ref vec j)))
+ (f64vector-set! vec i jval)
+ (f64vector-set! vec j ival)))
+
+(define f64vector-fill!
+ (case-lambda
+ ((vec fill) (f64vector-fill-some! vec fill 0 (f64vector-length vec)))
+ ((vec fill start) (f64vector-fill-some! vec fill start (f64vector-length vec)))
+ ((vec fill start end) (f64vector-fill-some! vec fill start end))))
+
+(define (f64vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (f64vector-set! vec start fill)
+ (f64vector-fill-some! vec fill (+ start 1) end)))
+
+(define f64vector-reverse!
+ (case-lambda
+ ((vec) (f64vector-reverse-some! vec 0 (f64vector-length vec)))
+ ((vec start) (f64vector-reverse-some! vec start (f64vector-length vec)))
+ ((vec start end) (f64vector-reverse-some! vec start end))))
+
+(define (f64vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (f64vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (f64vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (f64vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (f64vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (f64vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-f64vector->list
+ (case-lambda
+ ((vec) (reverse-f64vector->list* vec 0 (f64vector-length vec)))
+ ((vec start) (reverse-f64vector->list* vec start (f64vector-length vec)))
+ ((vec start end) (reverse-f64vector->list* vec start end))))
+
+(define (reverse-f64vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (f64vector-ref vec i) r)))))
+
+(define (reverse-list->f64vector list)
+ (let* ((len (length list))
+ (r (make-f64vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (f64vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define f64vector->vector
+ (case-lambda
+ ((vec) (f64vector->vector* vec 0 (f64vector-length vec)))
+ ((vec start) (f64vector->vector* vec start (f64vector-length vec)))
+ ((vec start end) (f64vector->vector* vec start end))))
+
+(define (f64vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (f64vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->f64vector
+ (case-lambda
+ ((vec) (vector->f64vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->f64vector* vec start (vector-length vec)))
+ ((vec start end) (vector->f64vector* vec start end))))
+
+(define (vector->f64vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-f64vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (f64vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-f64vector-generator
+ (case-lambda ((vec) (make-f64vector-generator vec 0 (f64vector-length vec)))
+ ((vec start) (make-f64vector-generator vec start (f64vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (f64vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-f64vector
+ (case-lambda
+ ((vec) (write-f64vector* vec (current-output-port)))
+ ((vec port) (write-f64vector* vec port))))
+
+
+(define (write-f64vector* vec port)
+ (display "#f64(" port) ; f64-expansion is blind, so will expand this too
+ (let ((last (- (f64vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (f64vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (f64vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (f64vector< vec1 vec2)
+ (let ((len1 (f64vector-length vec1))
+ (len2 (f64vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (f64vector-ref vec1 i) (f64vector-ref vec2 i))
+ #t)
+ ((> (f64vector-ref vec1 i) (f64vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (f64vector-hash vec)
+ (let ((len (min 256 (f64vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (f64vector-ref vec i)))))))
+
+(define f64vector-comparator
+ (make-comparator f64vector? f64vector= f64vector< f64vector-hash))
diff --git a/module/srfi/srfi-160/f64.sld b/module/srfi/srfi-160/f64.sld
new file mode 100644
index 000000000..58879d32e
--- /dev/null
+++ b/module/srfi/srfi-160/f64.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 f64)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-f64vector f64vector
+ f64vector-unfold f64vector-unfold-right
+ f64vector-copy f64vector-reverse-copy
+ f64vector-append f64vector-concatenate
+ f64vector-append-subvectors)
+ ;; Predicates
+ (export f64? f64vector? f64vector-empty? f64vector=)
+ ;; Selectors
+ (export f64vector-ref f64vector-length)
+ ;; Iteration
+ (export f64vector-take f64vector-take-right
+ f64vector-drop f64vector-drop-right
+ f64vector-segment
+ f64vector-fold f64vector-fold-right
+ f64vector-map f64vector-map! f64vector-for-each
+ f64vector-count f64vector-cumulate)
+ ;; Searching
+ (export f64vector-take-while f64vector-take-while-right
+ f64vector-drop-while f64vector-drop-while-right
+ f64vector-index f64vector-index-right f64vector-skip f64vector-skip-right
+ f64vector-any f64vector-every f64vector-partition
+ f64vector-filter f64vector-remove)
+ ;; Mutators
+ (export f64vector-set! f64vector-swap! f64vector-fill! f64vector-reverse!
+ f64vector-copy! f64vector-reverse-copy!
+ f64vector-unfold! f64vector-unfold-right!)
+ ;; Conversion
+ (export f64vector->list list->f64vector
+ reverse-f64vector->list reverse-list->f64vector
+ f64vector->vector vector->f64vector)
+ ;; Misc
+ (export make-f64vector-generator f64vector-comparator write-f64vector)
+
+ (include "f64-impl.scm")
+)
diff --git a/module/srfi/srfi-160/s16-impl.scm b/module/srfi/srfi-160/s16-impl.scm
new file mode 100644
index 000000000..275232dc4
--- /dev/null
+++ b/module/srfi/srfi-160/s16-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The s16s appearing in the code are expanded to u8, s8, etc.
+
+;; make-s16vector defined in (srfi 160 base)
+
+;; s16vector defined in (srfi 160 base)
+
+(define (s16vector-unfold f len seed)
+ (let ((v (make-s16vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (s16vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (s16vector-unfold-right f len seed)
+ (let ((v (make-s16vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (s16vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define s16vector-copy
+ (case-lambda
+ ((vec) (s16vector-copy* vec 0 (s16vector-length vec)))
+ ((vec start) (s16vector-copy* vec start (s16vector-length vec)))
+ ((vec start end) (s16vector-copy* vec start end))))
+
+(define (s16vector-copy* vec start end)
+ (let ((v (make-s16vector (- end start))))
+ (s16vector-copy! v 0 vec start end)
+ v))
+
+(define s16vector-copy!
+ (case-lambda
+ ((to at from)
+ (s16vector-copy!* to at from 0 (s16vector-length from)))
+ ((to at from start)
+ (s16vector-copy!* to at from start (s16vector-length from)))
+ ((to at from start end) (s16vector-copy!* to at from start end))))
+
+(define (s16vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (s16vector-set! to at (s16vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define s16vector-reverse-copy
+ (case-lambda
+ ((vec) (s16vector-reverse-copy* vec 0 (s16vector-length vec)))
+ ((vec start) (s16vector-reverse-copy* vec start (s16vector-length vec)))
+ ((vec start end) (s16vector-reverse-copy* vec start end))))
+
+(define (s16vector-reverse-copy* vec start end)
+ (let ((v (make-s16vector (- end start))))
+ (s16vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define s16vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (s16vector-reverse-copy!* to at from 0 (s16vector-length from)))
+ ((to at from start)
+ (s16vector-reverse-copy!* to at from start (s16vector-length from)))
+ ((to at from start end) (s16vector-reverse-copy!* to at from start end))))
+
+(define (s16vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (s16vector-set! to at (s16vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (s16vector-append . vecs)
+ (s16vector-concatenate vecs))
+
+(define (s16vector-concatenate vecs)
+ (let ((v (make-s16vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (s16vector-copy! v at vec 0 (s16vector-length vec))
+ (loop (cdr vecs) (+ at (s16vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (s16vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (s16vector-append-subvectors . args)
+ (let ((v (make-s16vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (s16vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; s16? defined in (srfi 160 base)
+
+;; s16vector? defined in (srfi 160 base)
+
+(define (s16vector-empty? vec)
+ (zero? (s16vector-length vec)))
+
+(define (s16vector= . vecs)
+ (s16vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (s16vector=* vec1 vec2 vecs)
+ (and (s16dyadic-vecs= vec1 0 (s16vector-length vec1)
+ vec2 0 (s16vector-length vec2))
+ (or (null? vecs)
+ (s16vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (s16dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (s16vector-ref vec1 start1))
+ (elt2 (s16vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (s16dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; s16vector-ref defined in (srfi 160 base)
+
+;; s16vector-length defined in (srfi 160 base)
+
+(define (s16vector-take vec n)
+ (let ((v (make-s16vector n)))
+ (s16vector-copy! v 0 vec 0 n)
+ v))
+
+(define (s16vector-take-right vec n)
+ (let ((v (make-s16vector n))
+ (len (s16vector-length vec)))
+ (s16vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (s16vector-drop vec n)
+ (let* ((len (s16vector-length vec))
+ (vlen (- len n))
+ (v (make-s16vector vlen)))
+ (s16vector-copy! v 0 vec n len)
+ v))
+
+(define (s16vector-drop-right vec n)
+ (let* ((len (s16vector-length vec))
+ (rlen (- len n))
+ (v (make-s16vector rlen)))
+ (s16vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (s16vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (s16vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (s16vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%s16vectors-ref vecs i)
+ (map (lambda (v) (s16vector-ref v i)) vecs))
+
+(define (s16vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (s16vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%s16vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (s16vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((r knil) (i (- (s16vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (s16vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%s16vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (s16vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (s16vector-length vec))
+ (v (make-s16vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s16vector-set! v i (f (s16vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs)))
+ (v (make-s16vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s16vector-set! v i (apply f (%s16vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (s16vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s16vector-set! vec i (f (s16vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s16vector-set! vec i (apply f (%s16vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (s16vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s16vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%s16vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (s16vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (s16vector-length vec)) r)
+ ((pred (s16vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%s16vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (s16vector-cumulate f knil vec)
+ (let* ((len (s16vector-length vec))
+ (v (make-s16vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (s16vector-ref vec i))))
+ (s16vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (s16vector-foreach f vec)
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s16vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (s16vector-take-while pred vec)
+ (let* ((len (s16vector-length vec))
+ (idx (s16vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s16vector-copy vec 0 idx*)))
+
+(define (s16vector-take-while-right pred vec)
+ (let* ((len (s16vector-length vec))
+ (idx (s16vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (s16vector-copy vec idx* len)))
+
+(define (s16vector-drop-while pred vec)
+ (let* ((len (s16vector-length vec))
+ (idx (s16vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s16vector-copy vec idx* len)))
+
+(define (s16vector-drop-while-right pred vec)
+ (let* ((len (s16vector-length vec))
+ (idx (s16vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (s16vector-copy vec 0 (+ 1 idx*))))
+
+(define (s16vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s16vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s16vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (s16vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (s16vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%s16vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (s16vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (s16vector-index (lambda (x) (not (pred x))) vec)
+ (apply s16vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s16vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (s16vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply s16vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s16vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s16vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s16vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (s16vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s16vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (s16vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s16vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%s16vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (s16vector-partition pred vec)
+ (let* ((len (s16vector-length vec))
+ (cnt (s16vector-count pred vec))
+ (r (make-s16vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (s16vector-ref vec i))
+ (s16vector-set! r yes (s16vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (s16vector-set! r no (s16vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (s16vector-filter pred vec)
+ (let* ((len (s16vector-length vec))
+ (cnt (s16vector-count pred vec))
+ (r (make-s16vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (s16vector-ref vec i))
+ (s16vector-set! r j (s16vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (s16vector-remove pred vec)
+ (s16vector-filter (lambda (x) (not (pred x))) vec))
+
+;; s16vector-set! defined in (srfi 160 base)
+
+(define (s16vector-swap! vec i j)
+ (let ((ival (s16vector-ref vec i))
+ (jval (s16vector-ref vec j)))
+ (s16vector-set! vec i jval)
+ (s16vector-set! vec j ival)))
+
+(define s16vector-fill!
+ (case-lambda
+ ((vec fill) (s16vector-fill-some! vec fill 0 (s16vector-length vec)))
+ ((vec fill start) (s16vector-fill-some! vec fill start (s16vector-length vec)))
+ ((vec fill start end) (s16vector-fill-some! vec fill start end))))
+
+(define (s16vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (s16vector-set! vec start fill)
+ (s16vector-fill-some! vec fill (+ start 1) end)))
+
+(define s16vector-reverse!
+ (case-lambda
+ ((vec) (s16vector-reverse-some! vec 0 (s16vector-length vec)))
+ ((vec start) (s16vector-reverse-some! vec start (s16vector-length vec)))
+ ((vec start end) (s16vector-reverse-some! vec start end))))
+
+(define (s16vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (s16vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (s16vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (s16vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (s16vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (s16vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-s16vector->list
+ (case-lambda
+ ((vec) (reverse-s16vector->list* vec 0 (s16vector-length vec)))
+ ((vec start) (reverse-s16vector->list* vec start (s16vector-length vec)))
+ ((vec start end) (reverse-s16vector->list* vec start end))))
+
+(define (reverse-s16vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (s16vector-ref vec i) r)))))
+
+(define (reverse-list->s16vector list)
+ (let* ((len (length list))
+ (r (make-s16vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (s16vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define s16vector->vector
+ (case-lambda
+ ((vec) (s16vector->vector* vec 0 (s16vector-length vec)))
+ ((vec start) (s16vector->vector* vec start (s16vector-length vec)))
+ ((vec start end) (s16vector->vector* vec start end))))
+
+(define (s16vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (s16vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->s16vector
+ (case-lambda
+ ((vec) (vector->s16vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->s16vector* vec start (vector-length vec)))
+ ((vec start end) (vector->s16vector* vec start end))))
+
+(define (vector->s16vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-s16vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (s16vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-s16vector-generator
+ (case-lambda ((vec) (make-s16vector-generator vec 0 (s16vector-length vec)))
+ ((vec start) (make-s16vector-generator vec start (s16vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (s16vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-s16vector
+ (case-lambda
+ ((vec) (write-s16vector* vec (current-output-port)))
+ ((vec port) (write-s16vector* vec port))))
+
+
+(define (write-s16vector* vec port)
+ (display "#s16(" port) ; s16-expansion is blind, so will expand this too
+ (let ((last (- (s16vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (s16vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (s16vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (s16vector< vec1 vec2)
+ (let ((len1 (s16vector-length vec1))
+ (len2 (s16vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (s16vector-ref vec1 i) (s16vector-ref vec2 i))
+ #t)
+ ((> (s16vector-ref vec1 i) (s16vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (s16vector-hash vec)
+ (let ((len (min 256 (s16vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (s16vector-ref vec i)))))))
+
+(define s16vector-comparator
+ (make-comparator s16vector? s16vector= s16vector< s16vector-hash))
diff --git a/module/srfi/srfi-160/s16.sld b/module/srfi/srfi-160/s16.sld
new file mode 100644
index 000000000..e9da8346d
--- /dev/null
+++ b/module/srfi/srfi-160/s16.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 s16)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-s16vector s16vector
+ s16vector-unfold s16vector-unfold-right
+ s16vector-copy s16vector-reverse-copy
+ s16vector-append s16vector-concatenate
+ s16vector-append-subvectors)
+ ;; Predicates
+ (export s16? s16vector? s16vector-empty? s16vector=)
+ ;; Selectors
+ (export s16vector-ref s16vector-length)
+ ;; Iteration
+ (export s16vector-take s16vector-take-right
+ s16vector-drop s16vector-drop-right
+ s16vector-segment
+ s16vector-fold s16vector-fold-right
+ s16vector-map s16vector-map! s16vector-for-each
+ s16vector-count s16vector-cumulate)
+ ;; Searching
+ (export s16vector-take-while s16vector-take-while-right
+ s16vector-drop-while s16vector-drop-while-right
+ s16vector-index s16vector-index-right s16vector-skip s16vector-skip-right
+ s16vector-any s16vector-every s16vector-partition
+ s16vector-filter s16vector-remove)
+ ;; Mutators
+ (export s16vector-set! s16vector-swap! s16vector-fill! s16vector-reverse!
+ s16vector-copy! s16vector-reverse-copy!
+ s16vector-unfold! s16vector-unfold-right!)
+ ;; Conversion
+ (export s16vector->list list->s16vector
+ reverse-s16vector->list reverse-list->s16vector
+ s16vector->vector vector->s16vector)
+ ;; Misc
+ (export make-s16vector-generator s16vector-comparator write-s16vector)
+
+ (include "s16-impl.scm")
+)
diff --git a/module/srfi/srfi-160/s32-impl.scm b/module/srfi/srfi-160/s32-impl.scm
new file mode 100644
index 000000000..528edc651
--- /dev/null
+++ b/module/srfi/srfi-160/s32-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The s32s appearing in the code are expanded to u8, s8, etc.
+
+;; make-s32vector defined in (srfi 160 base)
+
+;; s32vector defined in (srfi 160 base)
+
+(define (s32vector-unfold f len seed)
+ (let ((v (make-s32vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (s32vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (s32vector-unfold-right f len seed)
+ (let ((v (make-s32vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (s32vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define s32vector-copy
+ (case-lambda
+ ((vec) (s32vector-copy* vec 0 (s32vector-length vec)))
+ ((vec start) (s32vector-copy* vec start (s32vector-length vec)))
+ ((vec start end) (s32vector-copy* vec start end))))
+
+(define (s32vector-copy* vec start end)
+ (let ((v (make-s32vector (- end start))))
+ (s32vector-copy! v 0 vec start end)
+ v))
+
+(define s32vector-copy!
+ (case-lambda
+ ((to at from)
+ (s32vector-copy!* to at from 0 (s32vector-length from)))
+ ((to at from start)
+ (s32vector-copy!* to at from start (s32vector-length from)))
+ ((to at from start end) (s32vector-copy!* to at from start end))))
+
+(define (s32vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (s32vector-set! to at (s32vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define s32vector-reverse-copy
+ (case-lambda
+ ((vec) (s32vector-reverse-copy* vec 0 (s32vector-length vec)))
+ ((vec start) (s32vector-reverse-copy* vec start (s32vector-length vec)))
+ ((vec start end) (s32vector-reverse-copy* vec start end))))
+
+(define (s32vector-reverse-copy* vec start end)
+ (let ((v (make-s32vector (- end start))))
+ (s32vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define s32vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (s32vector-reverse-copy!* to at from 0 (s32vector-length from)))
+ ((to at from start)
+ (s32vector-reverse-copy!* to at from start (s32vector-length from)))
+ ((to at from start end) (s32vector-reverse-copy!* to at from start end))))
+
+(define (s32vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (s32vector-set! to at (s32vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (s32vector-append . vecs)
+ (s32vector-concatenate vecs))
+
+(define (s32vector-concatenate vecs)
+ (let ((v (make-s32vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (s32vector-copy! v at vec 0 (s32vector-length vec))
+ (loop (cdr vecs) (+ at (s32vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (s32vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (s32vector-append-subvectors . args)
+ (let ((v (make-s32vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (s32vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; s32? defined in (srfi 160 base)
+
+;; s32vector? defined in (srfi 160 base)
+
+(define (s32vector-empty? vec)
+ (zero? (s32vector-length vec)))
+
+(define (s32vector= . vecs)
+ (s32vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (s32vector=* vec1 vec2 vecs)
+ (and (s32dyadic-vecs= vec1 0 (s32vector-length vec1)
+ vec2 0 (s32vector-length vec2))
+ (or (null? vecs)
+ (s32vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (s32dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (s32vector-ref vec1 start1))
+ (elt2 (s32vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (s32dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; s32vector-ref defined in (srfi 160 base)
+
+;; s32vector-length defined in (srfi 160 base)
+
+(define (s32vector-take vec n)
+ (let ((v (make-s32vector n)))
+ (s32vector-copy! v 0 vec 0 n)
+ v))
+
+(define (s32vector-take-right vec n)
+ (let ((v (make-s32vector n))
+ (len (s32vector-length vec)))
+ (s32vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (s32vector-drop vec n)
+ (let* ((len (s32vector-length vec))
+ (vlen (- len n))
+ (v (make-s32vector vlen)))
+ (s32vector-copy! v 0 vec n len)
+ v))
+
+(define (s32vector-drop-right vec n)
+ (let* ((len (s32vector-length vec))
+ (rlen (- len n))
+ (v (make-s32vector rlen)))
+ (s32vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (s32vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (s32vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (s32vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%s32vectors-ref vecs i)
+ (map (lambda (v) (s32vector-ref v i)) vecs))
+
+(define (s32vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (s32vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%s32vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (s32vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((r knil) (i (- (s32vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (s32vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%s32vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (s32vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (s32vector-length vec))
+ (v (make-s32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s32vector-set! v i (f (s32vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs)))
+ (v (make-s32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s32vector-set! v i (apply f (%s32vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (s32vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s32vector-set! vec i (f (s32vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s32vector-set! vec i (apply f (%s32vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (s32vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s32vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%s32vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (s32vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (s32vector-length vec)) r)
+ ((pred (s32vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%s32vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (s32vector-cumulate f knil vec)
+ (let* ((len (s32vector-length vec))
+ (v (make-s32vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (s32vector-ref vec i))))
+ (s32vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (s32vector-foreach f vec)
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s32vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (s32vector-take-while pred vec)
+ (let* ((len (s32vector-length vec))
+ (idx (s32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s32vector-copy vec 0 idx*)))
+
+(define (s32vector-take-while-right pred vec)
+ (let* ((len (s32vector-length vec))
+ (idx (s32vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (s32vector-copy vec idx* len)))
+
+(define (s32vector-drop-while pred vec)
+ (let* ((len (s32vector-length vec))
+ (idx (s32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s32vector-copy vec idx* len)))
+
+(define (s32vector-drop-while-right pred vec)
+ (let* ((len (s32vector-length vec))
+ (idx (s32vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (s32vector-copy vec 0 (+ 1 idx*))))
+
+(define (s32vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s32vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s32vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (s32vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (s32vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%s32vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (s32vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (s32vector-index (lambda (x) (not (pred x))) vec)
+ (apply s32vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s32vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (s32vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply s32vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s32vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s32vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s32vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (s32vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s32vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (s32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s32vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%s32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (s32vector-partition pred vec)
+ (let* ((len (s32vector-length vec))
+ (cnt (s32vector-count pred vec))
+ (r (make-s32vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (s32vector-ref vec i))
+ (s32vector-set! r yes (s32vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (s32vector-set! r no (s32vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (s32vector-filter pred vec)
+ (let* ((len (s32vector-length vec))
+ (cnt (s32vector-count pred vec))
+ (r (make-s32vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (s32vector-ref vec i))
+ (s32vector-set! r j (s32vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (s32vector-remove pred vec)
+ (s32vector-filter (lambda (x) (not (pred x))) vec))
+
+;; s32vector-set! defined in (srfi 160 base)
+
+(define (s32vector-swap! vec i j)
+ (let ((ival (s32vector-ref vec i))
+ (jval (s32vector-ref vec j)))
+ (s32vector-set! vec i jval)
+ (s32vector-set! vec j ival)))
+
+(define s32vector-fill!
+ (case-lambda
+ ((vec fill) (s32vector-fill-some! vec fill 0 (s32vector-length vec)))
+ ((vec fill start) (s32vector-fill-some! vec fill start (s32vector-length vec)))
+ ((vec fill start end) (s32vector-fill-some! vec fill start end))))
+
+(define (s32vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (s32vector-set! vec start fill)
+ (s32vector-fill-some! vec fill (+ start 1) end)))
+
+(define s32vector-reverse!
+ (case-lambda
+ ((vec) (s32vector-reverse-some! vec 0 (s32vector-length vec)))
+ ((vec start) (s32vector-reverse-some! vec start (s32vector-length vec)))
+ ((vec start end) (s32vector-reverse-some! vec start end))))
+
+(define (s32vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (s32vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (s32vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (s32vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (s32vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (s32vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-s32vector->list
+ (case-lambda
+ ((vec) (reverse-s32vector->list* vec 0 (s32vector-length vec)))
+ ((vec start) (reverse-s32vector->list* vec start (s32vector-length vec)))
+ ((vec start end) (reverse-s32vector->list* vec start end))))
+
+(define (reverse-s32vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (s32vector-ref vec i) r)))))
+
+(define (reverse-list->s32vector list)
+ (let* ((len (length list))
+ (r (make-s32vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (s32vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define s32vector->vector
+ (case-lambda
+ ((vec) (s32vector->vector* vec 0 (s32vector-length vec)))
+ ((vec start) (s32vector->vector* vec start (s32vector-length vec)))
+ ((vec start end) (s32vector->vector* vec start end))))
+
+(define (s32vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (s32vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->s32vector
+ (case-lambda
+ ((vec) (vector->s32vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->s32vector* vec start (vector-length vec)))
+ ((vec start end) (vector->s32vector* vec start end))))
+
+(define (vector->s32vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-s32vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (s32vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-s32vector-generator
+ (case-lambda ((vec) (make-s32vector-generator vec 0 (s32vector-length vec)))
+ ((vec start) (make-s32vector-generator vec start (s32vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (s32vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-s32vector
+ (case-lambda
+ ((vec) (write-s32vector* vec (current-output-port)))
+ ((vec port) (write-s32vector* vec port))))
+
+
+(define (write-s32vector* vec port)
+ (display "#s32(" port) ; s32-expansion is blind, so will expand this too
+ (let ((last (- (s32vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (s32vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (s32vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (s32vector< vec1 vec2)
+ (let ((len1 (s32vector-length vec1))
+ (len2 (s32vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (s32vector-ref vec1 i) (s32vector-ref vec2 i))
+ #t)
+ ((> (s32vector-ref vec1 i) (s32vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (s32vector-hash vec)
+ (let ((len (min 256 (s32vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (s32vector-ref vec i)))))))
+
+(define s32vector-comparator
+ (make-comparator s32vector? s32vector= s32vector< s32vector-hash))
diff --git a/module/srfi/srfi-160/s32.sld b/module/srfi/srfi-160/s32.sld
new file mode 100644
index 000000000..8475ec13a
--- /dev/null
+++ b/module/srfi/srfi-160/s32.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 s32)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-s32vector s32vector
+ s32vector-unfold s32vector-unfold-right
+ s32vector-copy s32vector-reverse-copy
+ s32vector-append s32vector-concatenate
+ s32vector-append-subvectors)
+ ;; Predicates
+ (export s32? s32vector? s32vector-empty? s32vector=)
+ ;; Selectors
+ (export s32vector-ref s32vector-length)
+ ;; Iteration
+ (export s32vector-take s32vector-take-right
+ s32vector-drop s32vector-drop-right
+ s32vector-segment
+ s32vector-fold s32vector-fold-right
+ s32vector-map s32vector-map! s32vector-for-each
+ s32vector-count s32vector-cumulate)
+ ;; Searching
+ (export s32vector-take-while s32vector-take-while-right
+ s32vector-drop-while s32vector-drop-while-right
+ s32vector-index s32vector-index-right s32vector-skip s32vector-skip-right
+ s32vector-any s32vector-every s32vector-partition
+ s32vector-filter s32vector-remove)
+ ;; Mutators
+ (export s32vector-set! s32vector-swap! s32vector-fill! s32vector-reverse!
+ s32vector-copy! s32vector-reverse-copy!
+ s32vector-unfold! s32vector-unfold-right!)
+ ;; Conversion
+ (export s32vector->list list->s32vector
+ reverse-s32vector->list reverse-list->s32vector
+ s32vector->vector vector->s32vector)
+ ;; Misc
+ (export make-s32vector-generator s32vector-comparator write-s32vector)
+
+ (include "s32-impl.scm")
+)
diff --git a/module/srfi/srfi-160/s64-impl.scm b/module/srfi/srfi-160/s64-impl.scm
new file mode 100644
index 000000000..38165069c
--- /dev/null
+++ b/module/srfi/srfi-160/s64-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The s64s appearing in the code are expanded to u8, s8, etc.
+
+;; make-s64vector defined in (srfi 160 base)
+
+;; s64vector defined in (srfi 160 base)
+
+(define (s64vector-unfold f len seed)
+ (let ((v (make-s64vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (s64vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (s64vector-unfold-right f len seed)
+ (let ((v (make-s64vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (s64vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define s64vector-copy
+ (case-lambda
+ ((vec) (s64vector-copy* vec 0 (s64vector-length vec)))
+ ((vec start) (s64vector-copy* vec start (s64vector-length vec)))
+ ((vec start end) (s64vector-copy* vec start end))))
+
+(define (s64vector-copy* vec start end)
+ (let ((v (make-s64vector (- end start))))
+ (s64vector-copy! v 0 vec start end)
+ v))
+
+(define s64vector-copy!
+ (case-lambda
+ ((to at from)
+ (s64vector-copy!* to at from 0 (s64vector-length from)))
+ ((to at from start)
+ (s64vector-copy!* to at from start (s64vector-length from)))
+ ((to at from start end) (s64vector-copy!* to at from start end))))
+
+(define (s64vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (s64vector-set! to at (s64vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define s64vector-reverse-copy
+ (case-lambda
+ ((vec) (s64vector-reverse-copy* vec 0 (s64vector-length vec)))
+ ((vec start) (s64vector-reverse-copy* vec start (s64vector-length vec)))
+ ((vec start end) (s64vector-reverse-copy* vec start end))))
+
+(define (s64vector-reverse-copy* vec start end)
+ (let ((v (make-s64vector (- end start))))
+ (s64vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define s64vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (s64vector-reverse-copy!* to at from 0 (s64vector-length from)))
+ ((to at from start)
+ (s64vector-reverse-copy!* to at from start (s64vector-length from)))
+ ((to at from start end) (s64vector-reverse-copy!* to at from start end))))
+
+(define (s64vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (s64vector-set! to at (s64vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (s64vector-append . vecs)
+ (s64vector-concatenate vecs))
+
+(define (s64vector-concatenate vecs)
+ (let ((v (make-s64vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (s64vector-copy! v at vec 0 (s64vector-length vec))
+ (loop (cdr vecs) (+ at (s64vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (s64vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (s64vector-append-subvectors . args)
+ (let ((v (make-s64vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (s64vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; s64? defined in (srfi 160 base)
+
+;; s64vector? defined in (srfi 160 base)
+
+(define (s64vector-empty? vec)
+ (zero? (s64vector-length vec)))
+
+(define (s64vector= . vecs)
+ (s64vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (s64vector=* vec1 vec2 vecs)
+ (and (s64dyadic-vecs= vec1 0 (s64vector-length vec1)
+ vec2 0 (s64vector-length vec2))
+ (or (null? vecs)
+ (s64vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (s64dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (s64vector-ref vec1 start1))
+ (elt2 (s64vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (s64dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; s64vector-ref defined in (srfi 160 base)
+
+;; s64vector-length defined in (srfi 160 base)
+
+(define (s64vector-take vec n)
+ (let ((v (make-s64vector n)))
+ (s64vector-copy! v 0 vec 0 n)
+ v))
+
+(define (s64vector-take-right vec n)
+ (let ((v (make-s64vector n))
+ (len (s64vector-length vec)))
+ (s64vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (s64vector-drop vec n)
+ (let* ((len (s64vector-length vec))
+ (vlen (- len n))
+ (v (make-s64vector vlen)))
+ (s64vector-copy! v 0 vec n len)
+ v))
+
+(define (s64vector-drop-right vec n)
+ (let* ((len (s64vector-length vec))
+ (rlen (- len n))
+ (v (make-s64vector rlen)))
+ (s64vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (s64vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (s64vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (s64vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%s64vectors-ref vecs i)
+ (map (lambda (v) (s64vector-ref v i)) vecs))
+
+(define (s64vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (s64vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%s64vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (s64vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((r knil) (i (- (s64vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (s64vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%s64vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (s64vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (s64vector-length vec))
+ (v (make-s64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s64vector-set! v i (f (s64vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs)))
+ (v (make-s64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s64vector-set! v i (apply f (%s64vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (s64vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s64vector-set! vec i (f (s64vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s64vector-set! vec i (apply f (%s64vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (s64vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s64vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%s64vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (s64vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (s64vector-length vec)) r)
+ ((pred (s64vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%s64vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (s64vector-cumulate f knil vec)
+ (let* ((len (s64vector-length vec))
+ (v (make-s64vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (s64vector-ref vec i))))
+ (s64vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (s64vector-foreach f vec)
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s64vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (s64vector-take-while pred vec)
+ (let* ((len (s64vector-length vec))
+ (idx (s64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s64vector-copy vec 0 idx*)))
+
+(define (s64vector-take-while-right pred vec)
+ (let* ((len (s64vector-length vec))
+ (idx (s64vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (s64vector-copy vec idx* len)))
+
+(define (s64vector-drop-while pred vec)
+ (let* ((len (s64vector-length vec))
+ (idx (s64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s64vector-copy vec idx* len)))
+
+(define (s64vector-drop-while-right pred vec)
+ (let* ((len (s64vector-length vec))
+ (idx (s64vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (s64vector-copy vec 0 (+ 1 idx*))))
+
+(define (s64vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s64vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s64vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (s64vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (s64vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%s64vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (s64vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (s64vector-index (lambda (x) (not (pred x))) vec)
+ (apply s64vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s64vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (s64vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply s64vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s64vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s64vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s64vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (s64vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s64vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (s64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s64vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%s64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (s64vector-partition pred vec)
+ (let* ((len (s64vector-length vec))
+ (cnt (s64vector-count pred vec))
+ (r (make-s64vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (s64vector-ref vec i))
+ (s64vector-set! r yes (s64vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (s64vector-set! r no (s64vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (s64vector-filter pred vec)
+ (let* ((len (s64vector-length vec))
+ (cnt (s64vector-count pred vec))
+ (r (make-s64vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (s64vector-ref vec i))
+ (s64vector-set! r j (s64vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (s64vector-remove pred vec)
+ (s64vector-filter (lambda (x) (not (pred x))) vec))
+
+;; s64vector-set! defined in (srfi 160 base)
+
+(define (s64vector-swap! vec i j)
+ (let ((ival (s64vector-ref vec i))
+ (jval (s64vector-ref vec j)))
+ (s64vector-set! vec i jval)
+ (s64vector-set! vec j ival)))
+
+(define s64vector-fill!
+ (case-lambda
+ ((vec fill) (s64vector-fill-some! vec fill 0 (s64vector-length vec)))
+ ((vec fill start) (s64vector-fill-some! vec fill start (s64vector-length vec)))
+ ((vec fill start end) (s64vector-fill-some! vec fill start end))))
+
+(define (s64vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (s64vector-set! vec start fill)
+ (s64vector-fill-some! vec fill (+ start 1) end)))
+
+(define s64vector-reverse!
+ (case-lambda
+ ((vec) (s64vector-reverse-some! vec 0 (s64vector-length vec)))
+ ((vec start) (s64vector-reverse-some! vec start (s64vector-length vec)))
+ ((vec start end) (s64vector-reverse-some! vec start end))))
+
+(define (s64vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (s64vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (s64vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (s64vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (s64vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (s64vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-s64vector->list
+ (case-lambda
+ ((vec) (reverse-s64vector->list* vec 0 (s64vector-length vec)))
+ ((vec start) (reverse-s64vector->list* vec start (s64vector-length vec)))
+ ((vec start end) (reverse-s64vector->list* vec start end))))
+
+(define (reverse-s64vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (s64vector-ref vec i) r)))))
+
+(define (reverse-list->s64vector list)
+ (let* ((len (length list))
+ (r (make-s64vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (s64vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define s64vector->vector
+ (case-lambda
+ ((vec) (s64vector->vector* vec 0 (s64vector-length vec)))
+ ((vec start) (s64vector->vector* vec start (s64vector-length vec)))
+ ((vec start end) (s64vector->vector* vec start end))))
+
+(define (s64vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (s64vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->s64vector
+ (case-lambda
+ ((vec) (vector->s64vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->s64vector* vec start (vector-length vec)))
+ ((vec start end) (vector->s64vector* vec start end))))
+
+(define (vector->s64vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-s64vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (s64vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-s64vector-generator
+ (case-lambda ((vec) (make-s64vector-generator vec 0 (s64vector-length vec)))
+ ((vec start) (make-s64vector-generator vec start (s64vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (s64vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-s64vector
+ (case-lambda
+ ((vec) (write-s64vector* vec (current-output-port)))
+ ((vec port) (write-s64vector* vec port))))
+
+
+(define (write-s64vector* vec port)
+ (display "#s64(" port) ; s64-expansion is blind, so will expand this too
+ (let ((last (- (s64vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (s64vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (s64vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (s64vector< vec1 vec2)
+ (let ((len1 (s64vector-length vec1))
+ (len2 (s64vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (s64vector-ref vec1 i) (s64vector-ref vec2 i))
+ #t)
+ ((> (s64vector-ref vec1 i) (s64vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (s64vector-hash vec)
+ (let ((len (min 256 (s64vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (s64vector-ref vec i)))))))
+
+(define s64vector-comparator
+ (make-comparator s64vector? s64vector= s64vector< s64vector-hash))
diff --git a/module/srfi/srfi-160/s64.sld b/module/srfi/srfi-160/s64.sld
new file mode 100644
index 000000000..b25973eaf
--- /dev/null
+++ b/module/srfi/srfi-160/s64.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 s64)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-s64vector s64vector
+ s64vector-unfold s64vector-unfold-right
+ s64vector-copy s64vector-reverse-copy
+ s64vector-append s64vector-concatenate
+ s64vector-append-subvectors)
+ ;; Predicates
+ (export s64? s64vector? s64vector-empty? s64vector=)
+ ;; Selectors
+ (export s64vector-ref s64vector-length)
+ ;; Iteration
+ (export s64vector-take s64vector-take-right
+ s64vector-drop s64vector-drop-right
+ s64vector-segment
+ s64vector-fold s64vector-fold-right
+ s64vector-map s64vector-map! s64vector-for-each
+ s64vector-count s64vector-cumulate)
+ ;; Searching
+ (export s64vector-take-while s64vector-take-while-right
+ s64vector-drop-while s64vector-drop-while-right
+ s64vector-index s64vector-index-right s64vector-skip s64vector-skip-right
+ s64vector-any s64vector-every s64vector-partition
+ s64vector-filter s64vector-remove)
+ ;; Mutators
+ (export s64vector-set! s64vector-swap! s64vector-fill! s64vector-reverse!
+ s64vector-copy! s64vector-reverse-copy!
+ s64vector-unfold! s64vector-unfold-right!)
+ ;; Conversion
+ (export s64vector->list list->s64vector
+ reverse-s64vector->list reverse-list->s64vector
+ s64vector->vector vector->s64vector)
+ ;; Misc
+ (export make-s64vector-generator s64vector-comparator write-s64vector)
+
+ (include "s64-impl.scm")
+)
diff --git a/module/srfi/srfi-160/s8-impl.scm b/module/srfi/srfi-160/s8-impl.scm
new file mode 100644
index 000000000..9f5386060
--- /dev/null
+++ b/module/srfi/srfi-160/s8-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The s8s appearing in the code are expanded to u8, s8, etc.
+
+;; make-s8vector defined in (srfi 160 base)
+
+;; s8vector defined in (srfi 160 base)
+
+(define (s8vector-unfold f len seed)
+ (let ((v (make-s8vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (s8vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (s8vector-unfold-right f len seed)
+ (let ((v (make-s8vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (s8vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define s8vector-copy
+ (case-lambda
+ ((vec) (s8vector-copy* vec 0 (s8vector-length vec)))
+ ((vec start) (s8vector-copy* vec start (s8vector-length vec)))
+ ((vec start end) (s8vector-copy* vec start end))))
+
+(define (s8vector-copy* vec start end)
+ (let ((v (make-s8vector (- end start))))
+ (s8vector-copy! v 0 vec start end)
+ v))
+
+(define s8vector-copy!
+ (case-lambda
+ ((to at from)
+ (s8vector-copy!* to at from 0 (s8vector-length from)))
+ ((to at from start)
+ (s8vector-copy!* to at from start (s8vector-length from)))
+ ((to at from start end) (s8vector-copy!* to at from start end))))
+
+(define (s8vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (s8vector-set! to at (s8vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define s8vector-reverse-copy
+ (case-lambda
+ ((vec) (s8vector-reverse-copy* vec 0 (s8vector-length vec)))
+ ((vec start) (s8vector-reverse-copy* vec start (s8vector-length vec)))
+ ((vec start end) (s8vector-reverse-copy* vec start end))))
+
+(define (s8vector-reverse-copy* vec start end)
+ (let ((v (make-s8vector (- end start))))
+ (s8vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define s8vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (s8vector-reverse-copy!* to at from 0 (s8vector-length from)))
+ ((to at from start)
+ (s8vector-reverse-copy!* to at from start (s8vector-length from)))
+ ((to at from start end) (s8vector-reverse-copy!* to at from start end))))
+
+(define (s8vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (s8vector-set! to at (s8vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (s8vector-append . vecs)
+ (s8vector-concatenate vecs))
+
+(define (s8vector-concatenate vecs)
+ (let ((v (make-s8vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (s8vector-copy! v at vec 0 (s8vector-length vec))
+ (loop (cdr vecs) (+ at (s8vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (s8vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (s8vector-append-subvectors . args)
+ (let ((v (make-s8vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (s8vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; s8? defined in (srfi 160 base)
+
+;; s8vector? defined in (srfi 160 base)
+
+(define (s8vector-empty? vec)
+ (zero? (s8vector-length vec)))
+
+(define (s8vector= . vecs)
+ (s8vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (s8vector=* vec1 vec2 vecs)
+ (and (s8dyadic-vecs= vec1 0 (s8vector-length vec1)
+ vec2 0 (s8vector-length vec2))
+ (or (null? vecs)
+ (s8vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (s8dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (s8vector-ref vec1 start1))
+ (elt2 (s8vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (s8dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; s8vector-ref defined in (srfi 160 base)
+
+;; s8vector-length defined in (srfi 160 base)
+
+(define (s8vector-take vec n)
+ (let ((v (make-s8vector n)))
+ (s8vector-copy! v 0 vec 0 n)
+ v))
+
+(define (s8vector-take-right vec n)
+ (let ((v (make-s8vector n))
+ (len (s8vector-length vec)))
+ (s8vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (s8vector-drop vec n)
+ (let* ((len (s8vector-length vec))
+ (vlen (- len n))
+ (v (make-s8vector vlen)))
+ (s8vector-copy! v 0 vec n len)
+ v))
+
+(define (s8vector-drop-right vec n)
+ (let* ((len (s8vector-length vec))
+ (rlen (- len n))
+ (v (make-s8vector rlen)))
+ (s8vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (s8vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (s8vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (s8vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%s8vectors-ref vecs i)
+ (map (lambda (v) (s8vector-ref v i)) vecs))
+
+(define (s8vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (s8vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%s8vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (s8vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((r knil) (i (- (s8vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (s8vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%s8vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (s8vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (s8vector-length vec))
+ (v (make-s8vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s8vector-set! v i (f (s8vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs)))
+ (v (make-s8vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s8vector-set! v i (apply f (%s8vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (s8vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s8vector-set! vec i (f (s8vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (s8vector-set! vec i (apply f (%s8vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (s8vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s8vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%s8vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (s8vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (s8vector-length vec)) r)
+ ((pred (s8vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%s8vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (s8vector-cumulate f knil vec)
+ (let* ((len (s8vector-length vec))
+ (v (make-s8vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (s8vector-ref vec i))))
+ (s8vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (s8vector-foreach f vec)
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (s8vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (s8vector-take-while pred vec)
+ (let* ((len (s8vector-length vec))
+ (idx (s8vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s8vector-copy vec 0 idx*)))
+
+(define (s8vector-take-while-right pred vec)
+ (let* ((len (s8vector-length vec))
+ (idx (s8vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (s8vector-copy vec idx* len)))
+
+(define (s8vector-drop-while pred vec)
+ (let* ((len (s8vector-length vec))
+ (idx (s8vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (s8vector-copy vec idx* len)))
+
+(define (s8vector-drop-while-right pred vec)
+ (let* ((len (s8vector-length vec))
+ (idx (s8vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (s8vector-copy vec 0 (+ 1 idx*))))
+
+(define (s8vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s8vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s8vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (s8vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (s8vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%s8vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (s8vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (s8vector-index (lambda (x) (not (pred x))) vec)
+ (apply s8vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s8vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (s8vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply s8vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (s8vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (s8vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%s8vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (s8vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (s8vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (s8vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map s8vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%s8vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (s8vector-partition pred vec)
+ (let* ((len (s8vector-length vec))
+ (cnt (s8vector-count pred vec))
+ (r (make-s8vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (s8vector-ref vec i))
+ (s8vector-set! r yes (s8vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (s8vector-set! r no (s8vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (s8vector-filter pred vec)
+ (let* ((len (s8vector-length vec))
+ (cnt (s8vector-count pred vec))
+ (r (make-s8vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (s8vector-ref vec i))
+ (s8vector-set! r j (s8vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (s8vector-remove pred vec)
+ (s8vector-filter (lambda (x) (not (pred x))) vec))
+
+;; s8vector-set! defined in (srfi 160 base)
+
+(define (s8vector-swap! vec i j)
+ (let ((ival (s8vector-ref vec i))
+ (jval (s8vector-ref vec j)))
+ (s8vector-set! vec i jval)
+ (s8vector-set! vec j ival)))
+
+(define s8vector-fill!
+ (case-lambda
+ ((vec fill) (s8vector-fill-some! vec fill 0 (s8vector-length vec)))
+ ((vec fill start) (s8vector-fill-some! vec fill start (s8vector-length vec)))
+ ((vec fill start end) (s8vector-fill-some! vec fill start end))))
+
+(define (s8vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (s8vector-set! vec start fill)
+ (s8vector-fill-some! vec fill (+ start 1) end)))
+
+(define s8vector-reverse!
+ (case-lambda
+ ((vec) (s8vector-reverse-some! vec 0 (s8vector-length vec)))
+ ((vec start) (s8vector-reverse-some! vec start (s8vector-length vec)))
+ ((vec start end) (s8vector-reverse-some! vec start end))))
+
+(define (s8vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (s8vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (s8vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (s8vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (s8vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (s8vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-s8vector->list
+ (case-lambda
+ ((vec) (reverse-s8vector->list* vec 0 (s8vector-length vec)))
+ ((vec start) (reverse-s8vector->list* vec start (s8vector-length vec)))
+ ((vec start end) (reverse-s8vector->list* vec start end))))
+
+(define (reverse-s8vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (s8vector-ref vec i) r)))))
+
+(define (reverse-list->s8vector list)
+ (let* ((len (length list))
+ (r (make-s8vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (s8vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define s8vector->vector
+ (case-lambda
+ ((vec) (s8vector->vector* vec 0 (s8vector-length vec)))
+ ((vec start) (s8vector->vector* vec start (s8vector-length vec)))
+ ((vec start end) (s8vector->vector* vec start end))))
+
+(define (s8vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (s8vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->s8vector
+ (case-lambda
+ ((vec) (vector->s8vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->s8vector* vec start (vector-length vec)))
+ ((vec start end) (vector->s8vector* vec start end))))
+
+(define (vector->s8vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-s8vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (s8vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-s8vector-generator
+ (case-lambda ((vec) (make-s8vector-generator vec 0 (s8vector-length vec)))
+ ((vec start) (make-s8vector-generator vec start (s8vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (s8vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-s8vector
+ (case-lambda
+ ((vec) (write-s8vector* vec (current-output-port)))
+ ((vec port) (write-s8vector* vec port))))
+
+
+(define (write-s8vector* vec port)
+ (display "#s8(" port) ; s8-expansion is blind, so will expand this too
+ (let ((last (- (s8vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (s8vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (s8vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (s8vector< vec1 vec2)
+ (let ((len1 (s8vector-length vec1))
+ (len2 (s8vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (s8vector-ref vec1 i) (s8vector-ref vec2 i))
+ #t)
+ ((> (s8vector-ref vec1 i) (s8vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (s8vector-hash vec)
+ (let ((len (min 256 (s8vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (s8vector-ref vec i)))))))
+
+(define s8vector-comparator
+ (make-comparator s8vector? s8vector= s8vector< s8vector-hash))
diff --git a/module/srfi/srfi-160/s8.sld b/module/srfi/srfi-160/s8.sld
new file mode 100644
index 000000000..ed31b0c8d
--- /dev/null
+++ b/module/srfi/srfi-160/s8.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 s8)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-s8vector s8vector
+ s8vector-unfold s8vector-unfold-right
+ s8vector-copy s8vector-reverse-copy
+ s8vector-append s8vector-concatenate
+ s8vector-append-subvectors)
+ ;; Predicates
+ (export s8? s8vector? s8vector-empty? s8vector=)
+ ;; Selectors
+ (export s8vector-ref s8vector-length)
+ ;; Iteration
+ (export s8vector-take s8vector-take-right
+ s8vector-drop s8vector-drop-right
+ s8vector-segment
+ s8vector-fold s8vector-fold-right
+ s8vector-map s8vector-map! s8vector-for-each
+ s8vector-count s8vector-cumulate)
+ ;; Searching
+ (export s8vector-take-while s8vector-take-while-right
+ s8vector-drop-while s8vector-drop-while-right
+ s8vector-index s8vector-index-right s8vector-skip s8vector-skip-right
+ s8vector-any s8vector-every s8vector-partition
+ s8vector-filter s8vector-remove)
+ ;; Mutators
+ (export s8vector-set! s8vector-swap! s8vector-fill! s8vector-reverse!
+ s8vector-copy! s8vector-reverse-copy!
+ s8vector-unfold! s8vector-unfold-right!)
+ ;; Conversion
+ (export s8vector->list list->s8vector
+ reverse-s8vector->list reverse-list->s8vector
+ s8vector->vector vector->s8vector)
+ ;; Misc
+ (export make-s8vector-generator s8vector-comparator write-s8vector)
+
+ (include "s8-impl.scm")
+)
diff --git a/module/srfi/srfi-160/u16-impl.scm b/module/srfi/srfi-160/u16-impl.scm
new file mode 100644
index 000000000..af1dcfc99
--- /dev/null
+++ b/module/srfi/srfi-160/u16-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The u16s appearing in the code are expanded to u8, s8, etc.
+
+;; make-u16vector defined in (srfi 160 base)
+
+;; u16vector defined in (srfi 160 base)
+
+(define (u16vector-unfold f len seed)
+ (let ((v (make-u16vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (u16vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (u16vector-unfold-right f len seed)
+ (let ((v (make-u16vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (u16vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define u16vector-copy
+ (case-lambda
+ ((vec) (u16vector-copy* vec 0 (u16vector-length vec)))
+ ((vec start) (u16vector-copy* vec start (u16vector-length vec)))
+ ((vec start end) (u16vector-copy* vec start end))))
+
+(define (u16vector-copy* vec start end)
+ (let ((v (make-u16vector (- end start))))
+ (u16vector-copy! v 0 vec start end)
+ v))
+
+(define u16vector-copy!
+ (case-lambda
+ ((to at from)
+ (u16vector-copy!* to at from 0 (u16vector-length from)))
+ ((to at from start)
+ (u16vector-copy!* to at from start (u16vector-length from)))
+ ((to at from start end) (u16vector-copy!* to at from start end))))
+
+(define (u16vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (u16vector-set! to at (u16vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define u16vector-reverse-copy
+ (case-lambda
+ ((vec) (u16vector-reverse-copy* vec 0 (u16vector-length vec)))
+ ((vec start) (u16vector-reverse-copy* vec start (u16vector-length vec)))
+ ((vec start end) (u16vector-reverse-copy* vec start end))))
+
+(define (u16vector-reverse-copy* vec start end)
+ (let ((v (make-u16vector (- end start))))
+ (u16vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define u16vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u16vector-reverse-copy!* to at from 0 (u16vector-length from)))
+ ((to at from start)
+ (u16vector-reverse-copy!* to at from start (u16vector-length from)))
+ ((to at from start end) (u16vector-reverse-copy!* to at from start end))))
+
+(define (u16vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (u16vector-set! to at (u16vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (u16vector-append . vecs)
+ (u16vector-concatenate vecs))
+
+(define (u16vector-concatenate vecs)
+ (let ((v (make-u16vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (u16vector-copy! v at vec 0 (u16vector-length vec))
+ (loop (cdr vecs) (+ at (u16vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (u16vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (u16vector-append-subvectors . args)
+ (let ((v (make-u16vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (u16vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; u16? defined in (srfi 160 base)
+
+;; u16vector? defined in (srfi 160 base)
+
+(define (u16vector-empty? vec)
+ (zero? (u16vector-length vec)))
+
+(define (u16vector= . vecs)
+ (u16vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (u16vector=* vec1 vec2 vecs)
+ (and (u16dyadic-vecs= vec1 0 (u16vector-length vec1)
+ vec2 0 (u16vector-length vec2))
+ (or (null? vecs)
+ (u16vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (u16dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (u16vector-ref vec1 start1))
+ (elt2 (u16vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (u16dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; u16vector-ref defined in (srfi 160 base)
+
+;; u16vector-length defined in (srfi 160 base)
+
+(define (u16vector-take vec n)
+ (let ((v (make-u16vector n)))
+ (u16vector-copy! v 0 vec 0 n)
+ v))
+
+(define (u16vector-take-right vec n)
+ (let ((v (make-u16vector n))
+ (len (u16vector-length vec)))
+ (u16vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (u16vector-drop vec n)
+ (let* ((len (u16vector-length vec))
+ (vlen (- len n))
+ (v (make-u16vector vlen)))
+ (u16vector-copy! v 0 vec n len)
+ v))
+
+(define (u16vector-drop-right vec n)
+ (let* ((len (u16vector-length vec))
+ (rlen (- len n))
+ (v (make-u16vector rlen)))
+ (u16vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (u16vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (u16vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (u16vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%u16vectors-ref vecs i)
+ (map (lambda (v) (u16vector-ref v i)) vecs))
+
+(define (u16vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (u16vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%u16vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (u16vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((r knil) (i (- (u16vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (u16vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%u16vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (u16vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (u16vector-length vec))
+ (v (make-u16vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u16vector-set! v i (f (u16vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs)))
+ (v (make-u16vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u16vector-set! v i (apply f (%u16vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (u16vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u16vector-set! vec i (f (u16vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u16vector-set! vec i (apply f (%u16vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (u16vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u16vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%u16vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (u16vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (u16vector-length vec)) r)
+ ((pred (u16vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%u16vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (u16vector-cumulate f knil vec)
+ (let* ((len (u16vector-length vec))
+ (v (make-u16vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (u16vector-ref vec i))))
+ (u16vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (u16vector-foreach f vec)
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u16vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (u16vector-take-while pred vec)
+ (let* ((len (u16vector-length vec))
+ (idx (u16vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u16vector-copy vec 0 idx*)))
+
+(define (u16vector-take-while-right pred vec)
+ (let* ((len (u16vector-length vec))
+ (idx (u16vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (u16vector-copy vec idx* len)))
+
+(define (u16vector-drop-while pred vec)
+ (let* ((len (u16vector-length vec))
+ (idx (u16vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u16vector-copy vec idx* len)))
+
+(define (u16vector-drop-while-right pred vec)
+ (let* ((len (u16vector-length vec))
+ (idx (u16vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (u16vector-copy vec 0 (+ 1 idx*))))
+
+(define (u16vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u16vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u16vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (u16vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (u16vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%u16vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (u16vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (u16vector-index (lambda (x) (not (pred x))) vec)
+ (apply u16vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u16vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (u16vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply u16vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u16vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u16vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u16vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (u16vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u16vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (u16vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u16vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%u16vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (u16vector-partition pred vec)
+ (let* ((len (u16vector-length vec))
+ (cnt (u16vector-count pred vec))
+ (r (make-u16vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (u16vector-ref vec i))
+ (u16vector-set! r yes (u16vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (u16vector-set! r no (u16vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (u16vector-filter pred vec)
+ (let* ((len (u16vector-length vec))
+ (cnt (u16vector-count pred vec))
+ (r (make-u16vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (u16vector-ref vec i))
+ (u16vector-set! r j (u16vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (u16vector-remove pred vec)
+ (u16vector-filter (lambda (x) (not (pred x))) vec))
+
+;; u16vector-set! defined in (srfi 160 base)
+
+(define (u16vector-swap! vec i j)
+ (let ((ival (u16vector-ref vec i))
+ (jval (u16vector-ref vec j)))
+ (u16vector-set! vec i jval)
+ (u16vector-set! vec j ival)))
+
+(define u16vector-fill!
+ (case-lambda
+ ((vec fill) (u16vector-fill-some! vec fill 0 (u16vector-length vec)))
+ ((vec fill start) (u16vector-fill-some! vec fill start (u16vector-length vec)))
+ ((vec fill start end) (u16vector-fill-some! vec fill start end))))
+
+(define (u16vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (u16vector-set! vec start fill)
+ (u16vector-fill-some! vec fill (+ start 1) end)))
+
+(define u16vector-reverse!
+ (case-lambda
+ ((vec) (u16vector-reverse-some! vec 0 (u16vector-length vec)))
+ ((vec start) (u16vector-reverse-some! vec start (u16vector-length vec)))
+ ((vec start end) (u16vector-reverse-some! vec start end))))
+
+(define (u16vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (u16vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (u16vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (u16vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (u16vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (u16vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-u16vector->list
+ (case-lambda
+ ((vec) (reverse-u16vector->list* vec 0 (u16vector-length vec)))
+ ((vec start) (reverse-u16vector->list* vec start (u16vector-length vec)))
+ ((vec start end) (reverse-u16vector->list* vec start end))))
+
+(define (reverse-u16vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (u16vector-ref vec i) r)))))
+
+(define (reverse-list->u16vector list)
+ (let* ((len (length list))
+ (r (make-u16vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (u16vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define u16vector->vector
+ (case-lambda
+ ((vec) (u16vector->vector* vec 0 (u16vector-length vec)))
+ ((vec start) (u16vector->vector* vec start (u16vector-length vec)))
+ ((vec start end) (u16vector->vector* vec start end))))
+
+(define (u16vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (u16vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->u16vector
+ (case-lambda
+ ((vec) (vector->u16vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->u16vector* vec start (vector-length vec)))
+ ((vec start end) (vector->u16vector* vec start end))))
+
+(define (vector->u16vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-u16vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (u16vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-u16vector-generator
+ (case-lambda ((vec) (make-u16vector-generator vec 0 (u16vector-length vec)))
+ ((vec start) (make-u16vector-generator vec start (u16vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (u16vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-u16vector
+ (case-lambda
+ ((vec) (write-u16vector* vec (current-output-port)))
+ ((vec port) (write-u16vector* vec port))))
+
+
+(define (write-u16vector* vec port)
+ (display "#u16(" port) ; u16-expansion is blind, so will expand this too
+ (let ((last (- (u16vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (u16vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (u16vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (u16vector< vec1 vec2)
+ (let ((len1 (u16vector-length vec1))
+ (len2 (u16vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (u16vector-ref vec1 i) (u16vector-ref vec2 i))
+ #t)
+ ((> (u16vector-ref vec1 i) (u16vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (u16vector-hash vec)
+ (let ((len (min 256 (u16vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (u16vector-ref vec i)))))))
+
+(define u16vector-comparator
+ (make-comparator u16vector? u16vector= u16vector< u16vector-hash))
diff --git a/module/srfi/srfi-160/u16.sld b/module/srfi/srfi-160/u16.sld
new file mode 100644
index 000000000..5e4e3f2fa
--- /dev/null
+++ b/module/srfi/srfi-160/u16.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 u16)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-u16vector u16vector
+ u16vector-unfold u16vector-unfold-right
+ u16vector-copy u16vector-reverse-copy
+ u16vector-append u16vector-concatenate
+ u16vector-append-subvectors)
+ ;; Predicates
+ (export u16? u16vector? u16vector-empty? u16vector=)
+ ;; Selectors
+ (export u16vector-ref u16vector-length)
+ ;; Iteration
+ (export u16vector-take u16vector-take-right
+ u16vector-drop u16vector-drop-right
+ u16vector-segment
+ u16vector-fold u16vector-fold-right
+ u16vector-map u16vector-map! u16vector-for-each
+ u16vector-count u16vector-cumulate)
+ ;; Searching
+ (export u16vector-take-while u16vector-take-while-right
+ u16vector-drop-while u16vector-drop-while-right
+ u16vector-index u16vector-index-right u16vector-skip u16vector-skip-right
+ u16vector-any u16vector-every u16vector-partition
+ u16vector-filter u16vector-remove)
+ ;; Mutators
+ (export u16vector-set! u16vector-swap! u16vector-fill! u16vector-reverse!
+ u16vector-copy! u16vector-reverse-copy!
+ u16vector-unfold! u16vector-unfold-right!)
+ ;; Conversion
+ (export u16vector->list list->u16vector
+ reverse-u16vector->list reverse-list->u16vector
+ u16vector->vector vector->u16vector)
+ ;; Misc
+ (export make-u16vector-generator u16vector-comparator write-u16vector)
+
+ (include "u16-impl.scm")
+)
diff --git a/module/srfi/srfi-160/u32-impl.scm b/module/srfi/srfi-160/u32-impl.scm
new file mode 100644
index 000000000..36cff8110
--- /dev/null
+++ b/module/srfi/srfi-160/u32-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The u32s appearing in the code are expanded to u8, s8, etc.
+
+;; make-u32vector defined in (srfi 160 base)
+
+;; u32vector defined in (srfi 160 base)
+
+(define (u32vector-unfold f len seed)
+ (let ((v (make-u32vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (u32vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (u32vector-unfold-right f len seed)
+ (let ((v (make-u32vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (u32vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define u32vector-copy
+ (case-lambda
+ ((vec) (u32vector-copy* vec 0 (u32vector-length vec)))
+ ((vec start) (u32vector-copy* vec start (u32vector-length vec)))
+ ((vec start end) (u32vector-copy* vec start end))))
+
+(define (u32vector-copy* vec start end)
+ (let ((v (make-u32vector (- end start))))
+ (u32vector-copy! v 0 vec start end)
+ v))
+
+(define u32vector-copy!
+ (case-lambda
+ ((to at from)
+ (u32vector-copy!* to at from 0 (u32vector-length from)))
+ ((to at from start)
+ (u32vector-copy!* to at from start (u32vector-length from)))
+ ((to at from start end) (u32vector-copy!* to at from start end))))
+
+(define (u32vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (u32vector-set! to at (u32vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define u32vector-reverse-copy
+ (case-lambda
+ ((vec) (u32vector-reverse-copy* vec 0 (u32vector-length vec)))
+ ((vec start) (u32vector-reverse-copy* vec start (u32vector-length vec)))
+ ((vec start end) (u32vector-reverse-copy* vec start end))))
+
+(define (u32vector-reverse-copy* vec start end)
+ (let ((v (make-u32vector (- end start))))
+ (u32vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define u32vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u32vector-reverse-copy!* to at from 0 (u32vector-length from)))
+ ((to at from start)
+ (u32vector-reverse-copy!* to at from start (u32vector-length from)))
+ ((to at from start end) (u32vector-reverse-copy!* to at from start end))))
+
+(define (u32vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (u32vector-set! to at (u32vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (u32vector-append . vecs)
+ (u32vector-concatenate vecs))
+
+(define (u32vector-concatenate vecs)
+ (let ((v (make-u32vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (u32vector-copy! v at vec 0 (u32vector-length vec))
+ (loop (cdr vecs) (+ at (u32vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (u32vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (u32vector-append-subvectors . args)
+ (let ((v (make-u32vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (u32vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; u32? defined in (srfi 160 base)
+
+;; u32vector? defined in (srfi 160 base)
+
+(define (u32vector-empty? vec)
+ (zero? (u32vector-length vec)))
+
+(define (u32vector= . vecs)
+ (u32vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (u32vector=* vec1 vec2 vecs)
+ (and (u32dyadic-vecs= vec1 0 (u32vector-length vec1)
+ vec2 0 (u32vector-length vec2))
+ (or (null? vecs)
+ (u32vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (u32dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (u32vector-ref vec1 start1))
+ (elt2 (u32vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (u32dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; u32vector-ref defined in (srfi 160 base)
+
+;; u32vector-length defined in (srfi 160 base)
+
+(define (u32vector-take vec n)
+ (let ((v (make-u32vector n)))
+ (u32vector-copy! v 0 vec 0 n)
+ v))
+
+(define (u32vector-take-right vec n)
+ (let ((v (make-u32vector n))
+ (len (u32vector-length vec)))
+ (u32vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (u32vector-drop vec n)
+ (let* ((len (u32vector-length vec))
+ (vlen (- len n))
+ (v (make-u32vector vlen)))
+ (u32vector-copy! v 0 vec n len)
+ v))
+
+(define (u32vector-drop-right vec n)
+ (let* ((len (u32vector-length vec))
+ (rlen (- len n))
+ (v (make-u32vector rlen)))
+ (u32vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (u32vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (u32vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (u32vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%u32vectors-ref vecs i)
+ (map (lambda (v) (u32vector-ref v i)) vecs))
+
+(define (u32vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (u32vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%u32vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (u32vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((r knil) (i (- (u32vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (u32vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%u32vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (u32vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (u32vector-length vec))
+ (v (make-u32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u32vector-set! v i (f (u32vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs)))
+ (v (make-u32vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u32vector-set! v i (apply f (%u32vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (u32vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u32vector-set! vec i (f (u32vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u32vector-set! vec i (apply f (%u32vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (u32vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u32vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%u32vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (u32vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (u32vector-length vec)) r)
+ ((pred (u32vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%u32vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (u32vector-cumulate f knil vec)
+ (let* ((len (u32vector-length vec))
+ (v (make-u32vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (u32vector-ref vec i))))
+ (u32vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (u32vector-foreach f vec)
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u32vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (u32vector-take-while pred vec)
+ (let* ((len (u32vector-length vec))
+ (idx (u32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u32vector-copy vec 0 idx*)))
+
+(define (u32vector-take-while-right pred vec)
+ (let* ((len (u32vector-length vec))
+ (idx (u32vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (u32vector-copy vec idx* len)))
+
+(define (u32vector-drop-while pred vec)
+ (let* ((len (u32vector-length vec))
+ (idx (u32vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u32vector-copy vec idx* len)))
+
+(define (u32vector-drop-while-right pred vec)
+ (let* ((len (u32vector-length vec))
+ (idx (u32vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (u32vector-copy vec 0 (+ 1 idx*))))
+
+(define (u32vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u32vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u32vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (u32vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (u32vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%u32vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (u32vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (u32vector-index (lambda (x) (not (pred x))) vec)
+ (apply u32vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u32vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (u32vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply u32vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u32vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u32vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u32vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (u32vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u32vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (u32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u32vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%u32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (u32vector-partition pred vec)
+ (let* ((len (u32vector-length vec))
+ (cnt (u32vector-count pred vec))
+ (r (make-u32vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (u32vector-ref vec i))
+ (u32vector-set! r yes (u32vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (u32vector-set! r no (u32vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (u32vector-filter pred vec)
+ (let* ((len (u32vector-length vec))
+ (cnt (u32vector-count pred vec))
+ (r (make-u32vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (u32vector-ref vec i))
+ (u32vector-set! r j (u32vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (u32vector-remove pred vec)
+ (u32vector-filter (lambda (x) (not (pred x))) vec))
+
+;; u32vector-set! defined in (srfi 160 base)
+
+(define (u32vector-swap! vec i j)
+ (let ((ival (u32vector-ref vec i))
+ (jval (u32vector-ref vec j)))
+ (u32vector-set! vec i jval)
+ (u32vector-set! vec j ival)))
+
+(define u32vector-fill!
+ (case-lambda
+ ((vec fill) (u32vector-fill-some! vec fill 0 (u32vector-length vec)))
+ ((vec fill start) (u32vector-fill-some! vec fill start (u32vector-length vec)))
+ ((vec fill start end) (u32vector-fill-some! vec fill start end))))
+
+(define (u32vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (u32vector-set! vec start fill)
+ (u32vector-fill-some! vec fill (+ start 1) end)))
+
+(define u32vector-reverse!
+ (case-lambda
+ ((vec) (u32vector-reverse-some! vec 0 (u32vector-length vec)))
+ ((vec start) (u32vector-reverse-some! vec start (u32vector-length vec)))
+ ((vec start end) (u32vector-reverse-some! vec start end))))
+
+(define (u32vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (u32vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (u32vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (u32vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (u32vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (u32vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-u32vector->list
+ (case-lambda
+ ((vec) (reverse-u32vector->list* vec 0 (u32vector-length vec)))
+ ((vec start) (reverse-u32vector->list* vec start (u32vector-length vec)))
+ ((vec start end) (reverse-u32vector->list* vec start end))))
+
+(define (reverse-u32vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (u32vector-ref vec i) r)))))
+
+(define (reverse-list->u32vector list)
+ (let* ((len (length list))
+ (r (make-u32vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (u32vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define u32vector->vector
+ (case-lambda
+ ((vec) (u32vector->vector* vec 0 (u32vector-length vec)))
+ ((vec start) (u32vector->vector* vec start (u32vector-length vec)))
+ ((vec start end) (u32vector->vector* vec start end))))
+
+(define (u32vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (u32vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->u32vector
+ (case-lambda
+ ((vec) (vector->u32vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->u32vector* vec start (vector-length vec)))
+ ((vec start end) (vector->u32vector* vec start end))))
+
+(define (vector->u32vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-u32vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (u32vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-u32vector-generator
+ (case-lambda ((vec) (make-u32vector-generator vec 0 (u32vector-length vec)))
+ ((vec start) (make-u32vector-generator vec start (u32vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (u32vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-u32vector
+ (case-lambda
+ ((vec) (write-u32vector* vec (current-output-port)))
+ ((vec port) (write-u32vector* vec port))))
+
+
+(define (write-u32vector* vec port)
+ (display "#u32(" port) ; u32-expansion is blind, so will expand this too
+ (let ((last (- (u32vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (u32vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (u32vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (u32vector< vec1 vec2)
+ (let ((len1 (u32vector-length vec1))
+ (len2 (u32vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (u32vector-ref vec1 i) (u32vector-ref vec2 i))
+ #t)
+ ((> (u32vector-ref vec1 i) (u32vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (u32vector-hash vec)
+ (let ((len (min 256 (u32vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (u32vector-ref vec i)))))))
+
+(define u32vector-comparator
+ (make-comparator u32vector? u32vector= u32vector< u32vector-hash))
diff --git a/module/srfi/srfi-160/u32.sld b/module/srfi/srfi-160/u32.sld
new file mode 100644
index 000000000..507eac680
--- /dev/null
+++ b/module/srfi/srfi-160/u32.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 u32)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-u32vector u32vector
+ u32vector-unfold u32vector-unfold-right
+ u32vector-copy u32vector-reverse-copy
+ u32vector-append u32vector-concatenate
+ u32vector-append-subvectors)
+ ;; Predicates
+ (export u32? u32vector? u32vector-empty? u32vector=)
+ ;; Selectors
+ (export u32vector-ref u32vector-length)
+ ;; Iteration
+ (export u32vector-take u32vector-take-right
+ u32vector-drop u32vector-drop-right
+ u32vector-segment
+ u32vector-fold u32vector-fold-right
+ u32vector-map u32vector-map! u32vector-for-each
+ u32vector-count u32vector-cumulate)
+ ;; Searching
+ (export u32vector-take-while u32vector-take-while-right
+ u32vector-drop-while u32vector-drop-while-right
+ u32vector-index u32vector-index-right u32vector-skip u32vector-skip-right
+ u32vector-any u32vector-every u32vector-partition
+ u32vector-filter u32vector-remove)
+ ;; Mutators
+ (export u32vector-set! u32vector-swap! u32vector-fill! u32vector-reverse!
+ u32vector-copy! u32vector-reverse-copy!
+ u32vector-unfold! u32vector-unfold-right!)
+ ;; Conversion
+ (export u32vector->list list->u32vector
+ reverse-u32vector->list reverse-list->u32vector
+ u32vector->vector vector->u32vector)
+ ;; Misc
+ (export make-u32vector-generator u32vector-comparator write-u32vector)
+
+ (include "u32-impl.scm")
+)
diff --git a/module/srfi/srfi-160/u64-impl.scm b/module/srfi/srfi-160/u64-impl.scm
new file mode 100644
index 000000000..6d2491742
--- /dev/null
+++ b/module/srfi/srfi-160/u64-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The u64s appearing in the code are expanded to u8, s8, etc.
+
+;; make-u64vector defined in (srfi 160 base)
+
+;; u64vector defined in (srfi 160 base)
+
+(define (u64vector-unfold f len seed)
+ (let ((v (make-u64vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (u64vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (u64vector-unfold-right f len seed)
+ (let ((v (make-u64vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (u64vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define u64vector-copy
+ (case-lambda
+ ((vec) (u64vector-copy* vec 0 (u64vector-length vec)))
+ ((vec start) (u64vector-copy* vec start (u64vector-length vec)))
+ ((vec start end) (u64vector-copy* vec start end))))
+
+(define (u64vector-copy* vec start end)
+ (let ((v (make-u64vector (- end start))))
+ (u64vector-copy! v 0 vec start end)
+ v))
+
+(define u64vector-copy!
+ (case-lambda
+ ((to at from)
+ (u64vector-copy!* to at from 0 (u64vector-length from)))
+ ((to at from start)
+ (u64vector-copy!* to at from start (u64vector-length from)))
+ ((to at from start end) (u64vector-copy!* to at from start end))))
+
+(define (u64vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (u64vector-set! to at (u64vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define u64vector-reverse-copy
+ (case-lambda
+ ((vec) (u64vector-reverse-copy* vec 0 (u64vector-length vec)))
+ ((vec start) (u64vector-reverse-copy* vec start (u64vector-length vec)))
+ ((vec start end) (u64vector-reverse-copy* vec start end))))
+
+(define (u64vector-reverse-copy* vec start end)
+ (let ((v (make-u64vector (- end start))))
+ (u64vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define u64vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u64vector-reverse-copy!* to at from 0 (u64vector-length from)))
+ ((to at from start)
+ (u64vector-reverse-copy!* to at from start (u64vector-length from)))
+ ((to at from start end) (u64vector-reverse-copy!* to at from start end))))
+
+(define (u64vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (u64vector-set! to at (u64vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (u64vector-append . vecs)
+ (u64vector-concatenate vecs))
+
+(define (u64vector-concatenate vecs)
+ (let ((v (make-u64vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (u64vector-copy! v at vec 0 (u64vector-length vec))
+ (loop (cdr vecs) (+ at (u64vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (u64vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (u64vector-append-subvectors . args)
+ (let ((v (make-u64vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (u64vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; u64? defined in (srfi 160 base)
+
+;; u64vector? defined in (srfi 160 base)
+
+(define (u64vector-empty? vec)
+ (zero? (u64vector-length vec)))
+
+(define (u64vector= . vecs)
+ (u64vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (u64vector=* vec1 vec2 vecs)
+ (and (u64dyadic-vecs= vec1 0 (u64vector-length vec1)
+ vec2 0 (u64vector-length vec2))
+ (or (null? vecs)
+ (u64vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (u64dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (u64vector-ref vec1 start1))
+ (elt2 (u64vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (u64dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; u64vector-ref defined in (srfi 160 base)
+
+;; u64vector-length defined in (srfi 160 base)
+
+(define (u64vector-take vec n)
+ (let ((v (make-u64vector n)))
+ (u64vector-copy! v 0 vec 0 n)
+ v))
+
+(define (u64vector-take-right vec n)
+ (let ((v (make-u64vector n))
+ (len (u64vector-length vec)))
+ (u64vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (u64vector-drop vec n)
+ (let* ((len (u64vector-length vec))
+ (vlen (- len n))
+ (v (make-u64vector vlen)))
+ (u64vector-copy! v 0 vec n len)
+ v))
+
+(define (u64vector-drop-right vec n)
+ (let* ((len (u64vector-length vec))
+ (rlen (- len n))
+ (v (make-u64vector rlen)))
+ (u64vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (u64vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (u64vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (u64vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%u64vectors-ref vecs i)
+ (map (lambda (v) (u64vector-ref v i)) vecs))
+
+(define (u64vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (u64vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%u64vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (u64vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((r knil) (i (- (u64vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (u64vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%u64vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (u64vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (u64vector-length vec))
+ (v (make-u64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u64vector-set! v i (f (u64vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs)))
+ (v (make-u64vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u64vector-set! v i (apply f (%u64vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (u64vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u64vector-set! vec i (f (u64vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u64vector-set! vec i (apply f (%u64vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (u64vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u64vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%u64vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (u64vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (u64vector-length vec)) r)
+ ((pred (u64vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%u64vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (u64vector-cumulate f knil vec)
+ (let* ((len (u64vector-length vec))
+ (v (make-u64vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (u64vector-ref vec i))))
+ (u64vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (u64vector-foreach f vec)
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u64vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (u64vector-take-while pred vec)
+ (let* ((len (u64vector-length vec))
+ (idx (u64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u64vector-copy vec 0 idx*)))
+
+(define (u64vector-take-while-right pred vec)
+ (let* ((len (u64vector-length vec))
+ (idx (u64vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (u64vector-copy vec idx* len)))
+
+(define (u64vector-drop-while pred vec)
+ (let* ((len (u64vector-length vec))
+ (idx (u64vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u64vector-copy vec idx* len)))
+
+(define (u64vector-drop-while-right pred vec)
+ (let* ((len (u64vector-length vec))
+ (idx (u64vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (u64vector-copy vec 0 (+ 1 idx*))))
+
+(define (u64vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u64vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u64vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (u64vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (u64vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%u64vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (u64vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (u64vector-index (lambda (x) (not (pred x))) vec)
+ (apply u64vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u64vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (u64vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply u64vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u64vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u64vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u64vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (u64vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u64vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (u64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u64vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%u64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (u64vector-partition pred vec)
+ (let* ((len (u64vector-length vec))
+ (cnt (u64vector-count pred vec))
+ (r (make-u64vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (u64vector-ref vec i))
+ (u64vector-set! r yes (u64vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (u64vector-set! r no (u64vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (u64vector-filter pred vec)
+ (let* ((len (u64vector-length vec))
+ (cnt (u64vector-count pred vec))
+ (r (make-u64vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (u64vector-ref vec i))
+ (u64vector-set! r j (u64vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (u64vector-remove pred vec)
+ (u64vector-filter (lambda (x) (not (pred x))) vec))
+
+;; u64vector-set! defined in (srfi 160 base)
+
+(define (u64vector-swap! vec i j)
+ (let ((ival (u64vector-ref vec i))
+ (jval (u64vector-ref vec j)))
+ (u64vector-set! vec i jval)
+ (u64vector-set! vec j ival)))
+
+(define u64vector-fill!
+ (case-lambda
+ ((vec fill) (u64vector-fill-some! vec fill 0 (u64vector-length vec)))
+ ((vec fill start) (u64vector-fill-some! vec fill start (u64vector-length vec)))
+ ((vec fill start end) (u64vector-fill-some! vec fill start end))))
+
+(define (u64vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (u64vector-set! vec start fill)
+ (u64vector-fill-some! vec fill (+ start 1) end)))
+
+(define u64vector-reverse!
+ (case-lambda
+ ((vec) (u64vector-reverse-some! vec 0 (u64vector-length vec)))
+ ((vec start) (u64vector-reverse-some! vec start (u64vector-length vec)))
+ ((vec start end) (u64vector-reverse-some! vec start end))))
+
+(define (u64vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (u64vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (u64vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (u64vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (u64vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (u64vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-u64vector->list
+ (case-lambda
+ ((vec) (reverse-u64vector->list* vec 0 (u64vector-length vec)))
+ ((vec start) (reverse-u64vector->list* vec start (u64vector-length vec)))
+ ((vec start end) (reverse-u64vector->list* vec start end))))
+
+(define (reverse-u64vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (u64vector-ref vec i) r)))))
+
+(define (reverse-list->u64vector list)
+ (let* ((len (length list))
+ (r (make-u64vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (u64vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define u64vector->vector
+ (case-lambda
+ ((vec) (u64vector->vector* vec 0 (u64vector-length vec)))
+ ((vec start) (u64vector->vector* vec start (u64vector-length vec)))
+ ((vec start end) (u64vector->vector* vec start end))))
+
+(define (u64vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (u64vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->u64vector
+ (case-lambda
+ ((vec) (vector->u64vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->u64vector* vec start (vector-length vec)))
+ ((vec start end) (vector->u64vector* vec start end))))
+
+(define (vector->u64vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-u64vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (u64vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-u64vector-generator
+ (case-lambda ((vec) (make-u64vector-generator vec 0 (u64vector-length vec)))
+ ((vec start) (make-u64vector-generator vec start (u64vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (u64vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-u64vector
+ (case-lambda
+ ((vec) (write-u64vector* vec (current-output-port)))
+ ((vec port) (write-u64vector* vec port))))
+
+
+(define (write-u64vector* vec port)
+ (display "#u64(" port) ; u64-expansion is blind, so will expand this too
+ (let ((last (- (u64vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (u64vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (u64vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (u64vector< vec1 vec2)
+ (let ((len1 (u64vector-length vec1))
+ (len2 (u64vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (u64vector-ref vec1 i) (u64vector-ref vec2 i))
+ #t)
+ ((> (u64vector-ref vec1 i) (u64vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (u64vector-hash vec)
+ (let ((len (min 256 (u64vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (u64vector-ref vec i)))))))
+
+(define u64vector-comparator
+ (make-comparator u64vector? u64vector= u64vector< u64vector-hash))
diff --git a/module/srfi/srfi-160/u64.sld b/module/srfi/srfi-160/u64.sld
new file mode 100644
index 000000000..15e4178c6
--- /dev/null
+++ b/module/srfi/srfi-160/u64.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+(define-library (srfi srfi-160 u64)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-u64vector u64vector
+ u64vector-unfold u64vector-unfold-right
+ u64vector-copy u64vector-reverse-copy
+ u64vector-append u64vector-concatenate
+ u64vector-append-subvectors)
+ ;; Predicates
+ (export u64? u64vector? u64vector-empty? u64vector=)
+ ;; Selectors
+ (export u64vector-ref u64vector-length)
+ ;; Iteration
+ (export u64vector-take u64vector-take-right
+ u64vector-drop u64vector-drop-right
+ u64vector-segment
+ u64vector-fold u64vector-fold-right
+ u64vector-map u64vector-map! u64vector-for-each
+ u64vector-count u64vector-cumulate)
+ ;; Searching
+ (export u64vector-take-while u64vector-take-while-right
+ u64vector-drop-while u64vector-drop-while-right
+ u64vector-index u64vector-index-right u64vector-skip u64vector-skip-right
+ u64vector-any u64vector-every u64vector-partition
+ u64vector-filter u64vector-remove)
+ ;; Mutators
+ (export u64vector-set! u64vector-swap! u64vector-fill! u64vector-reverse!
+ u64vector-copy! u64vector-reverse-copy!
+ u64vector-unfold! u64vector-unfold-right!)
+ ;; Conversion
+ (export u64vector->list list->u64vector
+ reverse-u64vector->list reverse-list->u64vector
+ u64vector->vector vector->u64vector)
+ ;; Misc
+ (export make-u64vector-generator u64vector-comparator write-u64vector)
+
+ (include "u64-impl.scm")
+)
diff --git a/module/srfi/srfi-160/u8-impl.scm b/module/srfi/srfi-160/u8-impl.scm
new file mode 100644
index 000000000..c8fafb1ef
--- /dev/null
+++ b/module/srfi/srfi-160/u8-impl.scm
@@ -0,0 +1,600 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; This code is the same for all SRFI 160 vector sizes.
+;;; The u8s appearing in the code are expanded to u8, s8, etc.
+
+;; make-u8vector defined in (srfi 160 base)
+
+;; u8vector defined in (srfi 160 base)
+
+(define (u8vector-unfold f len seed)
+ (let ((v (make-u8vector len)))
+ (let loop ((i 0) (state seed))
+ (unless (= i len)
+ (let-values (((value newstate) (f i state)))
+ (u8vector-set! v i value)
+ (loop (+ i 1) newstate))))
+ v))
+
+(define (u8vector-unfold-right f len seed)
+ (let ((v (make-u8vector len)))
+ (let loop ((i (- len 1)) (state seed))
+ (unless (= i -1)
+ (let-values (((value newstate) (f i state)))
+ (u8vector-set! v i value)
+ (loop (- i 1) newstate))))
+ v))
+
+(define u8vector-copy
+ (case-lambda
+ ((vec) (u8vector-copy* vec 0 (u8vector-length vec)))
+ ((vec start) (u8vector-copy* vec start (u8vector-length vec)))
+ ((vec start end) (u8vector-copy* vec start end))))
+
+(define (u8vector-copy* vec start end)
+ (let ((v (make-u8vector (- end start))))
+ (u8vector-copy! v 0 vec start end)
+ v))
+
+(define u8vector-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-copy!* to at from 0 (u8vector-length from)))
+ ((to at from start)
+ (u8vector-copy!* to at from start (u8vector-length from)))
+ ((to at from start end) (u8vector-copy!* to at from start end))))
+
+(define (u8vector-copy!* to at from start end)
+ (let loop ((at at) (i start))
+ (unless (= i end)
+ (u8vector-set! to at (u8vector-ref from i))
+ (loop (+ at 1) (+ i 1)))))
+
+(define u8vector-reverse-copy
+ (case-lambda
+ ((vec) (u8vector-reverse-copy* vec 0 (u8vector-length vec)))
+ ((vec start) (u8vector-reverse-copy* vec start (u8vector-length vec)))
+ ((vec start end) (u8vector-reverse-copy* vec start end))))
+
+(define (u8vector-reverse-copy* vec start end)
+ (let ((v (make-u8vector (- end start))))
+ (u8vector-reverse-copy! v 0 vec start end)
+ v))
+
+(define u8vector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-reverse-copy!* to at from 0 (u8vector-length from)))
+ ((to at from start)
+ (u8vector-reverse-copy!* to at from start (u8vector-length from)))
+ ((to at from start end) (u8vector-reverse-copy!* to at from start end))))
+
+(define (u8vector-reverse-copy!* to at from start end)
+ (let loop ((at at) (i (- end 1)))
+ (unless (< i start)
+ (u8vector-set! to at (u8vector-ref from i))
+ (loop (+ at 1) (- i 1)))))
+
+(define (u8vector-append . vecs)
+ (u8vector-concatenate vecs))
+
+(define (u8vector-concatenate vecs)
+ (let ((v (make-u8vector (len-sum vecs))))
+ (let loop ((vecs vecs) (at 0))
+ (unless (null? vecs)
+ (let ((vec (car vecs)))
+ (u8vector-copy! v at vec 0 (u8vector-length vec))
+ (loop (cdr vecs) (+ at (u8vector-length vec)))))
+ v)))
+
+(define (len-sum vecs)
+ (if (null? vecs)
+ 0
+ (+ (u8vector-length (car vecs))
+ (len-sum (cdr vecs)))))
+
+(define (u8vector-append-subvectors . args)
+ (let ((v (make-u8vector (len-subsum args))))
+ (let loop ((args args) (at 0))
+ (unless (null? args)
+ (let ((vec (car args))
+ (start (cadr args))
+ (end (caddr args)))
+ (u8vector-copy! v at vec start end)
+ (loop (cdddr args) (+ at (- end start))))))
+ v))
+
+(define (len-subsum vecs)
+ (if (null? vecs)
+ 0
+ (+ (- (caddr vecs) (cadr vecs))
+ (len-subsum (cdddr vecs)))))
+
+;; u8? defined in (srfi 160 base)
+
+;; u8vector? defined in (srfi 160 base)
+
+(define (u8vector-empty? vec)
+ (zero? (u8vector-length vec)))
+
+(define (u8vector= . vecs)
+ (u8vector=* (car vecs) (cadr vecs) (cddr vecs)))
+
+(define (u8vector=* vec1 vec2 vecs)
+ (and (u8dyadic-vecs= vec1 0 (u8vector-length vec1)
+ vec2 0 (u8vector-length vec2))
+ (or (null? vecs)
+ (u8vector=* vec2 (car vecs) (cdr vecs)))))
+
+(define (u8dyadic-vecs= vec1 start1 end1 vec2 start2 end2)
+ (cond
+ ((not (= end1 end2)) #f)
+ ((not (< start1 end1)) #t)
+ ((let ((elt1 (u8vector-ref vec1 start1))
+ (elt2 (u8vector-ref vec2 start2)))
+ (= elt1 elt2))
+ (u8dyadic-vecs= vec1 (+ start1 1) end1
+ vec2 (+ start2 1) end2))
+ (else #f)))
+
+;; u8vector-ref defined in (srfi 160 base)
+
+;; u8vector-length defined in (srfi 160 base)
+
+(define (u8vector-take vec n)
+ (let ((v (make-u8vector n)))
+ (u8vector-copy! v 0 vec 0 n)
+ v))
+
+(define (u8vector-take-right vec n)
+ (let ((v (make-u8vector n))
+ (len (u8vector-length vec)))
+ (u8vector-copy! v 0 vec (- len n) len)
+ v))
+
+(define (u8vector-drop vec n)
+ (let* ((len (u8vector-length vec))
+ (vlen (- len n))
+ (v (make-u8vector vlen)))
+ (u8vector-copy! v 0 vec n len)
+ v))
+
+(define (u8vector-drop-right vec n)
+ (let* ((len (u8vector-length vec))
+ (rlen (- len n))
+ (v (make-u8vector rlen)))
+ (u8vector-copy! v 0 vec 0 rlen)
+ v))
+
+(define (u8vector-segment vec n)
+ (unless (and (integer? n) (positive? n))
+ (error "length must be a positive integer" n))
+ (let loop ((r '()) (i 0) (remain (u8vector-length vec)))
+ (if (<= remain 0)
+ (reverse r)
+ (let ((size (min n remain)))
+ (loop
+ (cons (u8vector-copy vec i (+ i size)) r)
+ (+ i size)
+ (- remain size))))))
+
+;; aux. procedure
+(define (%u8vectors-ref vecs i)
+ (map (lambda (v) (u8vector-ref v i)) vecs))
+
+(define (u8vector-fold kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (kons r (u8vector-ref vec i)) (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((r knil) (i 0))
+ (if (= i len)
+ r
+ (loop (apply kons r (%u8vectors-ref vecs i))
+ (+ i 1)))))))
+
+(define (u8vector-fold-right kons knil vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((r knil) (i (- (u8vector-length vec) 1)))
+ (if (negative? i)
+ r
+ (loop (kons r (u8vector-ref vec i)) (- i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((r knil) (i (- len 1)))
+ (if (negative? i)
+ r
+ (loop (apply kons r (%u8vectors-ref vecs i))
+ (- i 1)))))))
+
+(define (u8vector-map f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let* ((len (u8vector-length vec))
+ (v (make-u8vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u8vector-set! v i (f (u8vector-ref vec i)))
+ (loop (+ i 1))))
+ v)
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs)))
+ (v (make-u8vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u8vector-set! v i (apply f (%u8vectors-ref vecs i)))
+ (loop (+ i 1))))
+ v)))
+
+
+(define (u8vector-map! f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u8vector-set! vec i (f (u8vector-ref vec i)))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (u8vector-set! vec i (apply f (%u8vectors-ref vecs i)))
+ (loop (+ i 1)))))))
+
+(define (u8vector-for-each f vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u8vector-ref vec i))
+ (loop (+ i 1)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f (%u8vectors-ref vecs i))
+ (loop (+ i 1)))))))
+
+(define (u8vector-count pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i (u8vector-length vec)) r)
+ ((pred (u8vector-ref vec i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0) (r 0))
+ (cond
+ ((= i len) r)
+ ((apply pred (%u8vectors-ref vecs i)) (loop (+ i 1) (+ r 1)))
+ (else (loop (+ i 1) r)))))))
+
+(define (u8vector-cumulate f knil vec)
+ (let* ((len (u8vector-length vec))
+ (v (make-u8vector len)))
+ (let loop ((r knil) (i 0))
+ (unless (= i len)
+ (let ((next (f r (u8vector-ref vec i))))
+ (u8vector-set! v i next)
+ (loop next (+ i 1)))))
+ v))
+
+(define (u8vector-foreach f vec)
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f (u8vector-ref vec i))
+ (loop (+ i 1))))))
+
+(define (u8vector-take-while pred vec)
+ (let* ((len (u8vector-length vec))
+ (idx (u8vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u8vector-copy vec 0 idx*)))
+
+(define (u8vector-take-while-right pred vec)
+ (let* ((len (u8vector-length vec))
+ (idx (u8vector-skip-right pred vec))
+ (idx* (if idx (+ idx 1) 0)))
+ (u8vector-copy vec idx* len)))
+
+(define (u8vector-drop-while pred vec)
+ (let* ((len (u8vector-length vec))
+ (idx (u8vector-skip pred vec))
+ (idx* (if idx idx len)))
+ (u8vector-copy vec idx* len)))
+
+(define (u8vector-drop-while-right pred vec)
+ (let* ((len (u8vector-length vec))
+ (idx (u8vector-skip-right pred vec))
+ (idx* (if idx idx -1)))
+ (u8vector-copy vec 0 (+ 1 idx*))))
+
+(define (u8vector-index pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u8vector-ref vec i)) i)
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u8vectors-ref vecs i)) i)
+ (else (loop (+ i 1))))))))
+
+(define (u8vector-index-right pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((pred (u8vector-ref vec i)) i)
+ (else (loop (- i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i (- len 1)))
+ (cond
+ ((negative? i) #f)
+ ((apply pred (%u8vectors-ref vecs i)) i)
+ (else (loop (- i 1))))))))
+
+(define (u8vector-skip pred vec . vecs)
+ (if (null? vecs)
+ (u8vector-index (lambda (x) (not (pred x))) vec)
+ (apply u8vector-index (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u8vector-skip-right pred vec . vecs)
+ (if (null? vecs)
+ (u8vector-index-right (lambda (x) (not (pred x))) vec)
+ (apply u8vector-index-right (lambda xs (not (apply pred xs))) vec vecs)))
+
+(define (u8vector-any pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((pred (u8vector-ref vec i))) ;returns result of pred
+ (else (loop (+ i 1))))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #f)
+ ((apply pred (%u8vectors-ref vecs i))) ;returns result of pred
+ (else (loop (+ i 1))))))))
+
+(define (u8vector-every pred vec . vecs)
+ (if (null? vecs)
+ ;; fast path
+ (let ((len (u8vector-length vec)))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((pred (u8vector-ref vec i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))
+ ;; generic case
+ (let* ((vecs (cons vec vecs))
+ (len (apply min (map u8vector-length vecs))))
+ (let loop ((i 0) (last #t))
+ (cond
+ ((= i len) last)
+ ((apply pred (%u8vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r)))
+ (else #f))))))
+
+(define (u8vector-partition pred vec)
+ (let* ((len (u8vector-length vec))
+ (cnt (u8vector-count pred vec))
+ (r (make-u8vector len)))
+ (let loop ((i 0) (yes 0) (no cnt))
+ (cond
+ ((= i len) (values r cnt))
+ ((pred (u8vector-ref vec i))
+ (u8vector-set! r yes (u8vector-ref vec i))
+ (loop (+ i 1) (+ yes 1) no))
+ (else
+ (u8vector-set! r no (u8vector-ref vec i))
+ (loop (+ i 1) yes (+ no 1)))))))
+
+(define (u8vector-filter pred vec)
+ (let* ((len (u8vector-length vec))
+ (cnt (u8vector-count pred vec))
+ (r (make-u8vector cnt)))
+ (let loop ((i 0) (j 0))
+ (cond
+ ((= i len) r)
+ ((pred (u8vector-ref vec i))
+ (u8vector-set! r j (u8vector-ref vec i))
+ (loop (+ i 1) (+ j 1)))
+ (else
+ (loop (+ i 1) j))))))
+
+(define (u8vector-remove pred vec)
+ (u8vector-filter (lambda (x) (not (pred x))) vec))
+
+;; u8vector-set! defined in (srfi 160 base)
+
+(define (u8vector-swap! vec i j)
+ (let ((ival (u8vector-ref vec i))
+ (jval (u8vector-ref vec j)))
+ (u8vector-set! vec i jval)
+ (u8vector-set! vec j ival)))
+
+(define u8vector-fill!
+ (case-lambda
+ ((vec fill) (u8vector-fill-some! vec fill 0 (u8vector-length vec)))
+ ((vec fill start) (u8vector-fill-some! vec fill start (u8vector-length vec)))
+ ((vec fill start end) (u8vector-fill-some! vec fill start end))))
+
+(define (u8vector-fill-some! vec fill start end)
+ (unless (= start end)
+ (u8vector-set! vec start fill)
+ (u8vector-fill-some! vec fill (+ start 1) end)))
+
+(define u8vector-reverse!
+ (case-lambda
+ ((vec) (u8vector-reverse-some! vec 0 (u8vector-length vec)))
+ ((vec start) (u8vector-reverse-some! vec start (u8vector-length vec)))
+ ((vec start end) (u8vector-reverse-some! vec start end))))
+
+(define (u8vector-reverse-some! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (u8vector-swap! vec i j)
+ (loop (+ i 1) (- j 1)))))
+
+(define (u8vector-unfold! f vec start end seed)
+ (let loop ((i start) (seed seed))
+ (when (< i end)
+ (let-values (((elt seed) (f i seed)))
+ (u8vector-set! vec i elt)
+ (loop (+ i 1) seed)))))
+
+(define (u8vector-unfold-right! f vec start end seed)
+ (let loop ((i (- end 1)) (seed seed))
+ (when (>= i start)
+ (let-values (((elt seed) (f i seed)))
+ (u8vector-set! vec i elt)
+ (loop (- i 1) seed)))))
+
+(define reverse-u8vector->list
+ (case-lambda
+ ((vec) (reverse-u8vector->list* vec 0 (u8vector-length vec)))
+ ((vec start) (reverse-u8vector->list* vec start (u8vector-length vec)))
+ ((vec start end) (reverse-u8vector->list* vec start end))))
+
+(define (reverse-u8vector->list* vec start end)
+ (let loop ((i start) (r '()))
+ (if (= i end)
+ r
+ (loop (+ 1 i) (cons (u8vector-ref vec i) r)))))
+
+(define (reverse-list->u8vector list)
+ (let* ((len (length list))
+ (r (make-u8vector len)))
+ (let loop ((i 0) (list list))
+ (cond
+ ((= i len) r)
+ (else
+ (u8vector-set! r (- len i 1) (car list))
+ (loop (+ i 1) (cdr list)))))))
+
+(define u8vector->vector
+ (case-lambda
+ ((vec) (u8vector->vector* vec 0 (u8vector-length vec)))
+ ((vec start) (u8vector->vector* vec start (u8vector-length vec)))
+ ((vec start end) (u8vector->vector* vec start end))))
+
+(define (u8vector->vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (vector-set! r o (u8vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define vector->u8vector
+ (case-lambda
+ ((vec) (vector->u8vector* vec 0 (vector-length vec)))
+ ((vec start) (vector->u8vector* vec start (vector-length vec)))
+ ((vec start end) (vector->u8vector* vec start end))))
+
+(define (vector->u8vector* vec start end)
+ (let* ((len (- end start))
+ (r (make-u8vector len)))
+ (let loop ((i start) (o 0))
+ (cond
+ ((= i end) r)
+ (else
+ (u8vector-set! r o (vector-ref vec i))
+ (loop (+ i 1) (+ o 1)))))))
+
+(define make-u8vector-generator
+ (case-lambda ((vec) (make-u8vector-generator vec 0 (u8vector-length vec)))
+ ((vec start) (make-u8vector-generator vec start (u8vector-length vec)))
+ ((vec start end)
+ (lambda () (if (>= start end)
+ (eof-object)
+ (let ((next (u8vector-ref vec start)))
+ (set! start (+ start 1))
+ next))))))
+
+(define write-u8vector
+ (case-lambda
+ ((vec) (write-u8vector* vec (current-output-port)))
+ ((vec port) (write-u8vector* vec port))))
+
+
+(define (write-u8vector* vec port)
+ (display "#u8(" port) ; u8-expansion is blind, so will expand this too
+ (let ((last (- (u8vector-length vec) 1)))
+ (let loop ((i 0))
+ (cond
+ ((= i last)
+ (write (u8vector-ref vec i) port)
+ (display ")" port))
+ (else
+ (write (u8vector-ref vec i) port)
+ (display " " port)
+ (loop (+ i 1)))))))
+
+(define (u8vector< vec1 vec2)
+ (let ((len1 (u8vector-length vec1))
+ (len2 (u8vector-length vec2)))
+ (cond
+ ((< len1 len2)
+ #t)
+ ((> len1 len2)
+ #f)
+ (else
+ (let loop ((i 0))
+ (cond
+ ((= i len1)
+ #f)
+ ((< (u8vector-ref vec1 i) (u8vector-ref vec2 i))
+ #t)
+ ((> (u8vector-ref vec1 i) (u8vector-ref vec2 i))
+ #f)
+ (else
+ (loop (+ i 1)))))))))
+
+(define (u8vector-hash vec)
+ (let ((len (min 256 (u8vector-length vec))))
+ (let loop ((i 0) (r 0))
+ (if (= i len)
+ (abs (floor (real-part (inexact->exact r))))
+ (loop (+ i 1) (+ r (u8vector-ref vec i)))))))
+
+(define u8vector-comparator
+ (make-comparator u8vector? u8vector= u8vector< u8vector-hash))
diff --git a/module/srfi/srfi-160/u8.sld b/module/srfi/srfi-160/u8.sld
new file mode 100644
index 000000000..6b3fbd53d
--- /dev/null
+++ b/module/srfi/srfi-160/u8.sld
@@ -0,0 +1,48 @@
+;;; SPDX-License-Identifier: MIT
+;;; Copyright © John Cowan 2018
+
+(define-library (srfi srfi-160 u8)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (scheme cxr))
+ (import (only (scheme r5rs) inexact->exact))
+ (import (scheme complex))
+ (import (scheme write))
+ (import (srfi srfi-128))
+ (import (srfi srfi-160 base))
+ ;; Constructors
+ (export make-u8vector u8vector
+ u8vector-unfold u8vector-unfold-right
+ u8vector-copy u8vector-reverse-copy
+ u8vector-append u8vector-concatenate
+ u8vector-append-subvectors)
+ ;; Predicates
+ (export u8? u8vector? u8vector-empty? u8vector=)
+ ;; Selectors
+ (export u8vector-ref u8vector-length)
+ ;; Iteration
+ (export u8vector-take u8vector-take-right
+ u8vector-drop u8vector-drop-right
+ u8vector-segment
+ u8vector-fold u8vector-fold-right
+ u8vector-map u8vector-map! u8vector-for-each
+ u8vector-count u8vector-cumulate)
+ ;; Searching
+ (export u8vector-take-while u8vector-take-while-right
+ u8vector-drop-while u8vector-drop-while-right
+ u8vector-index u8vector-index-right u8vector-skip u8vector-skip-right
+ u8vector-any u8vector-every u8vector-partition
+ u8vector-filter u8vector-remove)
+ ;; Mutators
+ (export u8vector-set! u8vector-swap! u8vector-fill! u8vector-reverse!
+ u8vector-copy! u8vector-reverse-copy!
+ u8vector-unfold! u8vector-unfold-right!)
+ ;; Conversion
+ (export u8vector->list list->u8vector
+ reverse-u8vector->list reverse-list->u8vector
+ u8vector->vector vector->u8vector)
+ ;; Misc
+ (export make-u8vector-generator u8vector-comparator write-u8vector)
+
+ (include "u8-impl.scm")
+)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f51db8830..1afac2bca 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -166,6 +166,8 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-126.test \
tests/srfi-128.test \
tests/srfi-151.test \
+ tests/srfi-160-base.test \
+ tests/srfi-160.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -216,6 +218,8 @@ EXTRA_DIST = \
tests/srfi-126-test.scm \
tests/srfi-128-test.scm \
tests/srfi-151-test.scm \
+ tests/srfi-160-base-test.scm \
+ tests/srfi-160-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-160-base-test.scm b/test-suite/tests/srfi-160-base-test.scm
new file mode 100644
index 000000000..9edf4443c
--- /dev/null
+++ b/test-suite/tests/srfi-160-base-test.scm
@@ -0,0 +1,167 @@
+;;; SPDX-License-Identifier: MIT
+;;; Copyright © John Cowan 2018
+
+;;;; Shared tests
+;;; Hvector = homogeneous vector
+
+;; Test for sameness
+
+(define relerr (expt 2 -24))
+(define (inexact-real? x) (and (number? x) (inexact? x) (real? x)))
+(define (inexact-complex? x) (and (number? x) (inexact? x) (not (real? x))))
+(define (realify z) (* (real-part z) (imag-part z)))
+
+(define (same? result expected)
+ (cond
+ ((and (inexact-real? result) (inexact-real? expected))
+ (let ((abserr (abs (* expected relerr))))
+ (<= (- expected abserr) result (+ expected abserr))))
+ ((and (inexact-complex? result) (inexact-complex? expected))
+ (let ((abserr (abs (* (realify expected) relerr))))
+ (<= (- (realify expected) abserr) (realify result) (+ (realify expected) abserr))))
+ ((and (number? result) (number? expected))
+ (= result expected))
+ ((and (pair? result) (pair? expected))
+ (list-same? result expected))
+ (else
+ (equal? result expected))))
+
+ (define (list-same? result expected)
+ (cond
+ ((and (null? result) (null? expected))
+ #t)
+ ((and (pair? result) (pair? expected))
+ (and (same? (car result) (car expected)) (list-same? (cdr result) (cdr expected))))
+ (else
+ #f)))
+
+(define-syntax is-same?
+ (syntax-rules ()
+ ((is-same? result expected)
+ (begin
+ (display "Try ")
+ (display 'result)
+ (display " is same as ")
+ (display 'expected)
+ (display "? ")
+ (if (same? result expected)
+ (display "OK")
+ (begin
+ (display result)
+ (display " ")
+ (display expected)
+ (display " FAIL")))
+ (newline)))))
+
+(define (create label value)
+ value)
+
+(define (test tag make-Hvector Hvector Hvector? Hvector-length
+ Hvector-ref Hvector-set! Hvector->list list->Hvector)
+ (display "STARTING ")
+ (display tag)
+ (display "vector TESTS:")
+ (newline)
+ (let* ((first 32.0)
+ (second 32.0+47.0i)
+ (third -47.0i)
+ (vec0 (make-Hvector 3))
+ (vec1 (make-Hvector 3 second))
+ (vec2 (Hvector first second third))
+ (vec3 (list->Hvector (list third second first))))
+ (is-same? (Hvector? vec0) #t)
+ (is-same? (Hvector? vec1) #t)
+ (is-same? (Hvector? vec2) #t)
+ (is-same? (Hvector? vec3) #t)
+ (is-same? (Hvector-length vec0) 3)
+ (is-same? (Hvector-length vec1) 3)
+ (is-same? (Hvector-length vec2) 3)
+ (is-same? (Hvector-length vec3) 3)
+ (Hvector-set! vec0 0 second)
+ (Hvector-set! vec0 1 third)
+ (Hvector-set! vec0 2 first)
+ (is-same? (Hvector-ref vec0 0) second)
+ (is-same? (Hvector-ref vec0 1) third)
+ (is-same? (Hvector-ref vec0 2) first)
+ (is-same? (Hvector-ref vec1 0) second)
+ (is-same? (Hvector-ref vec1 1) second)
+ (is-same? (Hvector-ref vec1 2) second)
+ (is-same? (Hvector-ref vec2 0) first)
+ (is-same? (Hvector-ref vec2 1) second)
+ (is-same? (Hvector-ref vec2 2) third)
+ (is-same? (Hvector-ref vec3 0) third)
+ (is-same? (Hvector-ref vec3 1) second)
+ (is-same? (Hvector-ref vec3 2) first)
+ (is-same? (Hvector->list vec0) (list second third first))
+ (is-same? (Hvector->list vec1) (list second second second))
+ (is-same? (Hvector->list vec2) (list first second third))
+ (is-same? (Hvector->list vec3) (list third second first))))
+
+(test 'c64 make-c64vector c64vector c64vector? c64vector-length
+ c64vector-ref c64vector-set! c64vector->list list->c64vector)
+
+(test 'c128 make-c128vector c128vector c128vector? c128vector-length
+ c128vector-ref c128vector-set! c128vector->list list->c128vector)
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((test-assert expr)
+ (begin
+ (display "Try ")
+ (display 'expr)
+ (display " is ")
+ (display (if expr "true OK" "false FAIL"))
+ (newline)))))
+
+(define-syntax test-not
+ (syntax-rules ()
+ ((test-assert expr)
+ (begin
+ (display "Try ")
+ (display 'expr)
+ (display " is ")
+ (display (if expr "true FAIL" "false OK"))
+ (newline)))))
+
+(define-syntax integral-tests
+ (syntax-rules ()
+ ((integral-tests pred lo hi)
+ (begin
+ (test-not (pred 1/2))
+ (test-not (pred 1.0))
+ (test-not (pred 1+2i))
+ (test-not (pred 1.0+2.0i))
+ (test-assert (pred 0))
+ (test-assert (pred hi))
+ (test-assert (pred lo))
+ (test-not (pred (+ hi 1)))
+ (test-not (pred (- lo 1)))))))
+
+(display "STARTING @? TESTS")
+(newline)
+
+(integral-tests u8? 0 255)
+(integral-tests s8? -128 127)
+(integral-tests u16? 0 65535)
+(integral-tests s16? -32768 32767)
+(integral-tests u32? 0 4294967295)
+(integral-tests s32? -2147483648 2147483647)
+(integral-tests u64? 0 18446744073709551615)
+(integral-tests s64? -9223372036854775808 9223372036854775807)
+
+(test-assert (f32? 1.0))
+(test-not (f32? 1))
+(test-not (f32? 1.0+2.0i))
+
+(test-assert (f64? 1.0))
+(test-not (f64? 1))
+(test-not (f64? 1.0+2.0i))
+
+(test-assert (c64? 1.0))
+(test-not (c64? 1))
+(test-assert (c64? 1.0+2.0i))
+
+(test-assert (c128? 1.0))
+(test-not (c128? 1))
+(test-assert (c128? 1.0+2.0i))
+
diff --git a/test-suite/tests/srfi-160-base.test b/test-suite/tests/srfi-160-base.test
new file mode 100644
index 000000000..71f00d64e
--- /dev/null
+++ b/test-suite/tests/srfi-160-base.test
@@ -0,0 +1,47 @@
+;;;; srfi-160.test --- Test suite for SRFI-160 base library. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-160-base)
+ #:use-module (srfi srfi-160 base)
+ #:use-module (srfi srfi-64))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-160-base-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/srfi-160-test.scm b/test-suite/tests/srfi-160-test.scm
new file mode 100644
index 000000000..37d7753eb
--- /dev/null
+++ b/test-suite/tests/srfi-160-test.scm
@@ -0,0 +1,262 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2018 John Cowan
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library. A 'test-begin' call is added.
+(define-syntax-rule (test arg ...)
+ (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+ (test-end))
+
+(test-begin "srfi-160 libraries")
+;;; END Guile-specific modifications.
+
+(define (times2 x) (* x 2))
+(define s5 (s16vector 1 2 3 4 5))
+(define s4 (s16vector 1 2 3 4))
+(define s5+ (s16vector 1 2 3 4 6))
+
+(define (steady i x) (values x x))
+(define (count-up i x) (values x (+ x 1)))
+(define (count-down i x) (values x (- x 1)))
+(define (odd+1 x) (if (odd? x) (+ 1 x) #f))
+(define s16vector< (comparator-ordering-predicate s16vector-comparator))
+(define s16vector-hash (comparator-hash-function s16vector-comparator))
+
+(define g (make-s16vector-generator s5))
+(define-syntax test-equiv
+ (syntax-rules ()
+ ((test-equiv expect expr)
+ (test expect (s16vector->list expr)))
+ ((test-equiv name expect expr)
+ (test name expect (s16vector->list expr)))))
+
+(test-group "s16vector"
+(test-group "s16vector/constructors"
+ (test-equiv "make" '(3 3 3 3 3) (make-s16vector 5 3))
+ (test-equiv "s16vector" '(-2 -1 0 1 2) (s16vector -2 -1 0 1 2))
+ (test-equiv "unfold up" '(10 11 12 13 14)
+ (s16vector-unfold count-up 5 10))
+ (test-equiv "unfold down" '(10 9 8 7 6)
+ (s16vector-unfold count-down 5 10))
+ (test-equiv "unfold steady" '(10 10 10 10 10)
+ (s16vector-unfold steady 5 10))
+ (test-equiv "unfold-right up" '(14 13 12 11 10)
+ (s16vector-unfold-right count-up 5 10))
+ (test-equiv "unfold-right down" '(6 7 8 9 10)
+ (s16vector-unfold-right count-down 5 10))
+ (test-equiv "unfold-right steady" '(10 10 10 10 10)
+ (s16vector-unfold-right steady 5 10))
+ (test-equiv "copy" '(1 2 3 4 5) (s16vector-copy s5))
+ (test-assert "copy2" (not (eqv? s5 (s16vector-copy s5))))
+ (test-equiv "copy3" '(2 3) (s16vector-copy s5 1 3))
+ (test-equiv "reverse-copy" '(5 4 3 2 1) (s16vector-reverse-copy s5))
+ (test-equiv "append" '(1 2 3 4 5 1 2 3 4 5)
+ (s16vector-append s5 s5))
+ (test-equiv "concatenate" '(1 2 3 4 5 1 2 3 4 5)
+ (s16vector-concatenate (list s5 s5)))
+ (test-equiv "append-subvectors" '(2 3 2 3)
+ (s16vector-append-subvectors s5 1 3 s5 1 3))
+) ; end s16vector/constructors
+
+(test-group "s16vector/predicates"
+ (test-assert "s16?" (s16? 5))
+ (test-assert "not s16?" (not (s16? 65536)))
+ (test-assert "s16vector?" (s16vector? s5))
+ (test-assert "not s16vector?" (not (s16vector? #t)))
+ (test-assert "empty" (s16vector-empty? (s16vector)))
+ (test-assert "not empty" (not (s16vector-empty? s5)))
+ (test-assert "=" (s16vector= (s16vector 1 2 3) (s16vector 1 2 3)))
+ (test-assert "= multi" (s16vector= (s16vector 1 2 3)
+ (s16vector 1 2 3)
+ (s16vector 1 2 3)))
+ (test-assert "not =" (not (s16vector= (s16vector 1 2 3) (s16vector 3 2 1))))
+ (test-assert "not =2" (not (s16vector= (s16vector 1 2 3) (s16vector 1 2))))
+ (test-assert "not = multi" (not (s16vector= (s16vector 1 2 3)
+ (s16vector 1 2 3)
+ (s16vector 3 2 1))))
+) ; end s16vector/predicates
+
+(test-group "s16vector/selectors"
+ (test "ref" 1 (s16vector-ref (s16vector 1 2 3) 0))
+ (test "length" 3 (s16vector-length (s16vector 1 2 3)))
+) ; end s16vector/selectors
+
+(test-group "s16vector/iteration"
+ (test-equiv "take" '(1 2) (s16vector-take s5 2))
+ (test-equiv "take-right" '(4 5) (s16vector-take-right s5 2))
+ (test-equiv "drop" '(3 4 5) (s16vector-drop s5 2))
+ (test-equiv "drop-right" '(1 2 3) (s16vector-drop-right s5 2))
+ (test "segment" (list (s16vector 1 2 3) (s16vector 4 5))
+ (s16vector-segment s5 3))
+ (test "fold" -6 (s16vector-fold - 0 (s16vector 1 2 3)))
+ (test "fold" '(((0 1 4) 2 5) 3 6)
+ (s16vector-fold list 0 (s16vector 1 2 3) (s16vector 4 5 6)))
+ (test "fold-right" -6 (s16vector-fold-right - 0 (s16vector 1 2 3)))
+ (test "fold-right" '(((0 3 6) 2 5) 1 4)
+ (s16vector-fold-right list 0 (s16vector 1 2 3) (s16vector 4 5 6)))
+ (test-equiv "map" '(-1 -2 -3 -4 -5) (s16vector-map - s5))
+ (test-equiv "map" '(-2 -4 -6 -8 -10) (s16vector-map - s5 s5 s5 s5))
+ (let ((v (s16vector 1 2 3 4 5)))
+ (s16vector-map! - v)
+ (test-equiv "map!" '(-1 -2 -3 -4 -5) v))
+ (let ((v (s16vector 1 2 3 4 5))
+ (v2 (s16vector 6 7 8 9 10)))
+ (s16vector-map! + v v2)
+ (test-equiv "map!" '(7 9 11 13 15) v))
+ (let ((list '()))
+ (s16vector-for-each
+ (lambda (e) (set! list (cons e list)))
+ s5)
+ ;; stupid hack to shut up test egg about testing the value of a variable
+ (test "for-each" '(5 4 3 2 1) (cons (car list) (cdr list))))
+ (let ((list '()))
+ (s16vector-for-each
+ (lambda (e1 e2) (set! list (cons (cons e1 e2) list)))
+ s5
+ (s16vector 6 7 8 9 10))
+ ;; stupid hack to shut up test egg about testing the value of a variable
+ (test "for-each" '((5 . 10) (4 . 9) (3 . 8) (2 . 7) (1 . 6))
+ (cons (car list) (cdr list))))
+ (test "count" 3 (s16vector-count odd? s5))
+ (test "count" 2 (s16vector-count > s5 (s16vector 9 2 1 5 3)))
+ (test-equiv "cumulate" '(1 3 6 10 15)
+ (s16vector-cumulate + 0 s5))
+) ; end s16vector/iteration
+
+(test-group "s16vector/searching"
+ (test-equiv "take-while" '(1) (s16vector-take-while odd? s5))
+ (test-equiv "take-while-right" '(5) (s16vector-take-while-right odd? s5))
+ (test-equiv "drop-while" '(2 3 4 5) (s16vector-drop-while odd? s5))
+ (test-equiv "drop-while-right" '(1 2 3 4) (s16vector-drop-while-right odd? s5))
+ (test-equiv "degenerate take-while" '() (s16vector-take-while inexact? s5))
+ (test-equiv "degenerate take-while-right" '() (s16vector-take-while-right inexact? s5))
+ (test-equiv "degenerate drop-while" '(1 2 3 4 5) (s16vector-drop-while inexact? s5))
+ (test-equiv "degenerate drop-while-right" '(1 2 3 4 5) (s16vector-drop-while-right inexact? s5))
+ (test "index" 1 (s16vector-index even? s5))
+ (test "index" 2 (s16vector-index < s5 (s16vector 0 0 10 10 0)))
+ (test "index-right" 3 (s16vector-index-right even? s5))
+ (test "index-right" 3 (s16vector-index-right < s5 (s16vector 0 0 10 10 0)))
+ (test "skip" 1 (s16vector-skip odd? s5))
+ (test "skip" 2 (s16vector-skip > s5 (s16vector 0 0 10 10 0)))
+ (test "skip-right" 3 (s16vector-skip-right odd? s5))
+ (test "skip-right" 3 (s16vector-skip-right > s5 (s16vector 0 0 10 10 0)))
+ (test "any" 4 (s16vector-any (lambda (x) (and (even? x) (* x 2))) s5))
+ (test-assert "not any" (not (s16vector-any inexact? s5)))
+ (test "any + 1" 2 (s16vector-any odd+1 s5))
+ (test-assert "every" (s16vector-every exact? s5))
+ (test-assert "not every" (not (s16vector-every odd? s5)))
+ (test-assert "every + 1" (not (s16vector-every odd+1 s5)))
+ (test "multi-any" 10 (s16vector-any (lambda (x y) (and (even? x) (even? y) (+ x y)))
+ s5 (s16vector 0 1 2 6 4)))
+ (test "multi-any 2" #f (s16vector-any (lambda (x y) (and (even? x) (even? y) (+ x y)))
+ s5 (s16vector 0 1 2 5 4)))
+ (test "multi-every" 10 (s16vector-every (lambda (x) (and (exact? x) (* x 2))) s5))
+ (test "multi-every-2" 10 (s16vector-every (lambda (x y) (and (exact? x) (exact? y) (+ x y)))
+ s5 s5))
+ (test-assert "multi-not every" (not (s16vector-every < s5 (s16vector 10 10 10 10 0))))
+ (test-equiv "partition" '(1 3 5 2 4)
+ (call-with-values
+ (lambda () (s16vector-partition odd? s5))
+ (lambda (vec cnt) vec)))
+ (test-equiv "filter" '(1 3 5) (s16vector-filter odd? s5))
+ (test-equiv "remove" '(2 4) (s16vector-remove odd? s5))
+) ; end s16vector/searching
+
+(test-group "s16vector/mutators"
+ (let ((v (s16vector 1 2 3)))
+ (display "set!\n")
+ (s16vector-set! v 0 10)
+ (test-equiv "set!" '(10 2 3) v))
+ (let ((v (s16vector 1 2 3)))
+ (display "swap!\n")
+ (s16vector-swap! v 0 1)
+ (test-equiv "swap!" '(2 1 3) v))
+ (let ((v (s16vector 1 2 3)))
+ (display "fill!\n")
+ (s16vector-fill! v 2)
+ (test-equiv "fill!" '(2 2 2) v))
+ (let ((v (s16vector 1 2 3)))
+ (display "fill2!\n")
+ (s16vector-fill! v 10 0 2)
+ (test-equiv "fill2!" '(10 10 3) v))
+ (let ((v (s16vector 1 2 3)))
+ (display "reverse!\n")
+ (s16vector-reverse! v)
+ (test-equiv "reverse!" '(3 2 1) v))
+ (let ((v (s16vector 1 2 3)))
+ (display "reverse!\n")
+ (s16vector-reverse! v 1 3)
+ (test-equiv "reverse2!" '(1 3 2) v))
+ (let ((v (s16vector 10 20 30 40 50)))
+ (display "copy!\n")
+ (s16vector-copy! v 1 s5 2 4)
+ (test-equiv "copy!" '(10 3 4 40 50) v))
+ (let ((v (s16vector 10 20 30 40 50)))
+ (display "reverse-copy!\n")
+ (s16vector-reverse-copy! v 1 s5 2 4)
+ (test-equiv "reverse-copy!" '(10 4 3 40 50) v))
+ (let ((v (s16vector 1 2 3 4 5 6 7 8)))
+ (display "unfold!")
+ (s16vector-unfold! (lambda (_ x) (values (* x 2) (* x 2)))
+ v 1 6 -1)
+ (test-equiv "vector-unfold!" '(1 -2 -4 -8 -16 -32 7 8) v))
+ (let ((v (s16vector 1 2 3 4 5 6 7 8)))
+ (display "unfold-right!")
+ (s16vector-unfold-right! (lambda (_ x) (values (* x 2) (* x 2)))
+ v 1 6 -1)
+ (test-equiv "vector-unfold!" '(1 -32 -16 -8 -4 -2 7 8) v))
+) ; end s16vector/mutators
+
+(test-group "s16vector/conversion"
+ (test "@vector->list 1" '(1 2 3 4 5)
+ (s16vector->list s5))
+ (test "@vector->list 2" '(2 3 4 5)
+ (s16vector->list s5 1))
+ (test "@vector->list 3" '(2 3 4)
+ (s16vector->list s5 1 4))
+ (test "@vector->vector 1" #(1 2 3 4 5)
+ (s16vector->vector s5))
+ (test "@vector->vector 2" #(2 3 4 5)
+ (s16vector->vector s5 1))
+ (test "@vector->vector 3" #(2 3 4)
+ (s16vector->vector s5 1 4))
+ (test-equiv "list->@vector" '(1 2 3 4 5)
+ (list->s16vector '(1 2 3 4 5)))
+ (test-equiv "reverse-list->@vector" '(5 4 3 2 1)
+ (reverse-list->s16vector '(1 2 3 4 5)))
+ (test-equiv "vector->@vector 1" '(1 2 3 4 5)
+ (vector->s16vector #(1 2 3 4 5)))
+ (test-equiv "vector->@vector 2" '(2 3 4 5)
+ (vector->s16vector #(1 2 3 4 5) 1))
+ (test-equiv "vector->@vector 3" '(2 3 4)
+ (vector->s16vector #(1 2 3 4 5) 1 4))
+) ; end s16vector/conversion
+
+(test-group "s16vector/misc"
+ (let ((port (open-output-string)))
+ (write-s16vector s5 port)
+ (test "write-@vector" "#s16(1 2 3 4 5)" (get-output-string port))
+ (close-output-port port))
+
+ (test-assert "@vector< short" (s16vector< s4 s5))
+ (test-assert "not @vector< short" (not (s16vector< s5 s4)))
+ (test-assert "@vector< samelen" (s16vector< s5 s5+))
+ (test-assert "not @vector< samelen" (not (s16vector< s5+ s5+)))
+ (test-assert "@vector=" (s16vector= s5+ s5+))
+ (test "@vector-hash" 15 (s16vector-hash s5))
+
+ (test "@vector-gen 0" 1 (g))
+ (test "@vector-gen 1" 2 (g))
+ (test "@vector-gen 2" 3 (g))
+ (test "@vector-gen 3" 4 (g))
+ (test "@vector-gen 4" 5 (g))
+ (test-assert (eof-object? (g)))
+) ; end s16vector/misc
+
+) ; end s16vector
+(test-exit)
diff --git a/test-suite/tests/srfi-160.test b/test-suite/tests/srfi-160.test
new file mode 100644
index 000000000..19eccd722
--- /dev/null
+++ b/test-suite/tests/srfi-160.test
@@ -0,0 +1,48 @@
+;;;; srfi-160.test --- Test suite for SRFI-160 libraries. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-160)
+ #:use-module (srfi srfi-160 s16)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-128))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-160-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
prev parent reply other threads:[~2023-11-23 3:25 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-11-23 3:25 [PATCH v4 00/10] Add a few new SRFIs, R7RS libraries Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 01/10] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 02/10] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 03/10] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 04/10] module: Add SRFI 126 Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 05/10] module: Add SRFI 128 Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 06/10] module: Add (scheme comparator) Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 07/10] module: Add (scheme sort) Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 08/10] module: Add SRFI 125 Maxim Cournoyer
2023-11-23 3:25 ` [PATCH v4 09/10] module: Add SRFI 151 Maxim Cournoyer
2023-11-23 3:25 ` Maxim Cournoyer [this message]
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=20231123032659.5637-11-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).