* [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries
@ 2023-12-03 1:37 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
` (15 more replies)
0 siblings, 16 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
This series add the SRFI 209 enumerators library and its dependencies.
It fixes a few problems that prevented using the corresponding R7RS
upstream libraries as-is on the way.
Changes in v6:
- Add SRFI 209
Changes in v5:
- Generate Texinfo menu entries
- Update NEWS
Changes in v4:
- Mention Expat license of SRFI 126 in guile.tex copying section
- Fix invalid module references (e.g. (srfi 69) -> (srfi srfi-69))
- Use .sld for srfi-128 library file extension
- Mention Expat license of SRFI 128 in guile.tex copying section
- Add copyright line in srfi-modules.texi
- Mention Expat license of SRFI 125 in guile.tex copying section
- Rename srfi-125.scm to srfi-125.sld and use upstream copy
- Streamline import of (srfi srfi-125)
- Use R7RS 'import' for srfi-125-test.scm
- Mention Expat license of SRFI 151 in guile.tex copying section
- Update copyright line for John Cowan in srfi-modules.texi
- Rename srfi/srfi-151.scm to srfi/srfi-151.sld
Changes in v3:
- Rename SRFI-126 to SRFI 126 in text
- Rename SRFI-128 to SRFI 128 in text
- Replace srfi-128.scm with upstream srfi/128.sld
- Add menu entries.
- Rename SRFI-125 to SRFI 125 in text
- Rename included file to upstream name (125.body.scm)
- Add copyright/license header 125.body.scm
- Add SRFI 151
Changes in v2:
- Remove extraneous (ice-9 hash-table) import
- Rename SRFI-69 to SRFI 69, SRFI-125 to SRFI 125 in text
- Remove string-hash and symbol-hash from exports (they are already
listed in #:rename)
Maxim Cournoyer (15):
ice-9: Fix 'include' when used in compilation contexts.
r7rs-libraries: Add support for 'else' clause in cond-expand.
r7rs-libraries: Better support R7RS SRFI library names.
(scheme base): Support non-negative SRFI integer names in cond-expand.
Share features tested by cond-expand library declarations and
expressions.
build: Register '.sld' as an alternative extension to '.scm'.
module: Add SRFI 126.
module: Add SRFI 128.
module: Add (scheme comparator).
module: Add (scheme sort).
module: Add SRFI 125.
module: Add SRFI 151.
module: Add SRFI 160.
module: Add SRFI 178.
module: Add SRFI 209.
Timothy Sample (1):
Use R7RS 'rename' syntax for exports.
.gitignore | 1 +
NEWS | 20 +
am/bootstrap.am | 75 +-
configure.ac | 7 +-
doc/ref/guile.texi | 25 +-
doc/ref/srfi-modules.texi | 5347 ++++++++++++++++-
libguile/fports.c | 41 +-
module/ice-9/boot-9.scm | 123 +-
module/ice-9/endianness.scm.in | 1 +
module/ice-9/psyntax.scm | 8 +-
module/ice-9/r6rs-libraries.scm | 88 +-
module/ice-9/r7rs-libraries.scm | 68 +-
module/scheme/base.scm | 15 +-
module/scheme/comparator.sld | 33 +
module/scheme/features.scm | 44 +
module/scheme/sort.sld | 21 +
module/srfi/srfi-125.sld | 96 +
module/srfi/srfi-125/125.body.scm | 589 ++
module/srfi/srfi-126.scm | 396 ++
module/srfi/srfi-128.sld | 61 +
module/srfi/srfi-128/128.body1.scm | 361 ++
module/srfi/srfi-128/128.body2.scm | 146 +
module/srfi/srfi-151.sld | 56 +
module/srfi/srfi-151/bitwise-33.scm | 108 +
module/srfi/srfi-151/bitwise-60.scm | 70 +
module/srfi/srfi-151/bitwise-other.scm | 62 +
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 +
module/srfi/srfi-178.sld | 105 +
module/srfi/srfi-178/convert.scm | 83 +
module/srfi/srfi-178/fields.scm | 88 +
module/srfi/srfi-178/gen-acc.scm | 25 +
module/srfi/srfi-178/logic-ops.scm | 105 +
module/srfi/srfi-178/macros.scm | 26 +
module/srfi/srfi-178/map2list.scm | 27 +
module/srfi/srfi-178/quasi-ints.scm | 54 +
module/srfi/srfi-178/quasi-strs.scm | 88 +
module/srfi/srfi-178/unfolds.scm | 44 +
module/srfi/srfi-178/wrappers.scm | 285 +
module/srfi/srfi-209.sld | 60 +
module/srfi/srfi-209/209.scm | 690 +++
test-suite/Makefile.am | 25 +
test-suite/tests/r7rs-cond-expand.test | 35 +
test-suite/tests/rnrs-libraries.test | 12 +-
test-suite/tests/srfi-125-test.scm | 890 +++
test-suite/tests/srfi-125.test | 45 +
test-suite/tests/srfi-126-test.scm | 289 +
test-suite/tests/srfi-126.test | 49 +
test-suite/tests/srfi-128-test.scm | 321 +
test-suite/tests/srfi-128.test | 47 +
test-suite/tests/srfi-151-test.scm | 381 ++
test-suite/tests/srfi-151.test | 46 +
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 +
.../tests/srfi-178-test/constructors.scm | 88 +
.../tests/srfi-178-test/conversions.scm | 108 +
test-suite/tests/srfi-178-test/fields.scm | 98 +
test-suite/tests/srfi-178-test/gen-accum.scm | 72 +
test-suite/tests/srfi-178-test/iterators.scm | 150 +
test-suite/tests/srfi-178-test/logic-ops.scm | 125 +
test-suite/tests/srfi-178-test/mutators.scm | 79 +
test-suite/tests/srfi-178-test/quasi-ints.scm | 41 +
.../tests/srfi-178-test/quasi-string.scm | 62 +
test-suite/tests/srfi-178-test/selectors.scm | 13 +
test-suite/tests/srfi-178.test | 147 +
test-suite/tests/srfi-209-test.scm | 465 ++
test-suite/tests/srfi-209.test | 50 +
107 files changed, 21463 insertions(+), 448 deletions(-)
create mode 100644 module/ice-9/endianness.scm.in
create mode 100644 module/scheme/comparator.sld
create mode 100644 module/scheme/features.scm
create mode 100644 module/scheme/sort.sld
create mode 100644 module/srfi/srfi-125.sld
create mode 100644 module/srfi/srfi-125/125.body.scm
create mode 100644 module/srfi/srfi-126.scm
create mode 100644 module/srfi/srfi-128.sld
create mode 100644 module/srfi/srfi-128/128.body1.scm
create mode 100644 module/srfi/srfi-128/128.body2.scm
create mode 100644 module/srfi/srfi-151.sld
create mode 100644 module/srfi/srfi-151/bitwise-33.scm
create mode 100644 module/srfi/srfi-151/bitwise-60.scm
create mode 100644 module/srfi/srfi-151/bitwise-other.scm
create mode 100644 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 module/srfi/srfi-178.sld
create mode 100644 module/srfi/srfi-178/convert.scm
create mode 100644 module/srfi/srfi-178/fields.scm
create mode 100644 module/srfi/srfi-178/gen-acc.scm
create mode 100644 module/srfi/srfi-178/logic-ops.scm
create mode 100644 module/srfi/srfi-178/macros.scm
create mode 100644 module/srfi/srfi-178/map2list.scm
create mode 100644 module/srfi/srfi-178/quasi-ints.scm
create mode 100644 module/srfi/srfi-178/quasi-strs.scm
create mode 100644 module/srfi/srfi-178/unfolds.scm
create mode 100644 module/srfi/srfi-178/wrappers.scm
create mode 100644 module/srfi/srfi-209.sld
create mode 100644 module/srfi/srfi-209/209.scm
create mode 100644 test-suite/tests/r7rs-cond-expand.test
create mode 100644 test-suite/tests/srfi-125-test.scm
create mode 100644 test-suite/tests/srfi-125.test
create mode 100644 test-suite/tests/srfi-126-test.scm
create mode 100644 test-suite/tests/srfi-126.test
create mode 100644 test-suite/tests/srfi-128-test.scm
create mode 100644 test-suite/tests/srfi-128.test
create mode 100644 test-suite/tests/srfi-151-test.scm
create mode 100644 test-suite/tests/srfi-151.test
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
create mode 100644 test-suite/tests/srfi-178-test/constructors.scm
create mode 100644 test-suite/tests/srfi-178-test/conversions.scm
create mode 100644 test-suite/tests/srfi-178-test/fields.scm
create mode 100644 test-suite/tests/srfi-178-test/gen-accum.scm
create mode 100644 test-suite/tests/srfi-178-test/iterators.scm
create mode 100644 test-suite/tests/srfi-178-test/logic-ops.scm
create mode 100644 test-suite/tests/srfi-178-test/mutators.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-ints.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-string.scm
create mode 100644 test-suite/tests/srfi-178-test/selectors.scm
create mode 100644 test-suite/tests/srfi-178.test
create mode 100644 test-suite/tests/srfi-209-test.scm
create mode 100644 test-suite/tests/srfi-209.test
base-commit: d8df317bafcdd9fcfebb636433c4871f2fab28b2
--
2.41.0
^ permalink raw reply [flat|nested] 17+ messages in thread
* [PATCH v6 01/16] ice-9: Fix 'include' when used in compilation contexts.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
` (14 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
Fixes bug #66046.
Introduce a '%file-port-stripped-prefixes' fluid that captures the
pre-canonicalized file name used when compiling a file, before it gets
modified in fport_canonicalize_filename. That reference that can then
used by 'include' when searching for included files.
* libguile/fports.c (sys_file_port_stripped_prefixes): New C fluid.
(fport_canonicalize_filename): Register dirnames / stripped prefixes
pairs in.
(%file-port-stripped-prefixes): New corresponding Scheme fluid.
* module/ice-9/boot-9.scm (call-with-include-port): New procedure,
shadowing that from psyntax, that extends it to use the above fluid to
compute a fallback include file directory name to try.
* module/ice-9/psyntax.scm (call-with-include-port): Add comment. Strip
documentation, as it's now an internal.
* NEWS: Mention bug fix.
---
(no changes since v1)
NEWS | 3 ++
libguile/fports.c | 41 +++++++++++++++++++++++++--
module/ice-9/boot-9.scm | 61 ++++++++++++++++++++++++++++++++++++++++
module/ice-9/psyntax.scm | 8 ++----
4 files changed, 105 insertions(+), 8 deletions(-)
diff --git a/NEWS b/NEWS
index b319404d7..6676c5715 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,9 @@ a buffer overrun, and so might vary. This problem affected a number of
other operations, given the internal use of those functions.
+** Fix 'include' not finding included files when byte compiling Guile
+ (<https://bugs.gnu.org/66046>)
+
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/libguile/fports.c b/libguile/fports.c
index 9d4ca6ace..419e9ee3f 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006-2015,2017-2020,2022
+/* Copyright 1995-2004,2006-2015,2017-2020,2022-2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -43,6 +43,7 @@
#include <sys/select.h>
#include <full-write.h>
+#include "alist.h"
#include "async.h"
#include "boolean.h"
#include "dynwind.h"
@@ -60,6 +61,7 @@
#include "ports-internal.h"
#include "posix.h"
#include "read.h"
+#include "srfi-13.h"
#include "strings.h"
#include "symbols.h"
#include "syscalls.h"
@@ -124,6 +126,7 @@ SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
static SCM sys_file_port_name_canonicalization;
+static SCM sys_file_port_stripped_prefixes;
static SCM sym_relative;
static SCM sym_absolute;
@@ -144,7 +147,34 @@ fport_canonicalize_filename (SCM filename)
"%load-path"));
rel = scm_i_relativize_path (filename, path);
- return scm_is_true (rel) ? rel : filename;
+ if (scm_is_true (rel))
+ {
+ SCM relative_dir = scm_dirname (rel);
+ SCM stripped_prefixes = scm_fluid_ref
+ (sys_file_port_stripped_prefixes);
+
+ /* Extend the association list if needed, but keep its size
+ capped to limit memory usage. */
+ if (scm_is_false (scm_assoc_ref(stripped_prefixes, relative_dir)))
+ {
+ SCM stripped_prefix = scm_string_drop_right
+ (filename, scm_string_length (rel));
+
+ stripped_prefixes = scm_cons (scm_cons (relative_dir,
+ stripped_prefix),
+ stripped_prefixes);
+
+ if (scm_to_int (scm_length (stripped_prefixes)) > 100)
+ stripped_prefixes = scm_list_head (stripped_prefixes,
+ scm_from_int(100));
+
+ scm_fluid_set_x (sys_file_port_stripped_prefixes,
+ stripped_prefixes);
+ }
+
+ return rel;
+ }
+ return filename;
}
else if (scm_is_eq (mode, sym_absolute))
{
@@ -767,4 +797,11 @@ scm_init_fports ()
sys_file_port_name_canonicalization = scm_make_fluid ();
scm_c_define ("%file-port-name-canonicalization",
sys_file_port_name_canonicalization);
+
+ /* Used by `include' to locate the true source when relative
+ canonicalization strips a leading part of the source file. */
+ sys_file_port_stripped_prefixes = scm_make_fluid_with_default (SCM_EOL);
+
+ scm_c_define ("%file-port-stripped-prefixes",
+ sys_file_port_stripped_prefixes);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a5f2eea9b..a79d49ae1 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2030,6 +2030,67 @@ non-locally, that exit determines the continuation."
\f
+;;; {Include}
+;;;
+
+;;; This redefined version of call-with-include-port (first defined in
+;;; psyntax.scm) also try to locate an included file using the
+;;; %file-port-stripped-prefixes fluid.
+(define call-with-include-port
+ (let ((syntax-dirname (lambda (stx)
+ (define src (syntax-source stx))
+ (define filename (and src (assq-ref src 'filename)))
+ (and (string? filename)
+ (dirname filename)))))
+ (lambda* (filename proc #:key (dirname (syntax-dirname filename)))
+ "Like @code{call-with-input-file}, except relative paths are
+searched relative to @var{dirname} instead of the current working
+directory. Also, @var{filename} can be a syntax object; in that case,
+and if @var{dirname} is not specified, the @code{syntax-source} of
+@var{filename} is used to obtain a base directory for relative file
+names. As a special case, when the @var{%file-port-stripped-prefixes}
+fluid is set, its value is searched for a directory matching the dirname
+inferred from FILENAME."
+ (let* ((filename (syntax->datum filename))
+ (candidates
+ (cond ((absolute-file-name? filename)
+ (list filename))
+ (dirname ;filename is relative
+ (let* ((rel-names (fluid-ref %file-port-stripped-prefixes))
+ (stripped-prefix (and rel-names
+ (assoc-ref rel-names dirname)))
+ (fallback (and stripped-prefix
+ (string-append stripped-prefix
+ dirname))))
+ (map (lambda (d)
+ (in-vicinity d filename))
+ `(,dirname ,@(if fallback
+ (list fallback)
+ '())))))
+ (else
+ (error
+ "attempt to include relative file name \
+but could not determine base dir"))))
+ (p (let loop ((files candidates))
+ (when (null? files)
+ (error "could not open any of" candidates))
+ (catch 'system-error
+ (lambda _
+ (open-input-file (car files)))
+ (lambda _
+ (loop (cdr files))))))
+ (enc (file-encoding p)))
+
+ ;; Choose the input encoding deterministically.
+ (set-port-encoding! p (or enc "UTF-8"))
+
+ (call-with-values (lambda () (proc p))
+ (lambda results
+ (close-port p)
+ (apply values results)))))))
+
+\f
+
;;; {Time Structures}
;;;
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7811f7118..0e0370457 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3256,6 +3256,8 @@
;; Scheme code corresponding to the intermediate language forms.
((_ e) (emit (quasi #'e 0)))))))
+;; Note: this procedure is later refined in ice-9/boot-9.scm after we
+;; have basic exception handling.
(define call-with-include-port
(let ((syntax-dirname (lambda (stx)
(define src (syntax-source stx))
@@ -3263,12 +3265,6 @@
(and (string? filename)
(dirname filename)))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename)))
- "Like @code{call-with-input-file}, except relative paths are
-searched relative to the @var{dirname} instead of the current working
-directory. Also, @var{filename} can be a syntax object; in that case,
-and if @var{dirname} is not specified, the @code{syntax-source} of
-@var{filename} is used to obtain a base directory for relative file
-names."
(let* ((filename (syntax->datum filename))
(p (open-input-file
(cond ((absolute-file-name? filename)
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 02/16] Use R7RS 'rename' syntax for exports.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
` (13 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Timothy Sample, Maxim Cournoyer
From: Timothy Sample <samplet@ngyro.com>
* module/ice-9/r7rs-libraries.scm (define-library): Convert R7RS
exports to R6RS exports before passing them on to 'library'.
* NEWS: Mention bug fix.
Fixes: https://bugs.gnu.org/67255
Reported-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>.
Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
---
(no changes since v5)
Changes in v5:
- Update NEWS
NEWS | 2 ++
module/ice-9/r7rs-libraries.scm | 10 ++++++++--
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/NEWS b/NEWS
index 6676c5715..6284bb127 100644
--- a/NEWS
+++ b/NEWS
@@ -50,6 +50,8 @@ other operations, given the internal use of those functions.
** Fix 'include' not finding included files when byte compiling Guile
(<https://bugs.gnu.org/66046>)
+** R7RS define-library now properly supports 'rename' declarations
+ (<https://bugs.gnu.org/67255>)
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index 63a300a26..429d82ad9 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -1,5 +1,5 @@
;; R7RS library support
-;; Copyright (C) 2020, 2021 Free Software Foundation, Inc.
+;; Copyright (C) 2020, 2021, 2023 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -97,12 +97,18 @@
((decl ...)
(partition-decls #'(decl ... . decls) exports imports code))))))
+ (define (r7rs-export->r6rs-export export-spec)
+ (syntax-case export-spec (rename)
+ ((rename from-identifier to-identifier)
+ #'(rename (from-identifier to-identifier)))
+ (identifier #'identifier)))
+
(syntax-case stx ()
((_ name decl ...)
(call-with-values (lambda ()
(partition-decls #'(decl ...) '() '() '()))
(lambda (exports imports code)
#`(library name
- (export . #,exports)
+ (export . #,(map r7rs-export->r6rs-export exports))
(import . #,imports)
. #,code)))))))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
` (12 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/ice-9/r7rs-libraries.scm (define-library)
<handle-cond-expand>: Add a pattern to match an 'else' clause.
---
(no changes since v1)
module/ice-9/r7rs-libraries.scm | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index 429d82ad9..97465b649 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -64,8 +64,10 @@
;; FIXME: R7RS (features) isn't quite the same as
;; %cond-expand-features; see scheme/base.scm.
(memq (syntax->datum #'id) %cond-expand-features))))
- (syntax-case clauses ()
+ (syntax-case clauses (else)
(() #'()) ; R7RS says this is not specified :-/
+ (((else decl ...))
+ #'(decl ...))
(((test decl ...) . clauses)
(if (has-req? #'test)
#'(decl ...)
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 04/16] r7rs-libraries: Better support R7RS SRFI library names.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (2 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
` (11 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/ice-9/r6rs-libraries.scm
(resolve-r6rs-interface <srfi-name?>: Relax symbol requirements.
<import-spec>: Add a new syntax matching clause to avoid stripping the
3rd identifier in a R7RS SRFI module name.
(library): Move R7RS specifics to...
* module/ice-9/r7rs-libraries.scm (define-library): ... here.
<r7rs-module-name->r6rs-module-name, r7rs-import->r6rs-import>: New
nested procedures, used to translate the library name and import sets.
<handle-cond-expand>: Apply r7rs-name->r6rs-name to the library name.
* test-suite/tests/rnrs-libraries.test ("import features")
<"renaming works">: Extend test.
<"import works">: New test.
* NEWS: Mention bug fix.
Fixes: https://bugs.gnu.org/67412
---
(no changes since v1)
NEWS | 3 +
module/ice-9/r6rs-libraries.scm | 88 ++++++++--------------------
module/ice-9/r7rs-libraries.scm | 48 ++++++++++++++-
test-suite/tests/rnrs-libraries.test | 12 +++-
4 files changed, 85 insertions(+), 66 deletions(-)
diff --git a/NEWS b/NEWS
index 6284bb127..af66c80bd 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,9 @@ a buffer overrun, and so might vary. This problem affected a number of
other operations, given the internal use of those functions.
+** Add better support to R7RS library names for SRFI modules
+ (<https://bugs.gnu.org/67412>)
+
** Fix 'include' not finding included files when byte compiling Guile
(<https://bugs.gnu.org/66046>)
** R7RS define-library now properly supports 'rename' declarations
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index f27b07841..a2ba3a740 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -1,6 +1,6 @@
;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms
-;; Copyright (C) 2010, 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2019, 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
@@ -44,9 +44,9 @@
(define (srfi-name? stx)
(syntax-case stx (srfi)
((srfi n rest ...)
- (and (and-map sym? #'(rest ...))
- (or (n? #'n)
- (colon-n? #'n))))
+ (cond ((n? #'n) 'r7rs)
+ ((colon-n? #'n) 'r6rs)
+ (else #f)))
(_ #f)))
(define (module-name? stx)
@@ -85,10 +85,19 @@
(module-and-uses mod)))
(syntax-case import-spec (library only except prefix rename srfi)
- ;; (srfi :n ...) -> (srfi srfi-n ...)
+ ;; XXX: This is R7RS-specific, but it's here since we want the
+ ;; `import' procedure below to accept (srfi 64) as well as
+ ;; (srfi :64).
+ ;;
;; (srfi n ...) -> (srfi srfi-n ...)
((library (srfi n rest ... (version ...)))
- (srfi-name? #'(srfi n rest ...))
+ (eq? 'r7rs (srfi-name? #'(srfi n rest ...)))
+ (let ((srfi-n (make-srfi-n #'srfi #'n)))
+ (resolve-r6rs-interface
+ #`(library (srfi #,srfi-n rest ... (version ...))))))
+ ;; (srfi :n ...) -> (srfi srfi-n ...)
+ ((library (srfi n rest ... (version ...)))
+ (eq? 'r6rs (srfi-name? #'(srfi n rest ...)))
(let ((srfi-n (make-srfi-n #'srfi #'n)))
(resolve-r6rs-interface
(syntax-case #'(rest ...) ()
@@ -98,7 +107,7 @@
;; SRFI 97 says that the first identifier after the `n'
;; is used for the libraries name, so it must be ignored.
#`(library (srfi #,srfi-n rest ... (version ...))))))))
-
+
((library (name name* ... (version ...)))
(and-map sym? #'(name name* ...))
(resolve-interface (syntax->datum #'(name name* ...))
@@ -107,7 +116,7 @@
((library (name name* ...))
(and-map sym? #'(name name* ...))
(resolve-r6rs-interface #'(library (name name* ... ()))))
-
+
((only import-set identifier ...)
(and-map sym? #'(identifier ...))
(let* ((mod (resolve-r6rs-interface #'import-set))
@@ -121,7 +130,7 @@
(hashq-set! (module-replacements iface) sym #t)))
(syntax->datum #'(identifier ...)))
iface))
-
+
((except import-set identifier ...)
(and-map sym? #'(identifier ...))
(let* ((mod (resolve-r6rs-interface #'import-set))
@@ -182,7 +191,7 @@
(module-remove! iface from)
(hashq-remove! replacements from)
(lp (cdr in) (cons (vector to replace? var) out))))))))
-
+
((name name* ... (version ...))
(module-name? #'(name name* ...))
(resolve-r6rs-interface #'(library (name name* ... (version ...)))))
@@ -196,45 +205,11 @@
(define (sym? stx)
(symbol? (syntax->datum stx)))
- (define (n? stx)
- (let ((n (syntax->datum stx)))
- (and (exact-integer? n)
- (not (negative? n)))))
-
- (define (colon-n? x)
- (let ((sym (syntax->datum x)))
- (and (symbol? sym)
- (let ((str (symbol->string sym)))
- (and (string-prefix? ":" str)
- (let ((num (string->number (substring str 1))))
- (and (exact-integer? num)
- (not (negative? num)))))))))
-
- (define (srfi-name? stx)
- (syntax-case stx (srfi)
- ((srfi n rest ...)
- (and (and-map sym? #'(rest ...))
- (or (n? #'n)
- (colon-n? #'n))))
- (_ #f)))
-
(define (module-name? stx)
- (or (srfi-name? stx)
- (syntax-case stx ()
- ((name name* ...)
- (and-map sym? #'(name name* ...)))
- (_ #f))))
-
- (define (make-srfi-n context n)
- (datum->syntax
- context
- (string->symbol
- (string-append
- "srfi-"
- (let ((n (syntax->datum n)))
- (if (symbol? n)
- (substring (symbol->string n) 1)
- (number->string n)))))))
+ (syntax-case stx ()
+ ((name name* ...)
+ (and-map sym? #'(name name* ...)))
+ (_ #f)))
(define (compute-exports ifaces specs)
(define (re-export? sym)
@@ -282,17 +257,6 @@
(import ispec ...)
body ...))
- ((_ (srfi n rest ... (version ...))
- (export espec ...)
- (import ispec ...)
- body ...)
- (srfi-name? #'(srfi n rest ...))
- (let ((srfi-n (make-srfi-n #'srfi #'n)))
- #`(library (srfi #,srfi-n rest ... (version ...))
- (export espec ...)
- (import ispec ...)
- body ...)))
-
((_ (name name* ... (version ...))
(export espec ...)
(import ispec ...)
@@ -328,7 +292,7 @@
(export! x ...)
(@@ @@ (name name* ...) body)
...))))))))
-
+
(define-syntax import
(lambda (stx)
(define (strip-for import-set)
@@ -343,7 +307,7 @@
#'(eval-when (expand load eval)
(let ((iface (resolve-r6rs-interface 'library-reference)))
(call-with-deferred-observers
- (lambda ()
- (module-use-interfaces! (current-module) (list iface)))))
+ (lambda ()
+ (module-use-interfaces! (current-module) (list iface)))))
...
(if #f #f)))))))
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index 97465b649..773a9d47b 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -31,6 +31,36 @@
(define-syntax define-library
(lambda (stx)
+ (define (r7rs-module-name->r6rs-module-name name)
+ ;; This is a hack to support (srfi N x ...) modules in R7RS. The
+ ;; longer term solution would be to add support at the level of
+ ;; resolve-interface (bug #40371).
+ (define (n? stx)
+ (let ((n (syntax->datum stx)))
+ (and (exact-integer? n)
+ (not (negative? n)))))
+
+ (define (srfi-name? stx)
+ (syntax-case stx (srfi)
+ ((srfi n rest ...)
+ (n? #'n))
+ (_ #f)))
+
+ (define (make-srfi-n context n)
+ (datum->syntax
+ context
+ (string->symbol
+ (string-append
+ "srfi-"
+ (let ((n (syntax->datum n)))
+ (number->string n))))))
+
+ (syntax-case name (srfi)
+ ;; (srfi n ...) -> (srfi srfi-n ...)
+ ((srfi n rest ...) (srfi-name? #'(srfi n rest ...))
+ #`(srfi #,(make-srfi-n #'srfi #'n) rest ...))
+ (_ name)))
+
(define (handle-includes filenames)
(syntax-case filenames ()
(() #'())
@@ -105,12 +135,26 @@
#'(rename (from-identifier to-identifier)))
(identifier #'identifier)))
+ (define (r7rs-import->r6rs-import import-set)
+ ;; Normalize SRFI names.
+ (syntax-case import-set (only except prefix rename)
+ ((only import-set identifier ...)
+ #`(only #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+ ((except import-set identifier ...)
+ #`(except #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+ ((prefix import-set identifier ...)
+ #`(prefix #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+ ((rename import-set (from-identifier to-identifier) ...)
+ #`(rename #,(r7rs-import->r6rs-import #'import-set)
+ (from-identifier to-identifier) ...))
+ (_ (r7rs-module-name->r6rs-module-name import-set))))
+
(syntax-case stx ()
((_ name decl ...)
(call-with-values (lambda ()
(partition-decls #'(decl ...) '() '() '()))
(lambda (exports imports code)
- #`(library name
+ #`(library #,(r7rs-module-name->r6rs-module-name #'name)
(export . #,(map r7rs-export->r6rs-export exports))
- (import . #,imports)
+ (import . #,(map r7rs-import->r6rs-import imports))
. #,code)))))))
diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test
index 86035e508..0fa7acb5c 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -205,9 +205,17 @@
(with-test-prefix "srfi"
(pass-if "renaming works"
(eq? (resolve-interface '(srfi srfi-1))
- (resolve-r6rs-interface '(srfi :1)))
+ (resolve-r6rs-interface '(srfi :1))
+ (resolve-r6rs-interface '(srfi 1)))
(eq? (resolve-interface '(srfi srfi-1))
- (resolve-r6rs-interface '(srfi :1 lists)))))
+ (resolve-r6rs-interface '(srfi :1 lists))
+ (resolve-r6rs-interface '(srfi 1))))
+
+ (pass-if "import works"
+ (import (srfi srfi-1))
+ (import (srfi :1))
+ (import (srfi 1))
+ #t))
(with-test-prefix "macro"
(pass-if "multiple clauses"
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (3 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
` (10 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/scheme/base.scm (r7:cond-expand): Test for library using
resolve-r6rs-interface instead of resolve-interface. Swallow any
exception with false-if-exception.
* test-suite/tests/r7rs-cond-expand.test: New test.
* NEWS: Update news.
---
(no changes since v5)
Changes in v5:
- Update NEWS
NEWS | 1 +
module/scheme/base.scm | 5 +++-
test-suite/tests/r7rs-cond-expand.test | 35 ++++++++++++++++++++++++++
3 files changed, 40 insertions(+), 1 deletion(-)
create mode 100644 test-suite/tests/r7rs-cond-expand.test
diff --git a/NEWS b/NEWS
index af66c80bd..1de1fa8b4 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,7 @@ other operations, given the internal use of those functions.
(<https://bugs.gnu.org/66046>)
** R7RS define-library now properly supports 'rename' declarations
(<https://bugs.gnu.org/67255>)
+** (scheme base)'s cond-expand supports non-negative integer in modules names
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 477dd9c28..2bd1f0d89 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -283,7 +283,10 @@
((not req)
(not (has-req? #'req)))
((library lib-name)
- (->bool (resolve-interface (syntax->datum #'lib-name))))
+ (->bool
+ (false-if-exception
+ (resolve-r6rs-interface
+ (syntax->datum #'lib-name)))))
(id
(identifier? #'id)
(memq (syntax->datum #'id) (features)))))
diff --git a/test-suite/tests/r7rs-cond-expand.test b/test-suite/tests/r7rs-cond-expand.test
new file mode 100644
index 000000000..ea880d8c2
--- /dev/null
+++ b/test-suite/tests/r7rs-cond-expand.test
@@ -0,0 +1,35 @@
+;;; R7RS cond-expand -*- 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (test-suite r7rs-cond-expand)
+ #:use-module ((scheme base) #:select (cond-expand))
+ #:use-module ((srfi srfi-64) #:select (test-read-eval-string))
+ #:use-module (test-suite lib))
+
+(pass-if "cond-expand expression missing library test"
+ (test-read-eval-string "\
+(cond-expand
+ ((library (srfi 99999 something))
+ #f)
+ (else #t))"))
+
+(pass-if "cond-expand expression found library test"
+ (test-read-eval-string "\
+(cond-expand
+ ((library (srfi 64))
+ #t)
+ (else #f))"))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 06/16] Share features tested by cond-expand library declarations and expressions.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (4 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
` (9 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
This addresses a FIXME in r7rs-libraries.scm, which was about the
cond-expand define-library declarations not using the same features as
provided in (scheme base).
* .gitignore: Register /module/ice-9/endianness.scm.
* am/bootstrap.am (NOCOMP_SOURCES): Register ice-9/endianness.scm and
scheme/features.scm.
* configure.ac: Define a NATIVE_ENDIANNESS output variable.
* module/ice-9/endianness.scm.in: New file.
* module/scheme/base.scm (features): Move to...
* module/scheme/features.scm: ... here. Include this file in base.scm
and...
* module/ice-9/r7rs-libraries.scm: ... here.
(define-library) <handle-cond-expand>: Adjust to match the definition of
cond-expand found in (scheme base).
* module/ice-9/boot-9.scm (%cond-expand-features): Move before where
r7rs-libraries.scm is included.
* NEWS: Update NEWS.
---
(no changes since v5)
Changes in v5:
- Update NEWS
.gitignore | 1 +
NEWS | 1 +
am/bootstrap.am | 2 ++
configure.ac | 7 +++-
module/ice-9/boot-9.scm | 62 +++++++++++++++++----------------
module/ice-9/endianness.scm.in | 1 +
module/ice-9/r7rs-libraries.scm | 6 ++--
module/scheme/base.scm | 10 ++----
module/scheme/features.scm | 44 +++++++++++++++++++++++
9 files changed, 92 insertions(+), 42 deletions(-)
create mode 100644 module/ice-9/endianness.scm.in
create mode 100644 module/scheme/features.scm
diff --git a/.gitignore b/.gitignore
index 931ebf7c4..7903bee15 100644
--- a/.gitignore
+++ b/.gitignore
@@ -122,6 +122,7 @@ INSTALL
/meta/guild
/meta/guile-config
/lib/locale.h
+/module/ice-9/endianness.scm
/module/ice-9/eval.go.stamp
/doc/ref/standard-library.texi
/doc/ref/standard-libraryscmfiles
diff --git a/NEWS b/NEWS
index 1de1fa8b4..e5cc3c7aa 100644
--- a/NEWS
+++ b/NEWS
@@ -56,6 +56,7 @@ other operations, given the internal use of those functions.
** R7RS define-library now properly supports 'rename' declarations
(<https://bugs.gnu.org/67255>)
** (scheme base)'s cond-expand supports non-negative integer in modules names
+** define-library's cond-expand declarations can now test complete features
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index a71946958..39f65f100 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -427,12 +427,14 @@ ELISP_SOURCES = \
language/elisp/boot.el
NOCOMP_SOURCES = \
+ ice-9/endianness.scm \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
ice-9/read.scm \
ice-9/r6rs-libraries.scm \
ice-9/r7rs-libraries.scm \
ice-9/quasisyntax.scm \
+ scheme/features.scm \
srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
diff --git a/configure.ac b/configure.ac
index d0a2dc79b..d049a5a1b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -326,7 +326,12 @@ else
fi
AC_CHECK_LIB(uca, __uc_get_ar_bsp)
-AC_C_BIGENDIAN
+AC_C_BIGENDIAN(
+ [AC_DEFINE([WORDS_BIGENDIAN], 1)
+ AC_SUBST([NATIVE_ENDIANNESS], [big])],
+ [AC_SUBST([NATIVE_ENDIANNESS], [little])]
+)
+AC_CONFIG_FILES([module/ice-9/endianness.scm])
AC_C_LABELS_AS_VALUES
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a79d49ae1..3da328b2a 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4066,6 +4066,38 @@ but it fails to load."
(process-use-modules (list quoted-args ...))
*unspecified*))))))
+;;; This is defined early because ice-9/r7rs-libraries makes use of
+;;; the R7RS features, which requires it to be defined.
+(define %cond-expand-features
+ ;; This should contain only features that are present in core Guile,
+ ;; before loading any modules. Modular features are handled by
+ ;; placing 'cond-expand-provide' in the relevant module.
+ '(guile
+ guile-2
+ guile-2.2
+ guile-3
+ guile-3.0
+ r5rs
+ r6rs
+ r7rs
+ exact-closed ieee-float full-unicode ratios ;; R7RS features.
+ srfi-0 ;; cond-expand itself
+ srfi-4 ;; homogeneous numeric vectors
+ srfi-6 ;; string ports
+ srfi-13 ;; string library
+ srfi-14 ;; character sets
+ srfi-16 ;; case-lambda
+ srfi-23 ;; `error` procedure
+ srfi-30 ;; nested multi-line comments
+ srfi-39 ;; parameterize
+ srfi-46 ;; basic syntax-rules extensions
+ srfi-55 ;; require-extension
+ srfi-61 ;; general cond clause
+ srfi-62 ;; s-expression comments
+ srfi-87 ;; => in case clauses
+ srfi-105 ;; curly infix expressions
+ ))
+
(include-from-path "ice-9/r6rs-libraries")
(include-from-path "ice-9/r7rs-libraries")
@@ -4535,36 +4567,6 @@ when none is available, reading FILE-NAME with READER."
;;; Remember to update the features list when adding more SRFIs.
;;;
-(define %cond-expand-features
- ;; This should contain only features that are present in core Guile,
- ;; before loading any modules. Modular features are handled by
- ;; placing 'cond-expand-provide' in the relevant module.
- '(guile
- guile-2
- guile-2.2
- guile-3
- guile-3.0
- r5rs
- r6rs
- r7rs
- exact-closed ieee-float full-unicode ratios ;; R7RS features.
- srfi-0 ;; cond-expand itself
- srfi-4 ;; homogeneous numeric vectors
- srfi-6 ;; string ports
- srfi-13 ;; string library
- srfi-14 ;; character sets
- srfi-16 ;; case-lambda
- srfi-23 ;; `error` procedure
- srfi-30 ;; nested multi-line comments
- srfi-39 ;; parameterize
- srfi-46 ;; basic syntax-rules extensions
- srfi-55 ;; require-extension
- srfi-61 ;; general cond clause
- srfi-62 ;; s-expression comments
- srfi-87 ;; => in case clauses
- srfi-105 ;; curly infix expressions
- ))
-
;; This table maps module public interfaces to the list of features.
;;
(define %cond-expand-table (make-hash-table))
diff --git a/module/ice-9/endianness.scm.in b/module/ice-9/endianness.scm.in
new file mode 100644
index 000000000..5d3f5dbaa
--- /dev/null
+++ b/module/ice-9/endianness.scm.in
@@ -0,0 +1 @@
+(define %native-endianness '@NATIVE_ENDIANNESS@)
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index 773a9d47b..20692989d 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -29,6 +29,8 @@
(define-syntax-rule (include-ci filename)
(include filename))
+(include-from-path "scheme/features.scm")
+
(define-syntax define-library
(lambda (stx)
(define (r7rs-module-name->r6rs-module-name name)
@@ -91,9 +93,7 @@
(syntax->datum #'lib-name)))))
(id
(identifier? #'id)
- ;; FIXME: R7RS (features) isn't quite the same as
- ;; %cond-expand-features; see scheme/base.scm.
- (memq (syntax->datum #'id) %cond-expand-features))))
+ (memq (syntax->datum #'id) (features)))))
(syntax-case clauses (else)
(() #'()) ; R7RS says this is not specified :-/
(((else decl ...))
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 2bd1f0d89..1f47f8560 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -272,6 +272,8 @@
(make-exception exn
(make-exception-with-irritants irritants))))))
+(include-from-path "scheme/features.scm")
+
(define-syntax r7:cond-expand
(lambda (x)
(define (has-req? req)
@@ -551,14 +553,6 @@
(exact->inexact (expt x y))
(expt x y)))
-(define (features)
- (append
- (case (native-endianness)
- ((big) '(big-endian))
- ((little) '(little-endian))
- (else '()))
- %cond-expand-features))
-
(define (input-port-open? port)
(and (not (port-closed? port)) (input-port? port)))
diff --git a/module/scheme/features.scm b/module/scheme/features.scm
new file mode 100644
index 000000000..7acbe332b
--- /dev/null
+++ b/module/scheme/features.scm
@@ -0,0 +1,44 @@
+;;; R7RS compatibility libraries -- features
+;;; Copyright (C) 2019-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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Based on code from https://gitlab.com/akku/akku-scm, written
+;;; 2018-2019 by Göran Weinholt <goran@weinholt.se>, as well as
+;;; https://github.com/okuoku/yuni, written 2014-2018 by OKUMURA Yuki
+;;; <mjt@cltn.org>. This code was originally released under the
+;;; following terms:
+;;;
+;;; To the extent possible under law, the author(s) have dedicated
+;;; all copyright and related and neighboring rights to this
+;;; software to the public domain worldwide. This software is
+;;; distributed without any warranty.
+;;;
+;;; See <http://creativecommons.org/publicdomain/zero/1.0/>, for a
+;;; copy of the CC0 Public Domain Dedication.
+
+;;; This code is shared between (scheme base) and (ice-9
+;;; r7rs-libraries), which gets included in (ice-9 boot-9), to avoid
+;;; having multiple copies 'features' to maintain.
+
+(include-from-path "ice-9/endianness.scm")
+
+(define (features)
+ (append
+ (case %native-endianness
+ ((big) '(big-endian))
+ ((little) '(little-endian))
+ (else '()))
+ %cond-expand-features))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 07/16] build: Register '.sld' as an alternative extension to '.scm'.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (5 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 08/16] module: Add SRFI 126 Maxim Cournoyer
` (8 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
This is useful when integrating R7RS SRFI libraries into Guile.
* am/bootstrap.am (GOBJECTS_): New variable.
(GOBJECTS): Compute from GOBJECTS_.
<vpath>: Register %.sld to vpath.
(SUFFIXES): Register '.sld' extension.
(.sld.go .scm.go): Add 'sld.go' target to automatic compilation rule.
---
(no changes since v1)
am/bootstrap.am | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 39f65f100..68d4b3334 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -23,7 +23,8 @@ GUILE_OPTIMIZATIONS ?= -O2
GUILE_TARGET ?= $(host)
GUILE_BUILD_TAG ?= BOOTSTRAP($(GUILE_BOOTSTRAP_STAGE))
-GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
+GOBJECTS_ = $(SOURCES:%.sld=%.go)
+GOBJECTS = $(GOBJECTS_:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
nobase_noinst_DATA = $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
@@ -35,9 +36,10 @@ AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
AM_V_GUILEC_0 = @echo " $(GUILE_BUILD_TAG) GUILEC" $@;
vpath %.scm @top_srcdir@/module
+vpath %.sld @top_srcdir@/module
vpath %.el @top_srcdir@/module
-SUFFIXES = .scm .el .go
+SUFFIXES = .scm .sld .el .go
COMPILE = $(AM_V_GUILEC) \
GUILE_BOOTSTRAP_STAGE=$(GUILE_BOOTSTRAP_STAGE) \
@@ -46,7 +48,7 @@ COMPILE = $(AM_V_GUILEC) \
$(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \
-L "$(abs_top_srcdir)/module"
-.scm.go:
+.sld.go .scm.go:
$(COMPILE) -o "$@" "$<"
.el.go:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 08/16] module: Add SRFI 126.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (6 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 09/16] module: Add SRFI 128 Maxim Cournoyer
` (7 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
This is not original work: it merely integrates and formats the work of
Taylan Ulrich Bayırlı/Kammer into Guile, with a few adjustments to avoid
warnings/fix missing imports. Thank you!
* module/srfi/srfi-126.scm: New file.
* test-suite/tests/srfi-126.test: New file.
* test-suite/tests/srfi-126-test.scm: Likewise.
* am/bootstrap.am (SOURCES): Register srfi-126 module.
* test-suite/Makefile.am (SCM_TESTS): Register test.
(EXTRA_DIST): Register test suite implementation.
* doc/ref/srfi-modules.texi (SRFI Support): Document new module.
* NEWS: Mention new interface.
---
(no changes since v5)
Changes in v5:
- Update NEWS
Changes in v4:
- Mention Expat license of SRFI 126 in guile.tex copying section
Changes in v3:
- Rename SRFI-126 to SRFI 126 in text
Changes in v2:
- Remove extraneous (ice-9 hash-table) import
- Rename SRFI-69 to SRFI 69, SRFI-125 to SRFI 125 in text
NEWS | 3 +
am/bootstrap.am | 1 +
doc/ref/guile.texi | 25 +-
doc/ref/srfi-modules.texi | 600 +++++++++++++++++++++++++++++
module/srfi/srfi-126.scm | 396 +++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-126-test.scm | 289 ++++++++++++++
test-suite/tests/srfi-126.test | 49 +++
8 files changed, 1364 insertions(+), 1 deletion(-)
create mode 100644 module/srfi/srfi-126.scm
create mode 100644 test-suite/tests/srfi-126-test.scm
create mode 100644 test-suite/tests/srfi-126.test
diff --git a/NEWS b/NEWS
index e5cc3c7aa..31107a76d 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,9 @@ definitely unused---this is notably the case for modules that are only
used at macro-expansion time, such as (srfi srfi-26). In those cases,
the compiler reports it as "possibly unused".
+** Add (srfi 126), a hash tables library
+** Add (srfi 128), a comparators library
+
* Bug fixes
** (ice-9 suspendable-ports) incorrect UTF-8 decoding
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 68d4b3334..3586f0873 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -349,6 +349,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-126.scm \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 8414c3e2d..0540d2aab 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -23,8 +23,31 @@ any later version published by the Free Software Foundation; with no
Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-@end copying
+Additionally, the documentation of the SRFI 126 module is adapted from
+its specification text, which is made available under the following
+Expat license:
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+@end copying
@c Notes
@c
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 0cdf56923..8b3315180 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -2,6 +2,7 @@
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
@c Free Software Foundation, Inc.
+@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -64,6 +65,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
+* SRFI 126:: R6RS-based hash tables.
* SRFI-171:: Transducers
@end menu
@@ -5662,6 +5664,604 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI 126
+@subsection SRFI 126 R6RS-based hash tables
+@cindex SRFI 126
+@cindex hash tables, r6rs-based
+
+@uref{http://srfi.schemers.org/srfi-126/srfi-126.html, SRFI 126}
+provides hash tables API that takes the R6RS hash tables API as a basis
+and makes backwards compatible additions such as support for weak hash
+tables, external representation, API support for double hashing
+implementations, and utility procedures. As an alternative to SRFI 125,
+it builds on the R6RS hash tables API instead of SRFI 69, with only
+fully backwards compatible additions such as weak and ephemeral hash
+tables, an external representation, and API support for hashing
+strategies that require a pair of hash functions. This SRFI does not
+attempt to specify thread-safety because typical multi-threaded
+use-cases will most likely involve locking more than just accesses and
+mutations of hash tables.
+
+@noindent
+The R6RS hash tables API is favored over SRFI 69 because the latter
+contains a crucial flaw: exposing the hash functions for the @code{eq?}
+and @code{eqv?} procedures is a hindrance for Scheme implementations
+with a moving garbage collector. SRFI 125 works around this by allowing
+the user-provided hash function passed to @code{make-hash-table} to be
+ignored by the implementation, and allowing the
+@code{hash-table-hash-function} procedure to return @code{#f} instead of
+the hash function passed to @code{make-hash-table}. R6RS avoids the
+issue by providing dedicated constructors for @code{eq?} and @code{eqv?}
+based hash tables, and returning @code{#f} when their hash function is
+queried.
+
+While the SRFI is based on the R6RS hash tables API instead of SRFI 69,
+the provided utility procedures nevertheless make it relatively
+straightforward to change code written for SRFI 69 to use the API
+specified herein. The utility procedures provided by this SRFI in
+addition to the R6RS API may be categorized as follows:
+
+@table @asis
+@item Constructors
+alist->eq-hashtable, alist->eqv-hashtable, alist->hashtable
+
+@item Access and mutation
+hashtable-lookup, hashtable-intern!
+
+@item Copying
+hashtable-empty-copy
+
+@item Key/value collections
+hashtable-values, hashtable-key-list, hashtable-value-list,
+hashtable-entry-lists
+
+@item Iteration
+hashtable-walk, hashtable-update-all!, hashtable-prune!,
+hashtable-merge!, hashtable-sum, hashtable-map->lset, hashtable-find
+
+@item Miscellaneous
+hashtable-empty?, hashtable-pop!, hashtable-inc!, hashtable-dec!
+@end table
+
+Additionally, this specification adheres to the R7RS rule of specifying
+a single return value for procedures which don't have meaningful return
+values.
+
+@menu
+* SRFI 126 API::
+* SRFI 126 Constructors::
+* SRFI 126 Procedures::
+* SRFI 126 Inspection::
+* SRFI 126 Hash functions::
+@end menu
+
+@node SRFI 126 API
+@subsubsection SRFI 126 API
+
+The @code{(srfi srfi-126)} library provides a set of operations on hash
+tables. A hash table is of a disjoint type that associates keys with
+values. Any object can be used as a key, provided a hash function or a
+pair of hash functions, and a suitable equivalence function, are
+available. A hash function is a procedure that maps keys to
+non-negative exact integer objects. It is the programmer's
+responsibility to ensure that the hash functions are compatible with the
+equivalence function, which is a procedure that accepts two keys and
+returns true if they are equivalent and @code{#f} otherwise. Standard
+hash tables for arbitrary objects based on the @code{eq?} and
+@code{eqv?} predicates (see R7RS section on “Equivalence predicates”)
+are provided. Also, hash functions for arbitrary objects, strings, and
+symbols are provided.
+
+Hash tables can store their key, value, or key and value weakly.
+Storing an object weakly means that the storage location of the object
+does not count towards the total storage locations in the program which
+refer to the object, meaning the object can be reclaimed as soon as no
+non-weak storage locations referring to the object remain. Weakly
+stored objects referring to each other in a cycle will be reclaimed as
+well if none of them are referred to from outside the cycle. When a
+weakly stored object is reclaimed, associations in the hash table which
+have the object as their key or value are deleted.
+
+Hash tables can also store their key and value in ephemeral storage
+pairs. The objects in an ephemeral storage pair are stored weakly, but
+both protected from reclamation as long as there remain non-weak
+references to the first object from outside the ephemeral storage pair.
+In particular, an @code{ephemeral-key} hash table (where the keys are
+the first objects in the ephemeral storage pairs), with an association
+mapping an element of a vector to the vector itself, may delete said
+association when no non-weak references remain to the vector nor its
+element in the rest of the program. If it were a @code{weak-key} hash
+table, the reference to the key from within the vector would cyclically
+protect the key and value from reclamation, even when no non-weak
+references to the key and value remained from outside the hash table.
+At the absence of such references between the key and value,
+@code{ephemeral-key} and @code{ephemeral-value} hash tables behave
+effectively equivalent to @code{weak-key} and @code{weak-value} hash
+tables.
+
+@code{ephemeral-key-and-value} hash tables use a pair of ephemeral
+storage pairs for each association: one where the key is the first
+object and one where the value is. This means that the key and value
+are protected from reclamation until no references remain to neither the
+key nor value from outside the hash table. In contrast, a
+@code{weak-key-and-value} hash table will delete an association as soon
+as either the key or value is reclaimed.
+
+This document uses the @var{hashtable} parameter name for arguments that
+must be hash tables, and the @var{key} parameter name for arguments that
+must be hash table keys.
+
+@node SRFI 126 Constructors
+@subsubsection SRFI 126 Constructors
+
+@deffn {Scheme Procedure} make-eq-hashtable
+@deffnx {Scheme Procedure} make-eq-hashtable capacity
+@deffnx {Scheme Procedure} make-eq-hashtable capacity weakness
+
+Return a newly allocated mutable hash table that accepts arbitrary
+objects as keys, and compares those keys with @code{eq?}. If the
+@var{capacity} argument is provided and not @code{#f}, it must be an
+exact non-negative integer and the initial capacity of the hash table is
+set to approximately @var{capacity} elements. The @var{weakness}
+argument, if provided, must be one of: @code{#f}, @code{weak-key},
+@code{weak-value}, @code{weak-key-and-value}, @code{ephemeral-key},
+@code{ephemeral-value}, and @code{ephemeral-key-and-value}, and
+determines the weakness or ephemeral status for the keys and values in
+the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} make-eqv-hashtable
+@deffnx {Scheme Procedure} make-eqv-hashtable capacity
+@deffnx {Scheme Procedure} make-eqv-hashtable capacity weakness
+
+Return a newly allocated mutable hash table that accepts arbitrary
+objects as keys, and compares those keys with @code{eqv?}. The
+semantics of the optional arguments are as in @code{make-eq-hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} make-hashtable hash equiv
+@deffnx {Scheme Procedure} make-hashtable hash equiv capacity
+@deffnx {Scheme Procedure} make-hashtable hash equiv capacity weakness
+
+If @var{hash} is @code{#f} and @var{equiv} is the @code{eq?} procedure,
+the semantics of @code{make-eq-hashtable} apply to the rest of the
+arguments. If @var{hash} is @code{#f} and @var{equiv} is the
+@code{eqv?} procedure, the semantics of @code{make-eqv-hashtable} apply
+to the rest of the arguments.
+
+Otherwise, @var{hash} must be a pair of hash functions or a hash
+function, and @var{equiv} must be a procedure. @var{equiv} should
+accept two keys as arguments and return a single value. None of the
+procedures should mutate the hash table returned by
+@code{make-hashtable}. The @code{make-hashtable} procedure returns a
+newly allocated mutable hash table using the function(s) specified by
+@var{hash} as its hash function(s), and @var{equiv} as the equivalence
+function used to compare keys. The semantics of the remaining arguments
+are as in @code{make-eq-hashtable} and @code{make-eqv-hashtable}.
+
+The @var{hash} functions and @var{equiv} should behave like pure
+functions on the domain of keys. For example, the @code{string-hash}
+and @code{string=?} procedures are permissible only if all keys are
+strings and the contents of those strings are never changed so long as
+any of them continues to serve as a key in the hash table. Furthermore,
+any pair of keys for which @var{equiv} returns true should be hashed to
+the same exact integer objects by the given @var{hash} function(s).
+
+@quotation Note
+Hash tables are allowed to cache the results of calling a hash function
+and equivalence function, so programs cannot rely on a hash function
+being called for every lookup or update. Furthermore any hash table
+operation may call a hash function more than once.
+@end quotation
+@end deffn
+
+@deffn {Scheme Procedure} alist->eq-hashtable alist
+@deffnx {Scheme Procedure} alist->eq-hashtable capacity alist
+@deffnx {Scheme Procedure} alist->eq-hashtable capacity weakness alist
+
+The semantics of this procedure can be described as:
+
+@lisp
+(let ((ht (make-eq-hashtable @var{capacity} @var{weakness})))
+ (for-each (lambda (entry)
+ (hashtable-set! ht (car entry) (cdr entry)))
+ (reverse alist))
+ ht)
+@end lisp
+
+where omission of the @var{capacity} and/or @var{weakness} arguments
+corresponds to their omission in the call to @code{make-eq-hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} alist->eqv-hashtable alist
+@deffnx {Scheme Procedure} alist->eqv-hashtable capacity alist
+@deffnx {Scheme Procedure} alist->eqv-hashtable capacity weakness alist
+
+This procedure is equivalent to @code{alist->eq-hashtable} except that
+@code{make-eqv-hashtable} is used to construct the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} alist->hashtable hash equiv alist
+@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity alist
+@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity weakness alist
+
+This procedure is equivalent to @code{alist->eq-hashtable} except that
+@code{make-hashtable} is used to construct the hash table, with the
+given @var{hash} and @var{equiv} arguments.
+@end deffn
+
+@deffn {Scheme Syntax} weakness weakness-symbol
+
+The @var{weakness-symbol} must correspond to one of the non-#f values
+accepted for the @var{weakness} argument of the constructor procedures,
+that is, @code{'weak-key}, @code{'weak-value},
+@code{'weak-key-and-value}, @code{'ephemeral-key},
+@code{'ephemeral-value}, or @code{'ephemeral-key-and-value}. Given such
+a symbol, it is returned as a datum. Passing any other argument is an
+error.
+@end deffn
+
+@node SRFI 126 Procedures
+@subsubsection SRFI 126 Procedures
+
+@deffn {Scheme Procedure} hashtable? obj
+
+Return @code{#t} if @var{obj} is a hash table, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-size hashtable
+
+Return the number of keys contained in @var{hashtable} as an exact
+integer object.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-ref hashtable key
+@deffnx {Scheme Procedure} hashtable-ref hashtable key default
+
+Return the value in @var{hashtable} associated with @var{key}. If
+@var{hashtable} does not contain an association for key, @var{default}
+is returned. If @var{hashtable} does not contain an association for key
+and the @var{default} argument is not provided, an error is signaled.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-set! hashtable key obj
+
+Change @var{hashtable} to associate @var{key} with @var{obj}, adding a
+new association or replacing any existing association for @var{key}, and
+return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-delete! hashtable key
+
+Remove any association for @var{key} within @var{hashtable} and return
+an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-contains? hashtable key
+
+Return @code{#t} if @var{hashtable} contains an association for
+@var{key}, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-lookup hashtable key
+
+Return two values: the value in @var{hashtable} associated with
+@var{key} or an unspecified value if there is none, and a boolean
+indicating whether an association was found.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-update! hashtable key proc
+@deffnx {Scheme Procedure} hashtable-update! hashtable key proc default
+
+@var{proc} should accept one argument, should return a single value, and
+should not mutate hashtable. The @code{hashtable-update!} procedure
+applies @var{proc} to the value in @var{hashtable} associated with
+@var{key}, or to @var{default} if @var{hashtable} does not contain an
+association for @var{key}. The @var{hashtable} is then changed to
+associate @var{key} with the value returned by @var{proc}. If
+@var{hashtable} does not contain an association for @var{key} and the
+@var{default} argument is not provided, an error should be signaled.
+@var{hashtable-update!} returns the value of the new association for
+@var{key} in @var{hashtable}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-intern! hashtable key default-proc
+
+@var{default-proc} should accept zero arguments, should return a single
+value, and should not mutate @var{hashtable}. The
+@code{hashtable-intern!} procedure returns the association for key in
+@var{hashtable} if there is one, otherwise it calls @var{default-proc}
+with zero arguments, associates its return value with @var{key} in
+@var{hashtable}, and returns that value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-copy hashtable
+@deffnx {Scheme Procedure} hashtable-copy hashtable mutable
+@deffnx {Scheme Procedure} hashtable-copy hashtable mutable weakness
+
+Return a copy of @var{hashtable}. If the @var{mutable} argument is
+provided and is true, the returned @var{hashtable} is mutable; otherwise
+it is immutable. If the optional @var{weakness} argument is provided,
+it determines the weakness of the copy, otherwise the weakness attribute
+of @var{hashtable} is used.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-clear! hashtable
+@deffnx {Scheme Procedure} hashtable-clear! hashtable capacity
+
+Remove all associations from @var{hashtable} and return an unspecified
+value. If @var{capacity} is provided and not @code{#f}, it must be an
+exact non-negative integer and the current capacity of the
+@var{hashtable} is reset to approximately @var{capacity} elements.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-empty-copy hashtable
+@deffnx {Scheme Procedure} hashtable-empty-copy hashtable capacity
+
+Return a newly allocated mutable @var{hashtable} that has the same hash
+and equivalence functions and weakness attribute as @var{hashtable}.
+The @var{capacity} argument may be @code{#t} to set the initial capacity
+of the copy to approximately @samp{(hashtable-size @var{hashtable})}
+elements; otherwise the semantics of @code{make-eq-hashtable} apply to
+the @var{capacity} argument.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-keys hashtable
+
+Return a vector of all keys in @var{hashtable}. The order of the vector
+is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-values hashtable
+
+Return a vector of all values in @var{hashtable}. The order of the
+vector is unspecified, and is not guaranteed to match the order of keys
+in the result of @code{hashtable-keys}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-entries hashtable
+
+Return two values, a vector of the keys in @var{hashtable}, and a vector
+of the corresponding values.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-key-list hashtable
+
+Return a list of all keys in @var{hashtable}. The order of the list is
+unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-value-list hashtable
+
+Return a list of all values in @var{hashtable}. The order of the list
+is unspecified, and is not guaranteed to match the order of keys in the
+result of @code{hashtable-key-list}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-entry-lists hashtable
+
+Return two values, a list of the keys in @var{hashtable}, and a list of
+the corresponding values.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-walk hashtable proc
+
+@var{proc} should accept two arguments, and should not mutate
+@var{hashtable}. The @code{hashtable-walk} procedure applies @var{proc}
+once for every association in @var{hashtable}, passing it the key and
+value as arguments. The order in which @var{proc} is applied to the
+associations is unspecified. Return values of @var{proc} are ignored.
+@code{hashtable-walk} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-update-all! hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-update-all!}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and changes
+the value of the association to the return value of @var{proc}. The
+order in which @var{proc} is applied to the associations is unspecified.
+@code{hashtable-update-all!} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-prune! hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-prune!}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and deletes
+the association if @var{proc} returns a true value. The order in which
+@var{proc} is applied to the associations is unspecified.
+@code{hashtable-prune!} returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-merge! hashtable-dest hashtable-source
+
+Effectively equivalent to:
+
+@lisp
+(begin
+ (hashtable-walk @var{hashtable-source}
+ (lambda (key value)
+ (hashtable-set! @var{hashtable-dest} key value)))
+ hashtable-dest)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-sum hashtable init proc
+
+@var{proc} should accept three arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-sum}
+procedure accumulates a result by applying @var{proc} once for every
+association in @var{hashtable}, passing it as arguments: the key, the
+value, and the result of the previous application or @var{init} at the
+first application. The order in which @var{proc} is applied to the
+associations is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-map->lset hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-map->lset}
+procedure applies @var{proc} once for every association in
+@var{hashtable}, passing it the key and value as arguments, and
+accumulates the returned values into a list. The order in which
+@var{proc} is applied to the associations, and the order of the results
+in the returned list, are unspecified.
+
+@quotation note
+This procedure can trivially imitate @code{hashtable->alist}:
+@samp{(hashtable-map->lset @var{hashtable} cons)}.
+@end quotation
+
+@quotation warning
+Since the order of the results is unspecified, the returned list should
+be treated as a set or multi-set. Relying on the order of results will
+produce unpredictable programs.
+@end quotation
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-find hashtable proc
+
+@var{proc} should accept two arguments, should return a single value,
+and should not mutate @var{hashtable}. The @code{hashtable-find}
+procedure applies @var{proc} to associations in @var{hashtable} in an
+unspecified order until one of the applications returns a true value or
+the associations are exhausted. Three values are returned: the key and
+value of the matching association or two unspecified values if none
+matched, and a boolean indicating whether any association matched.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-empty? hashtable
+
+Effectively equivalent to @samp{(zero? (hashtable-size @var{hashtable}))}.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-pop! hashtable
+
+Effectively equivalent to:
+
+@lisp
+(let-values (((key value found?)
+ (hashtable-find @var{hashtable} (lambda (k v) #t))))
+ (when (not found?)
+ (error))
+ (hashtable-delete! @var{hashtable} key)
+ (values key value))
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-inc! hashtable key
+@deffnx {Scheme Procedure} hashtable-inc! hashtable key number
+
+Effectively equivalent to:
+
+@lisp
+(hashtable-update! @var{hashtable} @var{key} (lambda (v) (+ v @var{number})) 0)
+@end lisp
+
+where @var{number} is 1 when not provided.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-dec! hashtable key
+@deffnx {Scheme Procedure} hashtable-dec! hashtable key number
+
+Effectively equivalent to:
+
+@lisp
+(hashtable-update! @var{hashtable} @var{key} (lambda (v) (- v @var{number})) 0)
+@end lisp
+
+where @var{number} is 1 when not provided.
+@end deffn
+
+@node SRFI 126 Inspection
+@subsubsection SRFI 126 Inspection
+
+@deffn {Scheme Procedure} hashtable-equivalence-function hashtable
+
+Return the equivalence function used by @var{hashtable} to compare
+keys. For hash tables created with @code{make-eq-hashtable} and
+@code{make-eqv-hashtable}, returns @code{eq?} and @code{eqv?}
+respectively.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-hash-function hashtable
+
+Return the hash function(s) used by @var{hashtable}, that is, either a
+procedure, or a pair of procedures. For hash tables created by
+@code{make-eq-hashtable} or @code{make-eqv-hashtable}, @code{#f} is
+returned.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-weakness hashtable
+
+Return the weakness attribute of @var{hashtable}. The same values that
+are accepted as the weakness argument in the constructor procedures are
+returned. This procedure may expose the fact that @code{weak-key} and
+@code{weak-value} hash tables are implemented as @var{ephemeral-key} and
+@var{ephemeral-value} hash tables, returning symbols indicating the
+latter even when the former were used to construct the hash table.
+@end deffn
+
+@deffn {Scheme Procedure} hashtable-mutable? hashtable
+
+Return @code{#t} if @var{hashtable} is mutable, otherwise @code{#f}.
+@end deffn
+
+@node SRFI 126 Hash functions
+@subsubsection SRFI 126 Hash functions
+
+The @code{equal-hash}, @code{string-hash}, and @code{string-ci-hash}
+procedures of this section are acceptable as the hash functions of a
+hash table only if the keys on which they are called are not mutated
+while they remain in use as keys in the hash table.
+
+An implementation may initialize its hash functions with a random salt
+value at program startup, meaning they are not guaranteed to return the
+same values for the same inputs across multiple runs of a program. If
+however the environment variable @env{SRFI_126_HASH_SEED} is set to a
+non-empty string before program startup, then the salt value is derived
+from that string in a deterministic manner.
+
+@deffn {Scheme Syntax} hash-salt
+
+Expand to a form evaluating to an exact non-negative integer that lies
+within the fixnum range of the implementation. The value the expanded
+form evaluates to remains constant throughout the execution of the
+program. It is random for every run of the program, except when the
+environment variable @env{SRFI_126_HASH_SEED} is set to a non-empty
+string before program startup, in which case it is derived from the
+value of that environment variable in a deterministic manner.
+@end deffn
+
+@deffn {Scheme Procedure} equal-hash obj
+
+Return an integer hash value for @var{obj}, based on its structure and
+current contents. This hash function is suitable for use with
+@code{equal?} as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} string-hash string
+
+Return an integer hash value for @var{string}, based on its current
+contents. This hash function is suitable for use with @code{string=?}
+as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci-hash string
+
+Return an integer hash value for @var{string} based on its current
+contents, ignoring case. This hash function is suitable for use with
+@code{string-ci=?} as an equivalence function.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-hash symbol
+
+Return an integer hash value for @var{symbol}.
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-126.scm b/module/srfi/srfi-126.scm
new file mode 100644
index 000000000..ce91fd158
--- /dev/null
+++ b/module/srfi/srfi-126.scm
@@ -0,0 +1,396 @@
+;;; srfi-126.scm -- SRFI 126 - R6RS-based hashtables.
+
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 control)
+ #:use-module ((rnrs hashtables) #:select (equal-hash
+ string-hash
+ string-ci-hash))
+ #:export (make-eq-hashtable
+ make-eqv-hashtable make-hashtable
+ alist->eq-hashtable alist->eqv-hashtable alist->hashtable
+ weakness
+ hashtable? hashtable-size
+ hashtable-ref hashtable-set! hashtable-delete! hashtable-contains?
+ hashtable-lookup hashtable-update! hashtable-intern!
+ hashtable-copy hashtable-clear! hashtable-empty-copy
+ hashtable-keys hashtable-values hashtable-entries
+ hashtable-key-list hashtable-value-list hashtable-entry-lists
+ hashtable-walk hashtable-update-all! hashtable-prune!
+ hashtable-merge!
+ hashtable-sum hashtable-map->lset hashtable-find
+ hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec!
+ hashtable-equivalence-function hashtable-hash-function
+ hashtable-weakness hashtable-mutable?
+ hash-salt)
+ #:re-export (equal-hash string-hash string-ci-hash))
+
+(define-record-type <hashtable>
+ (%make-hashtable %table %hash %assoc hash equiv weakness mutable)
+ hashtable?
+ (%table %hashtable-table)
+ (%hash %hashtable-hash)
+ (%assoc %hashtable-assoc)
+ (hash hashtable-hash-function)
+ (equiv hashtable-equivalence-function)
+ (weakness hashtable-weakness)
+ (mutable hashtable-mutable? %hashtable-set-mutable!))
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define (make-table capacity weakness)
+ (let ((capacity (or capacity 32)))
+ (case weakness
+ ((#f) (make-hash-table capacity))
+ ((weak-key) (make-weak-key-hash-table capacity))
+ ((weak-value) (make-weak-value-hash-table capacity))
+ ((weak-key-and-value) (make-doubly-weak-hash-table capacity))
+ (else (error "Hashtable weakness not supported." weakness)))))
+
+(define* (make-eq-hashtable #:optional capacity weakness)
+ (let ((table (make-table capacity weakness)))
+ (%make-hashtable table hashq assq #f eq? weakness #t)))
+
+(define* (make-eqv-hashtable #:optional capacity weakness)
+ (let ((table (make-table capacity weakness)))
+ (%make-hashtable table hashv assv #f eqv? weakness #t)))
+
+(define* (make-hashtable hash equiv #:optional capacity weakness)
+ (cond
+ ((and (not hash) (eq? equiv eq?))
+ (make-eq-hashtable capacity weakness))
+ ((and (not hash) (eq? equiv eqv?))
+ (make-eqv-hashtable capacity weakness))
+ (else
+ (let* ((table (make-table capacity weakness))
+ (hash (if (pair? hash)
+ (car hash)
+ hash))
+ (%hash (lambda (obj bound)
+ (modulo (hash obj) bound)))
+ (assoc (lambda (key alist)
+ (find (lambda (entry)
+ (equiv (car entry) key))
+ alist))))
+ (%make-hashtable table %hash assoc hash equiv weakness #t)))))
+
+(define (alist->eq-hashtable . args)
+ (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+ (apply alist->hashtable #f eqv? args))
+
+(define alist->hashtable
+ (case-lambda
+ ((hash equiv alist)
+ (alist->hashtable hash equiv #f #f alist))
+ ((hash equiv capacity alist)
+ (alist->hashtable hash equiv capacity #f alist))
+ ((hash equiv capacity weakness alist)
+ (let ((ht (make-hashtable hash equiv capacity weakness)))
+ (for-each (lambda (entry)
+ (hashtable-set! ht (car entry) (cdr entry)))
+ (reverse alist))
+ ht))))
+
+(define-syntax weakness
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <sym>)
+ (let ((sym (syntax->datum #'<sym>)))
+ (case sym
+ ((weak-key weak-value weak-key-and-value ephemeral-key
+ ephemeral-value ephemeral-key-and-value)
+ #''sym)
+ (else
+ (error "Bad weakness symbol." sym))))))))
+
+(define (hashtable-size ht)
+ (hash-count (const #t) (%hashtable-table ht)))
+
+(define* (%hashtable-ref ht key default)
+ (hashx-ref (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key default))
+
+(define* (hashtable-ref ht key #:optional (default nil))
+ (let ((val (%hashtable-ref ht key default)))
+ (if (nil? val)
+ (error "No association for key in hashtable." key ht)
+ val)))
+
+(define (assert-mutable ht)
+ (when (not (hashtable-mutable? ht))
+ (error "Hashtable is immutable." ht)))
+
+(define (hashtable-set! ht key value)
+ (assert-mutable ht)
+ (hashx-set! (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key value)
+ *unspecified*)
+
+(define (hashtable-delete! ht key)
+ (assert-mutable ht)
+ (hashx-remove! (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key)
+ *unspecified*)
+
+(define (hashtable-contains? ht key)
+ (not (nil? (%hashtable-ref ht key nil))))
+
+(define (hashtable-lookup ht key)
+ (let ((val (%hashtable-ref ht key nil)))
+ (if (nil? val)
+ (values #f #f)
+ (values val #t))))
+
+(define* (hashtable-update! ht key updater #:optional (default nil))
+ (assert-mutable ht)
+ (let ((handle (hashx-create-handle!
+ (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key nil)))
+ (if (eq? nil (cdr handle))
+ (if (nil? default)
+ (error "No association for key in hashtable." key ht)
+ (set-cdr! handle (updater default)))
+ (set-cdr! handle (updater (cdr handle))))
+ (cdr handle)))
+
+(define (hashtable-intern! ht key default-proc)
+ (assert-mutable ht)
+ (let ((handle (hashx-create-handle!
+ (%hashtable-hash ht) (%hashtable-assoc ht)
+ (%hashtable-table ht) key nil)))
+ (when (nil? (cdr handle))
+ (set-cdr! handle (default-proc)))
+ (cdr handle)))
+
+(define* (hashtable-copy ht #:optional mutable weakness)
+ (let ((copy (hashtable-empty-copy ht (hashtable-size ht) weakness)))
+ (hashtable-walk ht
+ (lambda (k v)
+ (hashtable-set! copy k v)))
+ (%hashtable-set-mutable! copy mutable)
+ copy))
+
+(define* (hashtable-clear! ht #:optional _capacity)
+ (assert-mutable ht)
+ (hash-clear! (%hashtable-table ht))
+ *unspecified*)
+
+(define* (hashtable-empty-copy ht #:optional capacity weakness)
+ (make-hashtable (hashtable-hash-function ht)
+ (hashtable-equivalence-function ht)
+ (case capacity
+ ((#f) #f)
+ ((#t) (hashtable-size ht))
+ (else capacity))
+ (or weakness (hashtable-weakness ht))))
+
+(define (hashtable-keys ht)
+ (let ((keys (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (+ i 1)))
+ keys))
+
+(define (hashtable-values ht)
+ (let ((vals (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! vals i v)
+ (+ i 1)))
+ vals))
+
+(define (hashtable-entries ht)
+ (let ((keys (make-vector (hashtable-size ht)))
+ (vals (make-vector (hashtable-size ht))))
+ (hashtable-sum ht 0
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (vector-set! vals i v)
+ (+ i 1)))
+ (values keys vals)))
+
+(define (hashtable-key-list ht)
+ (hashtable-map->lset ht (lambda (k v) k)))
+
+(define (hashtable-value-list ht)
+ (hashtable-map->lset ht (lambda (k v) v)))
+
+(define (hashtable-entry-lists ht)
+ (let ((keys&vals (cons '() '())))
+ (hashtable-walk ht
+ (lambda (k v)
+ (set-car! keys&vals (cons k (car keys&vals)))
+ (set-cdr! keys&vals (cons v (cdr keys&vals)))))
+ (car+cdr keys&vals)))
+
+(define (hashtable-walk ht proc)
+ (hash-for-each proc (%hashtable-table ht)))
+
+(define (hashtable-update-all! ht proc)
+ (assert-mutable ht)
+ (hash-for-each-handle
+ (lambda (handle)
+ (set-cdr! handle (proc (car handle) (cdr handle))))
+ (%hashtable-table ht)))
+
+(define (hashtable-prune! ht pred)
+ (assert-mutable ht)
+ (let ((keys (hashtable-sum ht '()
+ (lambda (k v keys-to-delete)
+ (if (pred k v)
+ (cons k keys-to-delete)
+ keys-to-delete)))))
+ (for-each (lambda (k)
+ (hashtable-delete! ht k))
+ keys)))
+
+(define (hashtable-merge! ht-dest ht-src)
+ (assert-mutable ht-dest)
+ (hashtable-walk ht-src
+ (lambda (k v)
+ (hashtable-set! ht-dest k v)))
+ ht-dest)
+
+(define (hashtable-sum ht init proc)
+ (hash-fold proc init (%hashtable-table ht)))
+
+(define (hashtable-map->lset ht proc)
+ (hash-map->list proc (%hashtable-table ht)))
+
+(define (hashtable-find ht pred)
+ (let/ec return
+ (hashtable-walk ht
+ (lambda (k v)
+ (when (pred k v)
+ (return k v #t))))
+ (return #f #f #f)))
+
+(define (hashtable-empty? ht)
+ (zero? (hashtable-size ht)))
+
+(define (hashtable-pop! ht)
+ (assert-mutable ht)
+ (when (hashtable-empty? ht)
+ (error "Cannot pop from empty hashtable." ht))
+ (let-values (((k v found?) (hashtable-find ht (const #t))))
+ (hashtable-delete! ht k)
+ (values k v)))
+
+(define* (hashtable-inc! ht k #:optional (x 1))
+ (assert-mutable ht)
+ (hashtable-update! ht k (lambda (v) (+ v x)) 0))
+
+(define* (hashtable-dec! ht k #:optional (x 1))
+ (assert-mutable ht)
+ (hashtable-update! ht k (lambda (v) (- v x)) 0))
+
+(define (hash-salt) 0)
+
+(set-record-type-printer!
+ <hashtable>
+ (lambda (ht port)
+ (with-output-to-port port
+ (lambda ()
+ (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+ (string-hash (@ (rnrs hashtables) string-hash))
+ (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+ (symbol-hash (@ (rnrs hashtables) symbol-hash))
+ (hash (hashtable-hash-function ht))
+ (equiv (hashtable-equivalence-function ht))
+ (alist (hashtable-map->lset ht cons)))
+ (cond
+ ((and (not hash) (eq? equiv eq?))
+ (display "#hasheq")
+ (display alist))
+ ((and (not hash) (eq? equiv eqv?))
+ (display "#hasheqv")
+ (display alist))
+ (else
+ (display "#hash")
+ (cond
+ ((and (eq? hash (@ (rnrs hashtables) equal-hash)) (eq? equiv equal?))
+ (display alist))
+ ((and (eq? hash (@ (rnrs hashtables) string-hash)) (eq? equiv string=?))
+ (display (cons 'string alist)))
+ ((and (eq? hash string-ci-hash) (eq? equiv string-ci=?))
+ (display (cons 'string-ci alist)))
+ ((and (eq? hash symbol-hash) (eq? equiv eq?))
+ (display (cons 'symbol alist)))
+ (else
+ (display (cons 'custom alist)))))))))))
+
+(read-hash-extend
+ #\h
+ (lambda (char port)
+ (with-input-from-port port
+ (lambda ()
+ (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+ (string-hash (@ (rnrs hashtables) string-hash))
+ (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+ (symbol-hash (@ (rnrs hashtables) symbol-hash))
+ (type (string-append "h" (symbol->string (read))))
+ (alist (read)))
+ (cond
+ ((string=? type "hasheq")
+ (alist->eq-hashtable alist))
+ ((string=? type "hasheqv")
+ (alist->eqv-hashtable alist))
+ (else
+ (when (not (string=? type "hash"))
+ (error "Unrecognized hash type." type))
+ (let* ((has-tag? (symbol? (car alist)))
+ (subtype (if has-tag?
+ (car alist)
+ "equal"))
+ (alist (if has-tag?
+ (cdr alist)
+ alist)))
+ (cond
+ ((string=? subtype "equal")
+ (alist->hashtable equal-hash equal? alist))
+ ((string=? subtype "string")
+ (alist->hashtable string-hash string=? alist))
+ ((string=? subtype "string-ci")
+ (alist->hashtable string-ci-hash string-ci=? alist))
+ ((string=? subtype "symbol")
+ (alist->hashtable symbol-hash eq? alist))
+ (else
+ (error "Unrecognized hash subtype." subtype)))))))))))
+
+;; Local Variables:
+;; eval: (put 'hashtable-walk 'scheme-indent-function 1)
+;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-prune! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-sum 'scheme-indent-function 2)
+;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1)
+;; eval: (put 'hashtable-find 'scheme-indent-function 1)
+;; End:
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 81e63bce2..eaa5e1fdb 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
+ tests/srfi-126.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -208,6 +209,7 @@ EXTRA_DIST = \
$(SCM_TESTS) \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
+ tests/srfi-126-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-126-test.scm b/test-suite/tests/srfi-126-test.scm
new file mode 100644
index 000000000..25ba5ae91
--- /dev/null
+++ b/test-suite/tests/srfi-126-test.scm
@@ -0,0 +1,289 @@
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; This doesn't test weakness, external representation, and quasiquote.
+
+(test-begin "SRFI-126")
+
+(test-group "constructors & inspection"
+ (test-group "eq"
+ (let ((tables (list (make-eq-hashtable)
+ (make-eq-hashtable 10)
+ (make-eq-hashtable #f #f)
+ (make-hashtable #f eq?)
+ (alist->eq-hashtable '((a . b) (c . d)))
+ (alist->eq-hashtable 10 '((a . b) (c . d)))
+ (alist->eq-hashtable #f #f '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label #f (hashtable-hash-function table))
+ (test-eq label eq? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))))
+ (test-group "eqv"
+ (let ((tables (list (make-eqv-hashtable)
+ (make-eqv-hashtable 10)
+ (make-eqv-hashtable #f #f)
+ (make-hashtable #f eqv?)
+ (alist->eqv-hashtable '((a . b) (c . d)))
+ (alist->eqv-hashtable 10 '((a . b) (c . d)))
+ (alist->eqv-hashtable #f #f '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label #f (hashtable-hash-function table))
+ (test-eq label eqv? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))))
+ (test-group "equal"
+ (let ((tables (list (make-hashtable equal-hash equal?)
+ (make-hashtable equal-hash equal? 10)
+ (make-hashtable equal-hash equal? #f #f)
+ (alist->hashtable equal-hash equal?
+ '((a . b) (c . d)))
+ (alist->hashtable equal-hash equal? 10
+ '((a . b) (c . d)))
+ (alist->hashtable equal-hash equal? #f #f
+ '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-assert label (hashtable? table))
+ (test-eq label equal-hash (hashtable-hash-function table))
+ (test-eq label equal? (hashtable-equivalence-function table))
+ (test-eq label #f (hashtable-weakness table))
+ (test-assert label (hashtable-mutable? table))))
+ (let ((table (make-hashtable (cons equal-hash equal-hash) equal?)))
+ (let ((hash (hashtable-hash-function table)))
+ (test-assert (or (eq? equal-hash hash)
+ (and (eq? equal-hash (car hash))
+ (eq? equal-hash (cdr hash)))))))))
+ (test-group "alist"
+ (let ((tables (list (alist->eq-hashtable '((a . b) (a . c)))
+ (alist->eqv-hashtable '((a . b) (a . c)))
+ (alist->hashtable equal-hash equal?
+ '((a . b) (a . c))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (let ((table (car tables))
+ (label (number->string i)))
+ (test-eq label 'b (hashtable-ref table 'a)))))))
+
+(test-group "procedures"
+ (test-group "basics"
+ (let ((table (make-eq-hashtable)))
+ (test-group "ref"
+ (test-error (hashtable-ref table 'a))
+ (test-eq 'b (hashtable-ref table 'a 'b))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-eqv 0 (hashtable-size table)))
+ (test-group "set"
+ (hashtable-set! table 'a 'c)
+ (test-eq 'c (hashtable-ref table 'a))
+ (test-eq 'c (hashtable-ref table 'a 'b))
+ (test-assert (hashtable-contains? table 'a))
+ (test-eqv 1 (hashtable-size table)))
+ (test-group "delete"
+ (hashtable-delete! table 'a)
+ (test-error (hashtable-ref table 'a))
+ (test-eq 'b (hashtable-ref table 'a 'b))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-eqv 0 (hashtable-size table)))))
+ (test-group "advanced"
+ (let ((table (make-eq-hashtable)))
+ (test-group "lookup"
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-assert (not found?))))
+ (test-group "update"
+ (test-error (hashtable-update! table 'a (lambda (x) (+ x 1))))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv 1 x)
+ (test-assert found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)))
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv x 2)
+ (test-assert found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (let-values (((x found?) (hashtable-lookup table 'a)))
+ (test-eqv x 3)
+ (test-assert found?)))
+ (test-group "intern"
+ (test-eqv 0 (hashtable-intern! table 'b (lambda () 0)))
+ (test-eqv 0 (hashtable-intern! table 'b (lambda () 1))))))
+ (test-group "copy/clear"
+ (let ((table (alist->hashtable equal-hash equal? '((a . b)))))
+ (test-group "copy"
+ (let ((table2 (hashtable-copy table)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (test-error (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #f)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (test-error (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #t)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq 'b (hashtable-ref table2 'a))
+ (hashtable-set! table2 'a 'c)
+ (test-eq 'c (hashtable-ref table2 'a)))
+ (let ((table2 (hashtable-copy table #f #f)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eq #f (hashtable-weakness table2))))
+ (test-group "clear"
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2)
+ (test-eqv 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2 10)
+ (test-eqv 0 (hashtable-size table2))))
+ (test-group "empty-copy"
+ (let ((table2 (hashtable-empty-copy table)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eqv 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-empty-copy table 10)))
+ (test-eq equal-hash (hashtable-hash-function table2))
+ (test-eq equal? (hashtable-equivalence-function table2))
+ (test-eqv 0 (hashtable-size table2))))))
+ (test-group "keys/values"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table))))
+ (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table))))
+ (let-values (((keys values) (hashtable-entries table)))
+ (test-assert (lset= eq? '(a c) (vector->list keys)))
+ (test-assert (lset= eq? '(b d) (vector->list values))))
+ (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(b d) (hashtable-value-list table)))
+ (let-values (((keys values) (hashtable-entry-lists table)))
+ (test-assert (lset= eq? '(a c) keys))
+ (test-assert (lset= eq? '(b d) values)))))
+ (test-group "iteration"
+ (test-group "walk"
+ (let ((keys '())
+ (values '()))
+ (hashtable-walk (alist->eq-hashtable '((a . b) (c . d)))
+ (lambda (k v)
+ (set! keys (cons k keys))
+ (set! values (cons v values))))
+ (test-assert (lset= eq? '(a c) keys))
+ (test-assert (lset= eq? '(b d) values))))
+ (test-group "update-all"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-update-all! table
+ (lambda (k v)
+ (string->symbol (string-append (symbol->string v) "x"))))
+ (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(bx dx) (hashtable-value-list table)))))
+ (test-group "prune"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-prune! table (lambda (k v) (eq? k 'a)))
+ (test-assert (not (hashtable-contains? table 'a)))
+ (test-assert (hashtable-contains? table 'c))))
+ (test-group "merge"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d))))
+ (table2 (alist->eq-hashtable '((a . x) (e . f)))))
+ (hashtable-merge! table table2)
+ (test-assert (lset= eq? '(a c e) (hashtable-key-list table)))
+ (test-assert (lset= eq? '(x d f) (hashtable-value-list table)))))
+ (test-group "sum"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= eq? '(a b c d)
+ (hashtable-sum table '()
+ (lambda (k v acc)
+ (lset-adjoin eq? acc k v)))))))
+ (test-group "map->lset"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (test-assert (lset= equal? '((a . b) (c . d))
+ (hashtable-map->lset table cons)))))
+ (test-group "find"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (let-values (((k v f?) (hashtable-find table
+ (lambda (k v)
+ (eq? k 'a)))))
+ (test-assert (and f? (eq? k 'a) (eq? v 'b))))
+ (let-values (((k v f?) (hashtable-find table (lambda (k v) #f))))
+ (test-assert (not f?)))))
+ (test-group "misc"
+ (test-group "empty?"
+ (test-assert (hashtable-empty? (alist->eq-hashtable '())))
+ (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b)))))))
+ (test-group "pop!"
+ (test-error (hashtable-pop! (make-eq-hashtable)))
+ (let ((table (alist->eq-hashtable '((a . b)))))
+ (let-values (((k v) (hashtable-pop! table)))
+ (test-eq 'a k)
+ (test-eq 'b v)
+ (test-assert (hashtable-empty? table)))))
+ (test-group "inc!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-inc! table 'a)
+ (test-eqv 1 (hashtable-ref table 'a))
+ (hashtable-inc! table 'a 2)
+ (test-eqv 3 (hashtable-ref table 'a))))
+ (test-group "dec!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-dec! table 'a)
+ (test-eqv -1 (hashtable-ref table 'a))
+ (hashtable-dec! table 'a 2)
+ (test-eqv -3 (hashtable-ref table 'a)))))))
+
+(test-group "hashing"
+ (test-assert (and (exact-integer? (hash-salt))))
+ (test-assert (not (negative? (hash-salt))))
+ (test-assert (= (equal-hash (list "foo" 'bar 42))
+ (equal-hash (list "foo" 'bar 42))))
+ (test-assert (= (string-hash (string-copy "foo"))
+ (string-hash (string-copy "foo"))))
+ (test-assert (= (string-ci-hash (string-copy "foo"))
+ (string-ci-hash (string-copy "FOO"))))
+ (test-assert (= (symbol-hash (string->symbol "foo"))
+ (symbol-hash (string->symbol "foo")))))
+
+(test-end "SRFI-126")
+
+(display
+ (string-append
+ "\n"
+ "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n"
+ " 14 tests are expected to fail in relation to make-eq-hashtable and\n"
+ " make-eqv-hashtable returning hashtables whose hash functions are\n"
+ " exposed instead of being #f. We have no obvious way to detect this\n"
+ " within this portable test suite, hence no XFAIL results.\n"))
+
+;; Local Variables:
+;; eval: (put (quote test-group) (quote scheme-indent-function) 1)
+;; End:
diff --git a/test-suite/tests/srfi-126.test b/test-suite/tests/srfi-126.test
new file mode 100644
index 000000000..8d8a1cd3f
--- /dev/null
+++ b/test-suite/tests/srfi-126.test
@@ -0,0 +1,49 @@
+;;;; srfi-126.test --- Test suite for SRFI-126. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-126))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-126-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 09/16] module: Add SRFI 128.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (7 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 08/16] module: Add SRFI 126 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 10/16] module: Add (scheme comparator) Maxim Cournoyer
` (6 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
From upstream commit 62504e3b5b01615297cf65c33ca76a474bd61dd3.
* module/srfi/srfi-128.scm
* module/srfi/srfi-128/128.body1.scm
* module/srfi/srfi-128/128.body2.scm
* test-suite/tests/srfi-128-test.scm
* test-suite/tests/srfi-128.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-128.scm.
(NOCOMP_SOURCES): Register 128.body1.scm and 128.body2.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI Support): Document it.
* NEWS: Update news.
---
(no changes since v5)
Changes in v5:
- Update NEWS
Changes in v4:
- Fix invalid module references (e.g. (srfi 69) -> (srfi srfi-69))
- Use .sld for srfi-128 library file extension
- Mention Expat license of SRFI 128 in guile.tex copying section
- Add copyright line in srfi-modules.texi
Changes in v3:
- Rename SRFI-128 to SRFI 128 in text
- Replace srfi-128.scm with upstream srfi/128.sld
Changes in v2:
- Remove string-hash and symbol-hash from exports (they are already
listed in #:rename)
am/bootstrap.am | 3 +
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 553 ++++++++++++++++++++++++++++-
module/srfi/srfi-128.sld | 61 ++++
module/srfi/srfi-128/128.body1.scm | 361 +++++++++++++++++++
module/srfi/srfi-128/128.body2.scm | 146 ++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-128-test.scm | 321 +++++++++++++++++
test-suite/tests/srfi-128.test | 47 +++
9 files changed, 1496 insertions(+), 4 deletions(-)
create mode 100644 module/srfi/srfi-128.sld
create mode 100644 module/srfi/srfi-128/128.body1.scm
create mode 100644 module/srfi/srfi-128/128.body2.scm
create mode 100644 test-suite/tests/srfi-128-test.scm
create mode 100644 test-suite/tests/srfi-128.test
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 3586f0873..4404113ab 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -350,6 +350,7 @@ SOURCES = \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
srfi/srfi-126.scm \
+ srfi/srfi-128.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -441,6 +442,8 @@ NOCOMP_SOURCES = \
srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
+ srfi/srfi-128/128.body1.scm \
+ srfi/srfi-128/128.body2.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 0540d2aab..f71d9a22c 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,9 +24,9 @@ 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 SRFI 126 module is adapted from
-its specification text, which is made available under the following
-Expat license:
+Additionally, the documentation of the 126 and 128 SRFI modules is
+adapted from their specification text, which is made available under the
+following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8b3315180..40ca7a2e7 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -3,6 +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 John Cowan
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -66,7 +67,8 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
* SRFI 126:: R6RS-based hash tables.
-* SRFI-171:: Transducers
+* SRFI 128:: Comparators.
+* SRFI-171:: Transducers.
@end menu
@@ -6262,6 +6264,555 @@ contents, ignoring case. This hash function is suitable for use with
Return an integer hash value for @var{symbol}.
@end deffn
+@node SRFI 128
+@subsection Comparators
+@cindex SRFI 128
+@cindex comparators
+
+@uref{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI 128}
+provides comparators, which bundle a @emph{type test predicate}, an
+@emph{equality predicate}, an @emph{ordering predicate}, and a @emph{hash
+function} into a single Scheme object. By packaging these procedures
+together, they can be treated as a single item for use in the
+implementation of data structures.
+
+@noindent
+The four procedures above have complex dependencies on one another, and
+it is inconvenient to have to pass them individually to other procedures
+that might or might not make use of all of them. For example, a set
+implementation by its nature requires only an equality predicate, but if
+it is implemented using a hash table, an appropriate hash function is
+also required if the implementation does not provide one; alternatively,
+if it is implemented using a tree, procedures specifying a total order
+are required. By passing a comparator rather than a bare equality
+predicate, the set implementation can make use of whatever procedures
+are available and useful to it.
+
+@subheading Definitions
+
+A comparator is an object of a disjoint type. It is a bundle of
+procedures that are useful for comparing two objects in a total order.
+It is an error if any of the procedures have side effects. There are
+four procedures in the bundle:
+
+@enumerate
+@item
+The @emph{type test predicate} returns @code{#t} if its argument has the
+correct type to be passed as an argument to the other three procedures,
+and @code{#f} otherwise.
+
+@item
+The @emph{equality predicate} returns @code{#t} if the two objects are the
+same in the sense of the comparator, and @code{#f} otherwise. It is the
+programmer's responsibility to ensure that it is reflexive, symmetric,
+transitive, and can handle any arguments that satisfy the type test
+predicate.
+
+@item
+The @emph{ordering predicate} returns @code{#t} if the first object
+precedes the second in a total order, and @code{#f} otherwise. Note
+that if it is true, the equality predicate must be false. It is the
+programmer's responsibility to ensure that it is irreflexive,
+anti-symmetric, transitive, and can handle any arguments that satisfy
+the type test predicate.
+
+@item
+The @emph{hash function} takes an object and returns an exact non-negative
+integer. It is the programmer's responsibility to ensure that it can
+handle any argument that satisfies the type test predicate, and that it
+returns the same value on two objects if the equality predicate says
+they are the same (but not necessarily the converse).
+@end enumerate
+
+It is also the programmer's responsibility to ensure that all four
+procedures provide the same result whenever they are applied to the same
+object(s) (in the sense of @code{eqv?}), unless the object(s) have been
+mutated since the last invocation.
+
+@subheading Limitations
+
+The comparator objects defined in SRFI 128 are not applicable to
+circular structures or to NaNs, or to objects containing any of these.
+Attempts to pass any such objects to any procedure defined here, or to
+any procedure that is part of a comparator defined here, is an error
+except as otherwise noted.
+
+@menu
+* SRFI 128 Predicates::
+* SRFI 128 Constructors::
+* SRFI 128 Standard hash functions::
+* SRFI 128 Bounds and salt::
+* SRFI 128 Default comparators::
+* SRFI 128 Accessors and Invokers::
+* SRFI 128 Comparison predicates::
+* SRFI 128 Syntax::
+@end menu
+
+@node SRFI 128 Predicates
+@subsubsection SRFI 128 Predicates
+
+@deffn {Scheme Procedure} comparator? obj
+
+Return @code{#t} if @var{obj} is a comparator, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-ordered? comparator
+
+Return @code{#t} if @var{comparator} has a supplied ordering predicate,
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-hashable? comparator
+Return @code{#t} if @var{comparator} has a supplied hash function, and
+@code{#f} otherwise.
+@end deffn
+
+@node SRFI 128 Constructors
+@subsubsection SRFI 128 Constructors
+
+The following comparator constructors all supply appropriate type test
+predicates, equality predicates, ordering predicates, and hash functions
+based on the supplied arguments. They are allowed to cache their
+results: they need not return a newly allocated object, since
+comparators are pure and functional. In addition, the procedures in a
+comparator are likewise pure and functional.
+
+@deffn {Scheme Procedure} make-comparator type-test equality ordering hash
+
+Return a comparator which bundles the @var{type-test}, @var{equality},
+@var{ordering}, and @var{hash} procedures provided. However, if
+@var{ordering} or @var{hash} is @code{#f}, a procedure is provided that
+signals an error on application. The predicates
+@code{comparator-ordered?} and/or @code{comparator-hashable?},
+respectively, will return @code{#f} in these cases.
+
+Here are calls on @code{make-comparator} that will return useful
+comparators for standard Scheme types:
+
+@itemize
+@item
+@samp{(make-comparator boolean? boolean=? (lambda (x y) (and (not x) y))
+boolean-hash)} will return a comparator for booleans, expressing the
+ordering @samp{#f < #t} and the standard hash function for booleans.
+
+@item
+@samp{(make-comparator real? = < (lambda (x) (exact (abs x))))} will
+return a comparator expressing the natural ordering of real numbers and
+a plausible (but not optimal) hash function.
+
+@item
+@samp{(make-comparator string? string=? string<? string-hash)} will
+return a comparator expressing the ordering of strings and the standard
+hash function.
+
+@item
+@samp{(make-comparator string? string-ci=? string-ci<? string-ci-hash)}
+will return a comparator expressing the case-insensitive ordering of
+strings and the standard case-insensitive hash function.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-pair-comparator car-comparator cdr-comparator
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument is a pair, if the car
+satisfies the type test predicate of @var{car-comparator}, and the cdr
+satisfies the type test predicate of @var{cdr-comparator}.
+
+@item
+The equality function returns @code{#t} if the cars are equal according
+to @var{car-comparator} and the cdrs are equal according to
+@var{cdr-comparator}, and @code{#f} otherwise.
+
+@item
+The ordering function first compares the cars of its pairs using the
+equality predicate of @var{car-comparator}. If they are not equal, then
+the ordering predicate of @var{car-comparator} is applied to the cars
+and its value is returned. Otherwise, the predicate compares the cdrs
+using the equality predicate of @var{cdr-comparator}. If they are not
+equal, then the ordering predicate of @var{cdr-comparator} is applied to
+the cdrs and its value is returned.
+
+@item
+The hash function computes the hash values of the car and the cdr using
+the hash functions of @var{car-comparator} and @var{cdr-comparator}
+respectively and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-list-comparator element-comparator type-test empty? head tail
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The total order defined by the equality and ordering functions is as
+follows (known as lexicographic order):
+
+@itemize
+@item
+The empty sequence, as determined by calling @code{empty?}, compares
+equal to itself.
+@item
+The empty sequence compares less than any non-empty sequence.
+@item
+Two non-empty sequences are compared by calling the @var{head} procedure
+on each. If the heads are not equal when compared using
+@var{element-comparator}, the result is the result of that comparison.
+Otherwise, the results of calling the @var{tail} procedure are compared
+recursively.
+@end itemize
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} make-vector-comparator element-comparator type-test length ref
+
+This procedure returns comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} if its argument satisfies
+@var{type-test} and the elements satisfy the type test predicate of
+@var{element-comparator}.
+
+@item
+The equality predicate returns @code{#t} if both of the following tests
+are satisfied in order: the lengths of the vectors are the same in the
+sense of @code{=}, and the elements of the vectors are the same in the
+sense of the equality predicate of @var{element-comparator}.
+
+@item
+The ordering predicate returns @code{#t} if the results of applying
+@var{length} to the first vector is less than the result of applying
+length to the second vector. If the lengths are equal, then the
+elements are examined pairwise using the ordering predicate of
+@var{element-comparator}. If any pair of elements returns @code{#t},
+then that is the result of the list comparator's ordering predicate;
+otherwise the result is @code{#f}.
+
+@item
+The hash function computes the hash values of the elements using the
+hash function of @var{element-comparator} and then hashes them together.
+@end itemize
+
+Here is an example, which returns a comparator for byte vectors:
+
+@lisp
+(make-vector-comparator
+ (make-comparator exact-integer? = < number-hash)
+ bytevector?
+ bytevector-length
+ bytevector-u8-ref)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} make-eq-comparator
+@deffnx {Scheme Procedure} make-eqv-comparator
+@deffnx {Scheme Procedure} make-equal-comparator
+
+These procedures return comparators whose functions behave as follows:
+
+@itemize
+@item
+The type test returns @code{#t} in all cases.
+
+@item
+The equality functions are @code{eq?}, @code{eqv?}, and @code{equal?},
+respectively.
+
+@item
+The ordering function is set @code{#f}, and attempting to use it will
+cause an error with the message @code{"ordering is not supported"}.
+
+@item
+The hash function is @code{default-hash}.
+@end itemize
+@end deffn
+
+@node SRFI 128 Standard hash functions
+@subsubsection SRFI 128 Standard hash functions
+
+These are hash functions for some standard Scheme types, suitable for
+passing to @code{make-comparator}. Users may write their own hash
+functions with the same signature. However, if programmers wish their
+hash functions to be backward compatible with the reference
+implementation of @uref{https://srfi.schemers.org/srfi-69/srfi-69.html,
+SRFI 69}, they are advised to write their hash functions to accept a
+second argument and ignore it.
+
+@deffn {Scheme Procedure} boolean-hash obj
+@deffnx {Scheme Procedure} char-hash obj
+@deffnx {Scheme Procedure} string-hash obj
+@deffnx {Scheme Procedure} string-ci-hash obj
+@deffnx {Scheme Procedure} symbol-hash obj
+@deffnx {Scheme Procedure} number-hash obj
+@end deffn
+
+These are suitable hash functions for the specified types. The hash
+functions @code{char-ci-hash} and @code{string-ci-hash} treat their
+argument case-insensitively. Note that while @code{symbol-hash} may
+return the hashed value of applying @code{symbol->string} and then
+@code{string-hash} to the symbol, this is not a requirement.
+
+@node SRFI 128 Bounds and salt
+@subsubsection SRFI 128 Bounds and salt
+
+The following macros allow the callers of hash functions to affect their
+behavior without interfering with the calling signature of a hash
+function, which accepts a single argument (the object to be hashed) and
+returns its hash value.
+
+@deffn {Scheme Syntax} hash-bound
+
+Hash functions should be written so as to return a number between
+@code{0} and the largest reasonable number of elements (such as hash
+buckets) a data structure in the implementation might have. This value
+is defined as @math{2^25-1} or @code{33554432} in the reference
+implementation used by Guile. This value provides the current bound as
+a positive exact integer, typically for use by user-written hash
+functions. However, they are not required to bound their results in
+this way.
+@end deffn
+
+@deffn {Scheme Syntax} hash-salt
+
+A salt is random data in the form of a non-negative exact integer used
+as an additional input to a hash function in order to defend against
+dictionary attacks, or (when used in hash tables) against
+denial-of-service attacks that overcrowd certain hash buckets,
+increasing the amortized O(1) lookup time to O(n). Salt can also be
+used to specify which of a family of hash functions should be used for
+purposes such as cuckoo hashing. This macro provides the current value
+of the salt, typically for use by user-written hash functions. However,
+they are not required to make use of the current salt.
+
+The initial value is implementation-dependent, but must be less than the
+value of @samp{(hash-bound)}, and should be distinct for distinct runs
+of a program unless otherwise specified by the implementation. In the
+reference implementation used by Guile, the initial salt value is
+@code{16064047}.
+@end deffn
+
+@node SRFI 128 Default comparators
+@subsubsection SRFI 128 Default comparators
+
+@deffn {Scheme Procedure} make-default-comparator
+
+Return a comparator known as a @emph{default comparator} that accepts
+Scheme values and orders them in a way that respects the following
+conditions:
+
+@itemize
+@item
+Given disjoint types @code{a} and @code{b}, one of three conditions must
+hold:
+@itemize
+@item
+All objects of type @code{a} compare less than all objects of type
+@code{b}.
+@item
+All objects of type @code{a} compare greater than all objects of type
+@code{b}.
+@item
+All objects of both type @code{a} and type @code{b} compare equal to
+each other. This is not permitted for any of the Scheme types mentioned
+below.
+@end itemize
+
+@item
+The empty list must be ordered before all pairs.
+
+@item
+When comparing booleans, it must use the total order @samp{#f < #t}.
+
+@item
+When comparing characters, @code{char=?} and @code{char<?} are used.
+
+@item
+When comparing pairs, it must behave the same as a comparator returned
+by @code{make-pair-comparator} with default comparators as arguments.
+
+@item
+When comparing symbols, the total order produced with @code{symbol<?}
+and @code{symbol<?} is used.
+
+@item
+When comparing bytevectors, it must behave the same as a comparator
+created by the expression @samp{(make-vector-comparator (make-comparator
+bytevector? = < number-hash) bytevector? bytevector-length
+bytevector-u8-ref)}.
+
+@item
+When comparing numbers where either number is complex, since non-real
+numbers cannot be compared with @code{<}, the following least-surprising
+ordering is defined: If the real parts are @code{<} or @code{>}, so are
+the numbers; otherwise, the numbers are ordered by their imaginary
+parts. This can still produce somewhat surprising results if one real
+part is exact and the other is inexact.
+
+@item
+When comparing real numbers, it must use @code{=} and @code{<}.
+
+@item
+When comparing strings, it must use @code{string=?} and @code{string<?}.
+
+@item
+When comparing vectors, it must behave the same as a comparator returned
+by @samp{(make-vector-comparator (make-default-comparator) vector?
+vector-length vector-ref)}.
+
+@item
+When comparing members of types registered with
+@code{comparator-register-default!}, it must behave in the same way as
+the comparator registered using that function.
+@end itemize
+
+Default comparators use @code{default-hash} as their hash function.
+@end deffn
+
+@deffn {Scheme Procedure} default-hash obj
+
+This is the hash function used by default comparators, which accepts a
+Scheme value and hashes it in a way that respects the following
+conditions:
+
+@itemize
+@item
+When applied to a pair, it must return the result of hashing together
+the values returned by @code{default-hash} when applied to the car and
+the cdr.
+
+@item
+When applied to a boolean, character, string, symbol, or number, it must
+return the same result as @code{boolean-hash}, @code{char-hash},
+@code{string-hash}, @code{symbol-hash}, or @code{number-hash}
+respectively.
+
+@item
+When applied to a list or vector, it must return the result of hashing
+together the values returned by @code{default-hash} when applied to each
+of the elements.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} comparator-register-default! comparator
+
+Register @var{comparator} for use by default comparators, such that if
+the objects being compared both satisfy the type test predicate of
+@var{comparator}, it will be employed by default comparators to compare
+them. Return an unspecified value. It is an error if any value
+satisfies both the type test predicate of @var{comparator} and any of
+the following type test predicates: @code{boolean?}, @code{char?},
+@code{null?}, @code{pair?}, @code{symbol?}, @code{bytevector?},
+@code{number?}, @code{string?}, @code{vector?}, or the type test
+predicate of a comparator that has already been registered.
+
+This procedure is intended only to extend default comparators into
+territory that would otherwise be undefined, not to override their
+existing behavior. In general, the ordering of calls to
+@code{comparator-register-default!} should be irrelevant.
+
+The comparators available from this library are not registered with the
+@code{comparator-register-default!} procedure, because the default
+comparator is meant to be under the control of the program author rather
+than the library author. It is the program author's responsibility to
+ensure that the registered comparators do not conflict with each other.
+@end deffn
+
+@node SRFI 128 Accessors and Invokers
+@subsubsection SRFI 128 Accessors and Invokers
+
+@deffn {Scheme Procedure} comparator-type-test-predicate comparator
+@deffnx {Scheme Procedure} comparator-equality-predicate comparator
+@deffnx {Scheme Procedure} comparator-ordering-predicate comparator
+@deffnx {Scheme Procedure} comparator-hash-function comparator
+@end deffn
+
+Return the four procedures of @var{comparator}.
+
+@deffn {Scheme Procedure} comparator-test-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return what it returns. More convenient than
+@code{comparator-type-test-predicate}, but less efficient when the
+predicate is called repeatedly.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-check-type comparator obj
+
+Invoke the type test predicate of @var{comparator} on @var{obj} and
+return true if it returns true, but signal an error otherwise. More
+convenient than @code{comparator-type-test-predicate}, but less
+efficient when the predicate is called repeatedly.
+@end deffn
+
+@deffn {Scheme Procedure} comparator-hash comparator obj
+
+Invoke the hash function of @var{comparator} on @var{obj} and return
+what it returns. More convenient than @code{comparator-hash-function},
+but less efficient when the predicate is called repeatedly.
+
+@quotation note
+No invokers are required for the equality and ordering predicates,
+because the @code{=?} and @code{<?} predicates described after serve
+this function.
+@end quotation
+@end deffn
+
+@node SRFI 128 Comparison predicates
+@subsubsection SRFI 128 Comparison predicates
+
+@deffn {Scheme Procedure} =? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} <=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@deffnx {Scheme Procedure} >=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{}
+@end deffn
+
+@noindent
+These procedures are analogous to the number, character, and string
+comparison predicates of Scheme. They allow the convenient use of
+comparators to handle variable data types.
+
+@noindent
+These procedures apply the equality and ordering predicates of
+@var{comparator} to the objects as follows. If the specified relation
+returns @code{#t} for all @var{object@sub{i}} and @var{object@sub{j}}
+where @var{n} is the number of objects and @math{1 <= @var{i} < @var{j}
+<= @var{n}}, then the procedures return @code{#t}, but otherwise
+@code{#f}. Because the relations are transitive, it suffices to compare
+each object with its successor. The order in which the values are
+compared is unspecified.
+
+@node SRFI 128 Syntax
+@subsubsection SRFI 128 Syntax
+
+@deffn {Scheme Procedure} comparator-if<=> [comparator] object@sub{1} object@sub{2} less-than equal-to greater-than
+
+It is an error unless @var{comparator} evaluates to a comparator and
+@var{object@sub{1}} and @var{object@sub{2}} evaluate to objects that the
+comparator can handle. If the ordering predicate returns true when
+applied to the values of @var{object@sub{1}} and @var{object@sub{2}} in
+that order, then @var{less-than} is evaluated and its value returned.
+If the equality predicate returns true when applied in the same way,
+then @var{equal-to} is evaluated and its value returned. If neither
+returns true, @var{greater-than} is evaluated and its value returned.
+
+If @var{comparator} is omitted, a default comparator is used.
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-128.sld b/module/srfi/srfi-128.sld
new file mode 100644
index 000000000..3931abea7
--- /dev/null
+++ b/module/srfi/srfi-128.sld
@@ -0,0 +1,61 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+(define-library (srfi srfi-128)
+ (export comparator? comparator-ordered? comparator-hashable?
+ make-comparator
+ make-pair-comparator make-list-comparator make-vector-comparator
+ make-eq-comparator make-eqv-comparator make-equal-comparator
+ boolean-hash char-hash char-ci-hash
+ string-hash string-ci-hash symbol-hash number-hash
+ make-default-comparator default-hash comparator-register-default!
+ comparator-type-test-predicate comparator-equality-predicate
+ comparator-ordering-predicate comparator-hash-function
+ comparator-test-type comparator-check-type comparator-hash
+ hash-bound hash-salt
+ =? <? >? <=? >=?
+ comparator-if<=>
+ )
+ (import (scheme base)
+ (scheme case-lambda)
+ (scheme char)
+ (scheme inexact)
+ (scheme complex))
+
+ (cond-expand ((library (srfi srfi-126))
+ (import (only (srfi srfi-126) equal-hash)))
+ ((library (rnrs hashtables))
+ (import (only (rnrs hashtables) equal-hash)))
+ ((library (r6rs hashtables))
+ (import (only (r6rs hashtables) equal-hash)))
+ ((library (srfi srfi-69))
+ (import (rename (only (srfi srfi-69) hash-by-identity)
+ (hash-by-identity equal-hash))))
+ (else
+ ;; FIXME: This works well enough for the test program,
+ ;; but you wouldn't want to use it in a real program.
+ (begin (define (equal-hash x) 0))))
+
+ (include "srfi-128/128.body1.scm")
+ (include "srfi-128/128.body2.scm")
+)
diff --git a/module/srfi/srfi-128/128.body1.scm b/module/srfi/srfi-128/128.body1.scm
new file mode 100644
index 000000000..8cb41a2bf
--- /dev/null
+++ b/module/srfi/srfi-128/128.body1.scm
@@ -0,0 +1,361 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;;; Main part of the SRFI 114 reference implementation
+
+;;; "There are two ways of constructing a software design: One way is to
+;;; make it so simple that there are obviously no deficiencies, and the
+;;; other way is to make it so complicated that there are no *obvious*
+;;; deficiencies." --Tony Hoare
+
+;;; Syntax (because syntax must be defined before it is used, contra Dr. Hardcase)
+
+;; Arithmetic if
+(define-syntax comparator-if<=>
+ (syntax-rules ()
+ ((if<=> a b less equal greater)
+ (comparator-if<=> (make-default-comparator) a b less equal greater))
+ ((comparator-if<=> comparator a b less equal greater)
+ (cond
+ ((=? comparator a b) equal)
+ ((<? comparator a b) less)
+ (else greater)))))
+
+;; Upper bound of hash functions is 2^25-1
+(define-syntax hash-bound
+ (syntax-rules ()
+ ((hash-bound) 33554432)))
+
+(define %salt% (make-parameter 16064047))
+
+(define-syntax hash-salt
+ (syntax-rules ()
+ ((hash-salt) (%salt%))))
+
+(define-syntax with-hash-salt
+ (syntax-rules ()
+ ((with-hash-salt new-salt hash-func obj)
+ (parameterize ((%salt% new-salt)) (hash-func obj)))))
+
+;;; Definition of comparator records with accessors and basic comparator
+
+(define-record-type comparator
+ (make-raw-comparator type-test equality ordering hash ordering? hash?)
+ comparator?
+ (type-test comparator-type-test-predicate)
+ (equality comparator-equality-predicate)
+ (ordering comparator-ordering-predicate)
+ (hash comparator-hash-function)
+ (ordering? comparator-ordered?)
+ (hash? comparator-hashable?))
+
+;; Public constructor
+(define (make-comparator type-test equality ordering hash)
+ (make-raw-comparator
+ (if (eq? type-test #t) (lambda (x) #t) type-test)
+ (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
+ (if ordering ordering (lambda (x y) (error "ordering not supported")))
+ (if hash hash (lambda (x y) (error "hashing not supported")))
+ (if ordering #t #f)
+ (if hash #t #f)))
+
+;;; Invokers
+
+;; Invoke the test type
+(define (comparator-test-type comparator obj)
+ ((comparator-type-test-predicate comparator) obj))
+
+;; Invoke the test type and throw an error if it fails
+(define (comparator-check-type comparator obj)
+ (if (comparator-test-type comparator obj)
+ #t
+ (error "comparator type check failed" comparator obj)))
+
+;; Invoke the hash function
+(define (comparator-hash comparator obj)
+ ((comparator-hash-function comparator) obj))
+
+;;; Comparison predicates
+
+;; Binary versions for internal use
+
+(define (binary=? comparator a b)
+ ((comparator-equality-predicate comparator) a b))
+
+(define (binary<? comparator a b)
+ ((comparator-ordering-predicate comparator) a b))
+
+(define (binary>? comparator a b)
+ (binary<? comparator b a))
+
+(define (binary<=? comparator a b)
+ (not (binary>? comparator a b)))
+
+(define (binary>=? comparator a b)
+ (not (binary<? comparator a b)))
+
+;; General versions for export
+
+(define (=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+
+;;; Simple ordering and hash functions
+
+(define (boolean<? a b)
+ ;; #f < #t but not otherwise
+ (and (not a) b))
+
+
+(define (boolean-hash obj)
+ (if obj (%salt%) 0))
+
+(define (char-hash obj)
+ (modulo (* (%salt%) (char->integer obj)) (hash-bound)))
+
+(define (char-ci-hash obj)
+ (modulo (* (%salt%) (char->integer (char-foldcase obj))) (hash-bound)))
+
+(define (number-hash obj)
+ (cond
+ ((nan? obj) (%salt%))
+ ((and (infinite? obj) (positive? obj)) (* 2 (%salt%)))
+ ((infinite? obj) (* (%salt%) 3))
+ ((real? obj) (abs (exact (round obj))))
+ (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj))))))
+
+;; Lexicographic ordering of complex numbers
+(define (complex<? a b)
+ (if (= (real-part a) (real-part b))
+ (< (imag-part a) (imag-part b))
+ (< (real-part a) (real-part b))))
+
+(define (string-ci-hash obj)
+ (string-hash (string-foldcase obj)))
+
+(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
+
+(define (symbol-hash obj)
+ (string-hash (symbol->string obj)))
+
+;;; Wrapped equality predicates
+;;; These comparators don't have ordering functions.
+
+(define (make-eq-comparator)
+ (make-comparator #t eq? #f default-hash))
+
+(define (make-eqv-comparator)
+ (make-comparator #t eqv? #f default-hash))
+
+(define (make-equal-comparator)
+ (make-comparator #t equal? #f default-hash))
+
+;;; Sequence ordering and hash functions
+;; The hash functions are based on djb2, but
+;; modulo 2^25 instead of 2^32 in hopes of sticking to fixnums.
+
+(define (make-hasher)
+ (let ((result (%salt%)))
+ (case-lambda
+ (() result)
+ ((n) (set! result (+ (modulo (* result 33) (hash-bound)) n))
+ result))))
+
+;;; Pair comparator
+(define (make-pair-comparator car-comparator cdr-comparator)
+ (make-comparator
+ (make-pair-type-test car-comparator cdr-comparator)
+ (make-pair=? car-comparator cdr-comparator)
+ (make-pair<? car-comparator cdr-comparator)
+ (make-pair-hash car-comparator cdr-comparator)))
+
+(define (make-pair-type-test car-comparator cdr-comparator)
+ (lambda (obj)
+ (and (pair? obj)
+ (comparator-test-type car-comparator (car obj))
+ (comparator-test-type cdr-comparator (cdr obj)))))
+
+(define (make-pair=? car-comparator cdr-comparator)
+ (lambda (a b)
+ (and ((comparator-equality-predicate car-comparator) (car a) (car b))
+ ((comparator-equality-predicate cdr-comparator) (cdr a) (cdr b)))))
+
+(define (make-pair<? car-comparator cdr-comparator)
+ (lambda (a b)
+ (if (=? car-comparator (car a) (car b))
+ (<? cdr-comparator (cdr a) (cdr b))
+ (<? car-comparator (car a) (car b)))))
+
+(define (make-pair-hash car-comparator cdr-comparator)
+ (lambda (obj)
+ (let ((acc (make-hasher)))
+ (acc (comparator-hash car-comparator (car obj)))
+ (acc (comparator-hash cdr-comparator (cdr obj)))
+ (acc))))
+
+;;; List comparator
+
+;; Cheap test for listness
+(define (norp? obj) (or (null? obj) (pair? obj)))
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+ (make-comparator
+ (make-list-type-test element-comparator type-test empty? head tail)
+ (make-list=? element-comparator type-test empty? head tail)
+ (make-list<? element-comparator type-test empty? head tail)
+ (make-list-hash element-comparator type-test empty? head tail)))
+
+
+(define (make-list-type-test element-comparator type-test empty? head tail)
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+ (let loop ((obj obj))
+ (cond
+ ((empty? obj) #t)
+ ((not (elem-type-test (head obj))) #f)
+ (else (loop (tail obj)))))))))
+
+(define (make-list=? element-comparator type-test empty? head tail)
+ (lambda (a b)
+ (let ((elem=? (comparator-equality-predicate element-comparator)))
+ (let loop ((a a) (b b))
+ (cond
+ ((and (empty? a) (empty? b) #t))
+ ((empty? a) #f)
+ ((empty? b) #f)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ (else #f))))))
+
+(define (make-list<? element-comparator type-test empty? head tail)
+ (lambda (a b)
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator)))
+ (let loop ((a a) (b b))
+ (cond
+ ((and (empty? a) (empty? b) #f))
+ ((empty? a) #t)
+ ((empty? b) #f)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ ((elem<? (head a) (head b)) #t)
+ (else #f))))))
+
+(define (make-list-hash element-comparator type-test empty? head tail)
+ (lambda (obj)
+ (let ((elem-hash (comparator-hash-function element-comparator))
+ (acc (make-hasher)))
+ (let loop ((obj obj))
+ (cond
+ ((empty? obj) (acc))
+ (else (acc (elem-hash (head obj))) (loop (tail obj))))))))
+
+
+;;; Vector comparator
+
+(define (make-vector-comparator element-comparator type-test length ref)
+ (make-comparator
+ (make-vector-type-test element-comparator type-test length ref)
+ (make-vector=? element-comparator type-test length ref)
+ (make-vector<? element-comparator type-test length ref)
+ (make-vector-hash element-comparator type-test length ref)))
+
+(define (make-vector-type-test element-comparator type-test length ref)
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator))
+ (len (length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((not (elem-type-test (ref obj n))) #f)
+ (else (loop (+ n 1)))))))))
+
+(define (make-vector=? element-comparator type-test length ref)
+ (lambda (a b)
+ (and
+ (= (length a) (length b))
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (len (length b)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ (else #f)))))))
+
+(define (make-vector<? element-comparator type-test length ref)
+ (lambda (a b)
+ (cond
+ ((< (length a) (length b)) #t)
+ ((> (length a) (length b)) #f)
+ (else
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator))
+ (len (length a)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #f)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ ((elem<? (ref a n) (ref b n)) #t)
+ (else #f))))))))
+
+(define (make-vector-hash element-comparator type-test length ref)
+ (lambda (obj)
+ (let ((elem-hash (comparator-hash-function element-comparator))
+ (acc (make-hasher))
+ (len (length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) (acc))
+ (else (acc (elem-hash (ref obj n))) (loop (+ n 1))))))))
+
+(define (string-hash obj)
+ (let ((acc (make-hasher))
+ (len (string-length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) (acc))
+ (else (acc (char->integer (string-ref obj n))) (loop (+ n 1)))))))
diff --git a/module/srfi/srfi-128/128.body2.scm b/module/srfi/srfi-128/128.body2.scm
new file mode 100644
index 000000000..b424d41b5
--- /dev/null
+++ b/module/srfi/srfi-128/128.body2.scm
@@ -0,0 +1,146 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; The default comparator
+
+;;; Standard comparators and their functions
+
+;; The unknown-object comparator, used as a fallback to everything else
+;; Everything compares exactly the same and hashes to 0
+(define unknown-object-comparator
+ (make-comparator
+ (lambda (obj) #t)
+ (lambda (a b) #t)
+ (lambda (a b) #f)
+ (lambda (obj) 0)))
+
+;; Next index for added comparator
+
+(define first-comparator-index 9)
+(define *next-comparator-index* 9)
+(define *registered-comparators* (list unknown-object-comparator))
+
+;; Register a new comparator for use by the default comparator.
+(define (comparator-register-default! comparator)
+ (set! *registered-comparators* (cons comparator *registered-comparators*))
+ (set! *next-comparator-index* (+ *next-comparator-index* 1)))
+
+;; Return ordinal for object types: null sorts before pairs, which sort
+;; before booleans, etc. Implementations can extend this.
+;; People who call comparator-register-default! effectively do extend it.
+(define (object-type obj)
+ (cond
+ ((null? obj) 0)
+ ((pair? obj) 1)
+ ((boolean? obj) 2)
+ ((char? obj) 3)
+ ((string? obj) 4)
+ ((symbol? obj) 5)
+ ((number? obj) 6)
+ ((vector? obj) 7)
+ ((bytevector? obj) 8)
+ ; Add more here if you want: be sure to update comparator-index variables
+ (else (registered-index obj))))
+
+;; Return the index for the registered type of obj.
+(define (registered-index obj)
+ (let loop ((i 0) (registry *registered-comparators*))
+ (cond
+ ((null? registry) (+ first-comparator-index i))
+ ((comparator-test-type (car registry) obj) (+ first-comparator-index i))
+ (else (loop (+ i 1) (cdr registry))))))
+
+;; Given an index, retrieve a registered conductor.
+;; Index must be >= first-comparator-index.
+(define (registered-comparator i)
+ (list-ref *registered-comparators* (- i first-comparator-index)))
+
+(define (dispatch-equality type a b)
+ (case type
+ ((0) #t) ; All empty lists are equal
+ ((1) ((make-pair=? (make-default-comparator) (make-default-comparator)) a b))
+ ((2) (boolean=? a b))
+ ((3) (char=? a b))
+ ((4) (string=? a b))
+ ((5) (symbol=? a b))
+ ((6) (= a b))
+ ((7) ((make-vector=? (make-default-comparator)
+ vector? vector-length vector-ref) a b))
+ ((8) ((make-vector=? (make-comparator exact-integer? = < default-hash)
+ bytevector? bytevector-length bytevector-u8-ref) a b))
+ ; Add more here
+ (else (binary=? (registered-comparator type) a b))))
+
+(define (dispatch-ordering type a b)
+ (case type
+ ((0) 0) ; All empty lists are equal
+ ((1) ((make-pair<? (make-default-comparator) (make-default-comparator)) a b))
+ ((2) (boolean<? a b))
+ ((3) (char<? a b))
+ ((4) (string<? a b))
+ ((5) (symbol<? a b))
+ ((6) (complex<? a b))
+ ((7) ((make-vector<? (make-default-comparator) vector? vector-length vector-ref) a b))
+ ((8) ((make-vector<? (make-comparator exact-integer? = < default-hash)
+ bytevector? bytevector-length bytevector-u8-ref) a b))
+ ; Add more here
+ (else (binary<? (registered-comparator type) a b))))
+
+;;; The author of SRFI 128 has suggested a post-finalization note
+;;; saying the first and third bullet items stating "must" requirements
+;;; for default-hash may be weakened. That allows a much faster hash
+;;; function to be used for lists and vectors.
+
+(define (default-hash obj)
+ (case (object-type obj)
+ ((0 1 7) ; empty list, pair, or vector
+ ((make-hasher) (equal-hash obj)))
+ ((2) (boolean-hash obj))
+ ((3) (char-hash obj))
+ ((4) (string-hash obj))
+ ((5) (symbol-hash obj))
+ ((6) (number-hash obj))
+ ((8) ((make-vector-hash (make-default-comparator)
+ bytevector? bytevector-length bytevector-u8-ref) obj))
+ ; Add more here
+ (else (comparator-hash (registered-comparator (object-type obj)) obj))))
+
+(define (default-ordering a b)
+ (let ((a-type (object-type a))
+ (b-type (object-type b)))
+ (cond
+ ((< a-type b-type) #t)
+ ((> a-type b-type) #f)
+ (else (dispatch-ordering a-type a b)))))
+
+(define (default-equality a b)
+ (let ((a-type (object-type a))
+ (b-type (object-type b)))
+ (if (= a-type b-type) (dispatch-equality a-type a b) #f)))
+
+(define (make-default-comparator)
+ (make-comparator
+ (lambda (obj) #t)
+ default-equality
+ default-ordering
+ default-hash))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index eaa5e1fdb..0fb5827cc 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-105.test \
tests/srfi-111.test \
tests/srfi-126.test \
+ tests/srfi-128.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
tests/srfi-126-test.scm \
+ tests/srfi-128-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-128-test.scm b/test-suite/tests/srfi-128-test.scm
new file mode 100644
index 000000000..2cad04377
--- /dev/null
+++ b/test-suite/tests/srfi-128-test.scm
@@ -0,0 +1,321 @@
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library. A 'test-begin' call is added.
+(use-modules (rnrs bytevectors)
+ (srfi srfi-64)
+ (srfi srfi-128))
+
+(define-syntax-rule (test arg ...)
+ (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+ (test-end))
+
+(test-begin "comparators")
+;;; END Guile-specific modifications.
+
+(define (print x) (display x) (newline))
+
+(test-group "comparators"
+
+ (define (vector-cdr vec)
+ (let* ((len (vector-length vec))
+ (result (make-vector (- len 1))))
+ (let loop ((n 1))
+ (cond
+ ((= n len) result)
+ (else (vector-set! result (- n 1) (vector-ref vec n))
+ (loop (+ n 1)))))))
+
+ (test '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+ (test '#() (vector-cdr '#(1)))
+
+ (print "default-comparator")
+ (define default-comparator (make-default-comparator))
+ (print "real-comparator")
+ (define real-comparator (make-comparator real? = < number-hash))
+ (print "degenerate comparator")
+ (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+ (print "boolean comparator")
+ (define boolean-comparator
+ (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+ (print "bool-pair-comparator")
+ (define bool-pair-comparator (make-pair-comparator boolean-comparator boolean-comparator))
+ (print "num-list-comparator")
+ (define num-list-comparator
+ (make-list-comparator real-comparator list? null? car cdr))
+ (print "num-vector-comparator")
+ (define num-vector-comparator
+ (make-vector-comparator real-comparator vector? vector-length vector-ref))
+ (print "vector-qua-list comparator")
+ (define vector-qua-list-comparator
+ (make-list-comparator
+ real-comparator
+ vector?
+ (lambda (vec) (= 0 (vector-length vec)))
+ (lambda (vec) (vector-ref vec 0))
+ vector-cdr))
+ (print "list-qua-vector-comparator")
+ (define list-qua-vector-comparator
+ (make-vector-comparator default-comparator list? length list-ref))
+ (print "eq-comparator")
+ (define eq-comparator (make-eq-comparator))
+ (print "eqv-comparator")
+ (define eqv-comparator (make-eqv-comparator))
+ (print "equal-comparator")
+ (define equal-comparator (make-equal-comparator))
+ (print "symbol-comparator")
+ (define symbol-comparator
+ (make-comparator
+ symbol?
+ eq?
+ (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+ symbol-hash))
+
+ (test-group "comparators/predicates"
+ (test-assert (comparator? real-comparator))
+ (test-assert (not (comparator? =)))
+ (test-assert (comparator-ordered? real-comparator))
+ (test-assert (comparator-hashable? real-comparator))
+ (test-assert (not (comparator-ordered? degenerate-comparator)))
+ (test-assert (not (comparator-hashable? degenerate-comparator)))
+ ) ; end comparators/predicates
+
+ (test-group "comparators/constructors"
+ (test-assert (=? boolean-comparator #t #t))
+ (test-assert (not (=? boolean-comparator #t #f)))
+ (test-assert (<? boolean-comparator #f #t))
+ (test-assert (not (<? boolean-comparator #t #t)))
+ (test-assert (not (<? boolean-comparator #t #f)))
+
+ (test-assert (comparator-test-type bool-pair-comparator '(#t . #f)))
+ (test-assert (not (comparator-test-type bool-pair-comparator 32)))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+ (test-assert (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+ (test-assert (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+ (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+ (test-assert (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+ (test-assert (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+ (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+ (test-assert (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+ (test-assert (comparator-test-type num-vector-comparator '#(1 2 3)))
+ (test-assert (comparator-test-type num-vector-comparator '#()))
+ (test-assert (not (comparator-test-type num-vector-comparator 1)))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+ (test-assert (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+ (test-assert (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+ (test-assert (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+ (test-assert (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+ (test-assert (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+ (test-assert (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+ (test-assert (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+ (test-assert (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+ (test-assert (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+ (define bool-pair (cons #t #f))
+ (define bool-pair-2 (cons #t #f))
+ (define reverse-bool-pair (cons #f #t))
+ (test-assert (=? eq-comparator #t #t))
+ (test-assert (not (=? eq-comparator #f #t)))
+ (test-assert (=? eqv-comparator bool-pair bool-pair))
+ (test-assert (not (=? eqv-comparator bool-pair bool-pair-2)))
+ (test-assert (=? equal-comparator bool-pair bool-pair-2))
+ (test-assert (not (=? equal-comparator bool-pair reverse-bool-pair)))
+ ) ; end comparators/constructors
+
+ (test-group "comparators/hash"
+ (test-assert (exact-integer? (boolean-hash #f)))
+ (test-assert (not (negative? (boolean-hash #t))))
+ (test-assert (exact-integer? (char-hash #\a)))
+ (test-assert (not (negative? (char-hash #\b))))
+ (test-assert (exact-integer? (char-ci-hash #\a)))
+ (test-assert (not (negative? (char-ci-hash #\b))))
+ (test-assert (= (char-ci-hash #\a) (char-ci-hash #\A)))
+ (test-assert (exact-integer? (string-hash "f")))
+ (test-assert (not (negative? (string-hash "g"))))
+ (test-assert (exact-integer? (string-ci-hash "f")))
+ (test-assert (not (negative? (string-ci-hash "g"))))
+ (test-assert (= (string-ci-hash "f") (string-ci-hash "F")))
+ (test-assert (exact-integer? (symbol-hash 'f)))
+ (test-assert (not (negative? (symbol-hash 't))))
+ (test-assert (exact-integer? (number-hash 3)))
+ (test-assert (not (negative? (number-hash 3))))
+ (test-assert (exact-integer? (number-hash -3)))
+ (test-assert (not (negative? (number-hash -3))))
+ (test-assert (exact-integer? (number-hash 3.0)))
+ (test-assert (not (negative? (number-hash 3.0))))
+
+ ) ; end comparators/hash
+
+ (test-group "comparators/default"
+ (test-assert (<? default-comparator '() '(a)))
+ (test-assert (not (=? default-comparator '() '(a))))
+ (test-assert (=? default-comparator #t #t))
+ (test-assert (not (=? default-comparator #t #f)))
+ (test-assert (<? default-comparator #f #t))
+ (test-assert (not (<? default-comparator #t #t)))
+ (test-assert (=? default-comparator #\a #\a))
+ (test-assert (<? default-comparator #\a #\b))
+
+ (test-assert (comparator-test-type default-comparator '()))
+ (test-assert (comparator-test-type default-comparator #t))
+ (test-assert (comparator-test-type default-comparator #\t))
+ (test-assert (comparator-test-type default-comparator '(a)))
+ (test-assert (comparator-test-type default-comparator 'a))
+ (test-assert (comparator-test-type default-comparator (make-bytevector 10)))
+ (test-assert (comparator-test-type default-comparator 10))
+ (test-assert (comparator-test-type default-comparator 10.0))
+ (test-assert (comparator-test-type default-comparator "10.0"))
+ (test-assert (comparator-test-type default-comparator '#(10)))
+
+ (test-assert (=? default-comparator '(#t . #t) '(#t . #t)))
+ (test-assert (not (=? default-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (=? default-comparator '(#t . #t) '(#t . #f))))
+ (test-assert (<? default-comparator '(#f . #t) '(#t . #t)))
+ (test-assert (<? default-comparator '(#t . #f) '(#t . #t)))
+ (test-assert (not (<? default-comparator '(#t . #t) '(#t . #t))))
+ (test-assert (not (<? default-comparator '(#t . #t) '(#f . #t))))
+ (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (test-assert (=? default-comparator '#(#t #t) '#(#t #t)))
+ (test-assert (not (=? default-comparator '#(#t #t) '#(#f #t))))
+ (test-assert (not (=? default-comparator '#(#t #t) '#(#t #f))))
+ (test-assert (<? default-comparator '#(#f #t) '#(#t #t)))
+ (test-assert (<? default-comparator '#(#t #f) '#(#t #t)))
+ (test-assert (not (<? default-comparator '#(#t #t) '#(#t #t))))
+ (test-assert (not (<? default-comparator '#(#t #t) '#(#f #t))))
+ (test-assert (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (test-assert (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+ (test-assert (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+ (test-assert (= (comparator-hash default-comparator "t") (string-hash "t")))
+ (test-assert (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+ (test-assert (= (comparator-hash default-comparator 10) (number-hash 10)))
+ (test-assert (= (comparator-hash default-comparator 10.0) (number-hash 10.0)))
+
+ (comparator-register-default!
+ (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 200)))
+ (test-assert (=? default-comparator (lambda () #t) (lambda () #f)))
+ (test-assert (not (<? default-comparator (lambda () #t) (lambda () #f))))
+ (test 200 (comparator-hash default-comparator (lambda () #t)))
+
+ ) ; end comparators/default
+
+ ;; SRFI 128 does not actually require a comparator's four procedures
+ ;; to be eq? to the procedures originally passed to make-comparator.
+ ;; For interoperability/interchangeability between the comparators
+ ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+ ;; make-comparator may need to be wrapped inside another lambda
+ ;; expression before they're returned by the corresponding accessor.
+ ;;
+ ;; So this next group of tests is incorrect, hence commented out
+ ;; and replaced by a slightly less naive group of tests.
+
+#;
+ (test-group "comparators/accessors"
+ (define ttp (lambda (x) #t))
+ (define eqp (lambda (x y) #t))
+ (define orp (lambda (x y) #t))
+ (define hf (lambda (x) 0))
+ (define comp (make-comparator ttp eqp orp hf))
+ (test ttp (comparator-type-test-predicate comp))
+ (test eqp (comparator-equality-predicate comp))
+ (test orp (comparator-ordering-predicate comp))
+ (test hf (comparator-hash-function comp))
+ ) ; end comparators/accessors
+
+ (test-group "comparators/accessors"
+ (define x1 0)
+ (define x2 0)
+ (define x3 0)
+ (define x4 0)
+ (define ttp (lambda (x) (set! x1 111) #t))
+ (define eqp (lambda (x y) (set! x2 222) #t))
+ (define orp (lambda (x y) (set! x3 333) #t))
+ (define hf (lambda (x) (set! x4 444) 0))
+ (define comp (make-comparator ttp eqp orp hf))
+ (test #t (and ((comparator-type-test-predicate comp) x1) (= x1 111)))
+ (test #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+ (test #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+ (test #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444)))
+ ) ; end comparators/accessors
+
+ (test-group "comparators/invokers"
+ (test-assert (comparator-test-type real-comparator 3))
+ (test-assert (comparator-test-type real-comparator 3.0))
+ (test-assert (not (comparator-test-type real-comparator "3.0")))
+ (test-assert (comparator-check-type boolean-comparator #t))
+ (test-error (comparator-check-type boolean-comparator 't))
+ ) ; end comparators/invokers
+
+ (test-group "comparators/comparison"
+ (test-assert (=? real-comparator 2 2.0 2))
+ (test-assert (<? real-comparator 2 3.0 4))
+ (test-assert (>? real-comparator 4.0 3.0 2))
+ (test-assert (<=? real-comparator 2.0 2 3.0))
+ (test-assert (>=? real-comparator 3 3.0 2))
+ (test-assert (not (=? real-comparator 1 2 3)))
+ (test-assert (not (<? real-comparator 3 1 2)))
+ (test-assert (not (>? real-comparator 1 2 3)))
+ (test-assert (not (<=? real-comparator 4 3 3)))
+ (test-assert (not (>=? real-comparator 3 4 4.0)))
+
+ ) ; end comparators/comparison
+
+ (test-group "comparators/syntax"
+ (test 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+ (test 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+ (test 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater))
+ (test 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+ (test 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+ (test 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+ ) ; end comparators/syntax
+
+ (test-group "comparators/bound-salt"
+ (test-assert (exact-integer? (hash-bound)))
+ (test-assert (exact-integer? (hash-salt)))
+ (test-assert (< (hash-salt) (hash-bound)))
+ ) ; end comparators/bound-salt
+
+) ; end comparators
+
+(test-exit)
diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test
new file mode 100644
index 000000000..a6a447767
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,47 @@
+;;;; srfi-128.test --- Test suite for SRFI-128. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-128)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-128))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-128-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 10/16] module: Add (scheme comparator).
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (8 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 09/16] module: Add SRFI 128 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 11/16] module: Add (scheme sort) Maxim Cournoyer
` (5 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/scheme/comparator.sld: New R7RS library shim for SRFI 128.
* am/bootstrap.am (SOURCES): Register it.
* NEWS: Update NEWS.
---
(no changes since v5)
Changes in v5:
- Update NEWS
NEWS | 1 +
am/bootstrap.am | 1 +
module/scheme/comparator.sld | 33 +++++++++++++++++++++++++++++++++
3 files changed, 35 insertions(+)
create mode 100644 module/scheme/comparator.sld
diff --git a/NEWS b/NEWS
index 31107a76d..45023d9fb 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 126), a hash tables library
** Add (srfi 128), a comparators library
+** Add (scheme comparator)
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 4404113ab..614d56d0d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -277,6 +277,7 @@ SOURCES = \
scheme/base.scm \
scheme/case-lambda.scm \
scheme/char.scm \
+ scheme/comparator.sld \
scheme/complex.scm \
scheme/cxr.scm \
scheme/eval.scm \
diff --git a/module/scheme/comparator.sld b/module/scheme/comparator.sld
new file mode 100644
index 000000000..5016e4392
--- /dev/null
+++ b/module/scheme/comparator.sld
@@ -0,0 +1,33 @@
+;;; comparator.sld --- R7RS library exposing SRFI 128.
+
+;;; 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-library (scheme comparator)
+ (export comparator? comparator-ordered? comparator-hashable?
+ make-comparator
+ make-pair-comparator make-list-comparator make-vector-comparator
+ make-eq-comparator make-eqv-comparator make-equal-comparator
+ boolean-hash char-hash char-ci-hash
+ string-hash string-ci-hash symbol-hash number-hash
+ make-default-comparator default-hash comparator-register-default!
+ comparator-type-test-predicate comparator-equality-predicate
+ comparator-ordering-predicate comparator-hash-function
+ comparator-test-type comparator-check-type comparator-hash
+ hash-bound hash-salt
+ =? <? >? <=? >=?
+ comparator-if<=>)
+ (import (srfi 128)))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 11/16] module: Add (scheme sort).
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (9 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 10/16] module: Add (scheme comparator) Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 12/16] module: Add SRFI 125 Maxim Cournoyer
` (4 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/scheme/sort.sld: New R7RS library shim for (rnrs sorting).
* am/bootstrap.am (SOURCES): Register it.
* NEWS: Update NEWS.
---
(no changes since v5)
Changes in v5:
- Update NEWS
NEWS | 1 +
am/bootstrap.am | 1 +
module/scheme/sort.sld | 21 +++++++++++++++++++++
3 files changed, 23 insertions(+)
create mode 100644 module/scheme/sort.sld
diff --git a/NEWS b/NEWS
index 45023d9fb..614a2bc7f 100644
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 126), a hash tables library
** Add (srfi 128), a comparators library
** Add (scheme comparator)
+** Add (scheme sort)
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 614d56d0d..e0517f69d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -289,6 +289,7 @@ SOURCES = \
scheme/r5rs.scm \
scheme/read.scm \
scheme/repl.scm \
+ scheme/sort.sld \
scheme/time.scm \
scheme/write.scm \
\
diff --git a/module/scheme/sort.sld b/module/scheme/sort.sld
new file mode 100644
index 000000000..d8b560d1f
--- /dev/null
+++ b/module/scheme/sort.sld
@@ -0,0 +1,21 @@
+;;; sorting.sld --- R7RS library exposing (rnrs sorting).
+
+;;; 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-library (scheme sort)
+ (export list-sort vector-sort vector-sort!)
+ (import (rnrs sorting)))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 12/16] module: Add SRFI 125.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (10 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 11/16] module: Add (scheme sort) Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 13/16] module: Add SRFI 151 Maxim Cournoyer
` (3 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-125.scm
* module/srfi/srfi-125/hash-table.scm
* test-suite/tests/srfi-125-test.scm
* test-suite/tests/srfi-125.test: New files.
* am/bootstrap.am (SOURCES): Register srfi-125.scm.
(NOCOMP_SOURCES): Register hash-table.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test.
(EXTRA_DIST): Register srfi-128-test.scm.
* doc/ref/srfi-modules.texi (SRFI-125): Document it.
* NEWS: Update news.
---
(no changes since v5)
Changes in v5:
- Update NEWS
Changes in v4:
- Mention Expat license of SRFI 125 in guile.tex copying section
- Rename srfi-125.scm to srfi-125.sld and use upstream copy
- Streamline import of (srfi srfi-125)
- Use R7RS 'import' for srfi-125-test.scm
Changes in v3:
- Add menu entries.
- Rename SRFI-125 to SRFI 125 in text
- Rename included file to upstream name (125.body.scm)
- Add copyright/license header 125.body.scm
NEWS | 1 +
am/bootstrap.am | 2 +
doc/ref/guile.texi | 2 +-
doc/ref/srfi-modules.texi | 603 +++++++++++++++++++
module/srfi/srfi-125.sld | 96 ++++
module/srfi/srfi-125/125.body.scm | 589 +++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-125-test.scm | 890 +++++++++++++++++++++++++++++
test-suite/tests/srfi-125.test | 45 ++
9 files changed, 2229 insertions(+), 1 deletion(-)
create mode 100644 module/srfi/srfi-125.sld
create mode 100644 module/srfi/srfi-125/125.body.scm
create mode 100644 test-suite/tests/srfi-125-test.scm
create mode 100644 test-suite/tests/srfi-125.test
diff --git a/NEWS b/NEWS
index 614a2bc7f..b7099673d 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 128), a comparators library
** Add (scheme comparator)
** Add (scheme sort)
+** Add (srfi 125), a mutators library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index e0517f69d..048379ca9 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -351,6 +351,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-125.sld \
srfi/srfi-126.scm \
srfi/srfi-128.sld \
srfi/srfi-171.scm \
@@ -444,6 +445,7 @@ NOCOMP_SOURCES = \
srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
+ srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
srfi/srfi-128/128.body2.scm \
system/base/lalr.upstream.scm \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f71d9a22c..e10916948 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 126 and 128 SRFI modules is
+Additionally, the documentation of the 125, 126, and 128 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 40ca7a2e7..3c276dfb0 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -66,6 +66,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
+* SRFI 125:: Mutators.
* SRFI 126:: R6RS-based hash tables.
* SRFI 128:: Comparators.
* SRFI-171:: Transducers.
@@ -5666,6 +5667,608 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI 125
+@subsection SRFI 125 Intermediate hash tables
+@cindex SRFI 125
+@cindex hash tables
+
+This SRFI defines an interface to hash tables, which are widely
+recognized as a fundamental data structure for a wide variety of
+applications. A hash table is a data structure that:
+
+@itemize
+@item
+Is disjoint from all other types.
+
+@item
+Provides a mapping from objects known as keys to corresponding objects
+known as values.
+@itemize
+@item
+Keys may be any Scheme objects in some kinds of hash tables, but are
+restricted in other kinds.
+@item
+Values may be any Scheme objects.
+@end itemize
+
+@item
+Has no intrinsic order for the key-value associations it contains.
+
+@item
+Provides an equality predicate which defines when a proposed key is the
+same as an existing key. No table may contain more than one value for a
+given key.
+
+@item
+Provides a hash function which maps a candidate key into a non-negative
+exact integer.
+
+@item
+Supports mutation as the primary means of setting the contents of a
+table.
+
+@item
+Provides key lookup and destructive update in (expected) amortized
+constant time, provided a satisfactory hash function is available.
+
+@item
+Does not guarantee that whole-table operations work in the presence of
+concurrent mutation of the whole hash table (values may be safely
+mutated).
+@end itemize
+
+@menu
+* SRFI 125 Rationale::
+* SRFI 125 Constructors::
+* SRFI 125 Predicates::
+* SRFI 125 Accessors::
+* SRFI 125 Mutators::
+* SRFI 125 The whole hash table::
+* SRFI 125 Mapping and folding::
+* SRFI 125 Copying and conversion::
+* SRFI 125 Hash tables as sets::
+* SRFI 125 Hash functions and reflectivity::
+@end menu
+
+@node SRFI 125 Rationale
+@subsubsection SRFI 125 Rationale
+
+Hash tables themselves don't really need defending: almost all
+dynamically typed languages, from awk to JavaScript to Lua to Perl to
+Python to Common Lisp, and including many Scheme implementations,
+provide them in some form as a fundamental data structure. Therefore,
+what needs to be defended is not the data structure but the procedures.
+This SRFI is at an intermediate level. It supports a great many
+convenience procedures on top of the basic hash table interfaces
+provided by SRFI 69 and R6RS. Nothing in it adds power to what those
+interfaces provide, but it does add convenience in the form of
+pre-debugged routines to do various common things, and even some things
+not so commonly done but useful.
+
+There is no mandated support for thread safety, immutability, or
+weakness, though there are portable hooks for specifying these features.
+
+While the specification of this SRFI accepts separate equality
+predicates and hash functions for backward compatibility, it strongly
+encourages the use of SRFI 128 comparators, which package a type test,
+an equality predicate, and a hash function into a single bundle.
+
+@subheading SRFI 69 compatibility
+
+This SRFI is downward compatible with SRFI 69. Some procedures have
+been given new preferred names for compatibility with other SRFIs, but
+in all cases the SRFI 69 names have been retained as deprecated
+synonyms; in Guile, these deprecated procedures have their name prefixed
+with @code{deprecated:}.
+
+There is one absolute incompatibility with SRFI 69: the reflective
+procedure @code{hash-table-hash-function} may return @code{#f}, which is
+not permitted by SRFI 69.
+
+@subheading R6RS compatibility
+
+The relatively few hash table procedures in R6RS are all available in
+this SRFI under somewhat different names. The only substantive
+difference is that R6RS @code{hashtable-values} and
+@code{hashtable-entries} return vectors, whereas in this SRFI
+@code{hash-table-value} and @code{hash-table-entries} return lists.
+This SRFI adopts SRFI 69's term hash-table rather than R6RS's hashtable,
+because of the universal use of ``hash table'' rather than ``hashtable''
+in other computer languages and in technical prose generally. Besides,
+the English word hashtable obviously means something that can be@dots{}
+hashted.
+
+In addition, the @code{hashtable-ref} and @code{hashtable-update!} of
+R6RS correspond to the @code{hash-table-ref/default} and
+@code{hash-table-update!/default} of both SRFI 69 and this SRFI.
+
+@subheading Common Lisp compatibility
+
+As usual, the Common Lisp names are completely different from the Scheme
+names. Common Lisp provides the following capabilities that are
+@emph{not} in this SRFI:
+
+@itemize
+@item
+The constructor allows specifying the rehash size and rehash threshold
+of the new hash table. There are also accessors and mutators for these
+and for the current capacity (as opposed to size).
+
+@item
+There are hash tables based on @code{equalp} (which does not exist in
+Scheme).
+
+@item
+@code{with-hash-table-iterator} is a hash table external iterator
+implemented as a local macro.
+
+@item
+@code{sxhash} is an implementation-specific hash function for the equal
+predicate. It has the property that objects in different instantiations
+of the same Lisp implementation that are similar, a concept analogous to
+e@code{qual} but defined across all instantiations, always return the
+same value from @code{sxhash}; for example, the symbol @code{xyz} will
+have the same @code{sxhash} result in all instantiations.
+@end itemize
+
+@subheading Sources
+
+The procedures in this SRFI are drawn primarily from SRFI 69 and
+R6RS. In addition, the following sources are acknowledged:
+
+@itemize
+@item
+The @code{hash-table-mutable?} procedure and the second argument of
+@code{hash-table-copy} (which allows the creation of immutable hash
+tables) are from R6RS, renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-intern!} procedure is from
+@url{https://docs.racket-lang.org/reference/hashtables.html, Racket},
+renamed in the style of this SRFI.
+
+@item
+The @code{hash-table-find} procedure is a modified version of
+@code{table-search} in Gambit.
+
+@item
+The procedures @code{hash-table-unfold} and @code{hash-table-count} were
+suggested by SRFI-1.
+
+@item
+The procedures @code{hash-table=?} and @code{hash-table-map} were
+suggested by Haskell's @code{Data.Map.Strict} module.
+
+@item
+The procedure @code{hash-table-map->list} is from Guile.
+@end itemize
+
+The procedures @code{hash-table-empty?,} @code{hash-table-empty-copy,
+hash-table-pop!,} @code{hash-table-map!,}
+@code{hash-table-intersection!, hash-table-difference!,} and
+@code{hash-table-xor!} were added for convenience and completeness.
+
+The native hash tables of MIT, SISC, Bigloo, Scheme48, SLIB, RScheme,
+Scheme 7, Scheme 9, Rep, and FemtoLisp were also investigated, but no
+additional procedures were incorporated.
+
+@subheading Pronunciation
+
+The slash in the names of some procedures can be pronounced ``with''.
+
+@node SRFI 125 Constructors
+@subsubsection SRFI 125 Constructors
+
+@deffn {Scheme Procedure} make-hash-table comparator [ arg @dots{} ]
+@deffnx {Scheme Procedure} make-hash-table equality-predicate [ hash-function ] [ arg @dots{} ])
+
+Return a newly allocated hash table whose equality predicate and hash
+function are extracted from comparator. Alternatively, for backward
+compatibility with SRFI 69 the equality predicate and hash function can
+be passed as separate arguments; this usage is deprecated.
+
+These procedures relate to R6RS @code{make-eq-hashtable},
+@code{make-eqv-hashtable} and @code{make-hashtable} ones, and
+@code{make-hash-table} from Common Lisp.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table comparator [ key value ] @dots{}
+
+Return a newly allocated hash table, created as if by
+@code{make-hash-table} using @var{comparator}. For each pair of
+arguments, an association is added to the new hash table with @var{key}
+as its key and @var{value} as its value. This procedure returns an
+immutable hash table. If the same key (in the sense of the equality
+predicate) is specified more than once, it is an error.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-unfold stop? mapper successor seed comparator arg @dots{}
+
+Create a new hash table as if by @var{make-hash-table} using
+@var{comparator} and the @var{args}. If the result of applying the
+predicate @code{stop?} to @var{seed} is true, return the hash table.
+Otherwise, apply the procedure @var{mapper} to @var{seed}. @var{mapper}
+returns two values, which are inserted into the hash table as the key
+and the value respectively. Then get a new seed by applying the
+procedure @var{successor} to @var{seed}, and repeat this algorithm.
+@end deffn
+
+@deffn {Scheme Procedure} alist->hash-table alist comparator arg @dots{}
+@deffnx {Scheme Procedure} alist->hash-table alist equality-predicate [ hash-function ] arg @dots{}
+
+Return a newly allocated hash table as if by @code{make-hash-table}
+using @var{comparator} and the @var{args}. It is then initialized from
+the associations of @var{alist}. Associations earlier in the list take
+precedence over those that come later. The second form is for
+compatibility with SRFI 69, and is deprecated.
+@end deffn
+
+@node SRFI 125 Predicates
+@subsubsection SRFI 125 Predicates
+
+@deffn {Scheme Procedure} hash-table? obj
+
+Return @code{#t} if @var{obj} is a hash table, and @code{#f} otherwise.
+(R6RS @code{hashtable?}; Common Lisp @code{hash-table-p})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-contains? hash-table key
+@deffnx {Scheme Procedure} hash-table-exists? hash-table key
+
+Return @code{#t} if there is any association to key in @var{hash-table},
+and @code{#f} otherwise. Execute in amortized constant time. The
+@code{hash-table-exists?} procedure is the same as
+@code{hash-table-contains?}; it is provided for backward compatibility
+with SRFI 69, and is deprecated. (R6RS @code{hashtable-contains?})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty? hash-table
+
+Return @code{#t} if @var{hash-table} contains no associations, and
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table=? value-comparator hash-table@sub{1} hash-table@sub{2}
+
+Return @code{#t} if @var{hash-table@sub{1}} and @var{hash-table@sub{2}}
+have the same keys (in the sense of their common equality predicate) and
+each key has the same value (in the sense of @var{value-comparator)},
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-mutable? hash-table
+
+Return @code{#t} if @var{hash-table} is mutable. (R6RS
+@code{hashtable-mutable?})
+@end deffn
+
+@node SRFI 125 Accessors
+@subsubsection SRFI 125 Accessors
+
+The following procedures, given a key, return the corresponding value.
+
+@deffn {Scheme Procedure} hash-table-ref hash-table key [ failure [ success ] ]
+
+Extract the value associated to key in @var{hash-table}, invoke the
+procedure success on it, and return its result; if @var{success} is not
+provided, then the value itself is returned. If @var{key} is not
+contained in @var{hash-table} and @var{failure} is supplied, then
+@var{failure} is called with no arguments and its result is returned.
+Otherwise, it is an error. Execute in expected amortized constant time,
+not counting the time to call the procedures. SRFI 69 does not support
+the @var{success} procedure.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-ref/default hash-table key default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-ref @var{hash-table} @var{key} (lambda () @var{default}))
+@end lisp
+
+(R6RS @code{hashtable-ref}; Common Lisp @code{gethash})
+@end deffn
+
+@node SRFI 125 Mutators
+@subsubsection SRFI 125 Mutators
+
+The following procedures alter the associations in a hash table either
+unconditionally, or conditionally on the presence or absence of a
+specified key. It is an error to add an association to a hash table
+whose key does not satisfy the type test predicate of the comparator
+used to create the hash table.
+
+@deffn {Scheme Procedure} hash-table-set! hash-table arg @dots{}
+
+Repeatedly mutates @code{hash-table}, creating new associations in it by
+processing the arguments from left to right. The @var{args} alternate
+between keys and values. Whenever there is a previous association for a
+key, it is deleted. It is an error if the type check procedure of the
+comparator of @var{hash-table}, when invoked on a key, does not return
+@code{#t}. Likewise, it is an error if a key is not a valid argument to
+the equality predicate of @var{hash-table}. Return an unspecified
+value. Execute in expected amortized constant time per key.
+SRFI 69, R6RS @code{hashtable-set!} and Common Lisp (@samp{setf
+gethash}) do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-delete! hash-table key @dots{}
+
+Delete any association to each key in @var{hash-table} and returns the
+number of keys that had associations. Execute in expected amortized
+constant time per key. SRFI 69, R6RS @code{hashtable-delete!}, and
+Common Lisp @var{remhash} do not handle multiple associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intern! hash-table key failure
+
+Effectively invoke @code{hash-table-ref} with the given arguments and
+return what it returns. If @var{key} was not found in @var{hash-table},
+its value is set to the result of calling @var{failure}. Execute in
+expected amortized constant time.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update! hash-table key updater [ failure [ success ] ]
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref @var{hash-table} @var{key} @var{failure} @var{success})))
+@end lisp
+
+Execute in expected amortized constant time. Return an unspecified
+value. (SRFI 69 and R6RS @code{hashtable-update!} do not support
+the @var{success} procedure)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update!/default hash-table key updater default
+
+Semantically equivalent to, but may be more efficient than, the
+following code:
+
+@lisp
+(hash-table-set! @var{hash-table} @var{key}
+ (@var{updater} (hash-table-ref/default @var{hash-table} @var{key} @var{default})))
+@end lisp
+
+Execute in expected amortized constant time. Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-pop! hash-table
+
+Choose an arbitrary association from @var{hash-table} and removes it,
+returning the key and value as two values. It is an error if
+@var{hash-table} is empty.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-clear! hash-table
+Delete all the associations from @var{hash-table}. (R6RS
+@code{hashtable-clear!}; Common Lisp @code{clrhash}.)
+@end deffn
+
+@node SRFI 125 The whole hash table
+@subsubsection SRFI 125 The whole hash table
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-size hash-table
+
+Return the number of associations in @var{hash-table} as an exact
+integer. Execute in constant time. (R6RS @code{hashtable-size}; Common
+Lisp @code{hash-table-count}.)
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-keys hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}. R6RS
+@code{hashtable-keys} returns a vector.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-values hash-table
+
+Return a newly allocated list of all the keys in @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-entries hash-table
+
+Return two values, a newly allocated list of all the keys in
+@var{hash-table} and a newly allocated list of all the values in
+@var{hash-table} in the corresponding order. R6RS
+@code{hash-table-entries} returns vectors.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-find proc hash-table failure
+
+For each association of @var{hash-table}, invoke @var{proc} on its key
+and value. If @var{proc} returns true, then @code{hash-table-find}
+returns what @var{proc} returns. If all the calls to @var{proc} return
+@code{#f}, return the result of invoking the thunk @var{failure}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-count pred hash-table
+For each association of @var{hash-table}, invoke @var{pred} on its key
+and value. Return the number of calls to @var{pred} which returned
+true.
+@end deffn
+
+@node SRFI 125 Mapping and folding
+@subsubsection SRFI 125 Mapping and folding
+
+These procedures process the associations of the hash table in an
+unspecified order.
+
+@deffn {Scheme Procedure} hash-table-map proc comparator hash-table
+
+Return a newly allocated hash table as if by @samp{(make-hash-table
+comparator)}. Calls @var{proc} for every association in
+@var{hash-table} with the value of the association. The key of the
+association and the result of invoking @var{proc} are entered into the
+new hash table. Note that this is not the result of lifting mapping
+over the domain of hash tables, but it is considered more useful.
+
+If @var{comparator} recognizes multiple keys in the @var{hash-table} as
+equivalent, any one of such associations is taken.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-for-each proc hash-table
+@deffnx {Scheme Procedure} hash-table-walk hash-table proc
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is discarded. Return an unspecified
+value. The @code{hash-table-walk} procedure is equivalent to
+@code{hash-table-for-each} with the arguments reversed, is provided for
+backward compatibility with SRFI 69, and is deprecated. (Common
+Lisp @code{maphash})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The value returned by @var{proc} is used to update the value of the
+association. Return an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-map->list proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments: the key of the association and the value of the association.
+The values returned by the invocations of @var{proc} are accumulated
+into a list, which is returned.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-fold proc seed hash-table
+@deffnx {Scheme Procedure} hash-table-fold hash-table proc seed
+
+Call @var{proc} for every association in @var{hash-table} with three
+arguments: the key of the association, the value of the association, and
+an accumulated value @var{val}. @var{val} is the seed for the first
+invocation of @var{proc}, and for subsequent invocations of @var{proc},
+the returned value of the previous invocation. The value returned by
+@code{hash-table-fold} is the return value of the last invocation of
+@var{proc}. The order of arguments with @var{hash-table} as the first
+argument is provided for SRFI 69 compatibility, and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-prune! proc hash-table
+
+Call @var{proc} for every association in @var{hash-table} with two
+arguments, the key and the value of the association, and removes all
+associations from @var{hash-table} for which @var{proc} returns true.
+Return an unspecified value.
+@end deffn
+
+@node SRFI 125 Copying and conversion
+@subsubsection SRFI 125 Copying and conversion
+
+@deffn {Scheme Procedure} hash-table-copy hash-table [ mutable? ]
+
+Return a newly allocated hash table with the same properties and
+associations as @var{hash-table}. If the second argument is present and
+is true, the new hash table is mutable. Otherwise it is immutable.
+SRFI 69 @code{hash-table-copy} does not support a second argument.
+(R6RS @code{hashtable-copy})
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-empty-copy hash-table
+
+Return a newly allocated mutable hash table with the same properties as
+@var{hash-table}, but with no associations.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table->alist hash-table
+
+Return an alist with the same associations as @var{hash-table} in an
+unspecified order.
+@end deffn
+
+@node SRFI 125 Hash tables as sets
+@subsubsection SRFI 125 Hash tables as sets
+
+@deffn {Scheme Procedure} hash-table-union! hash-table@sub{1} hash-table@sub{2}
+@deffnx {Scheme Procedure} hash-table-merge! hash-table@sub{1} hash-table@sub{2}
+
+Add the associations of @var{hash-table@sub{2}} to
+@var{hash-table@sub{1}} and return @var{hash-table@sub{1}}. If a key
+appears in both hash tables, its value is set to the value appearing in
+@var{hash-table@sub{1}}. Return @var{hash-table@sub{1}}. The
+@code{hash-table-merge!} procedure is the same as
+@code{hash-table-union!}, is provided for compatibility with SRFI 69,
+and is deprecated.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-intersection! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations from @var{hash-table@sub{1}} whose keys don't
+also appear in @var{hash-table@sub{2}} and return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-difference! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}} and return @var{hash-table@sub{1}}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-xor! hash-table@sub{1} hash-table@sub{2}
+
+Delete the associations of @var{hash-table@sub{1}} whose keys are also
+present in @var{hash-table@sub{2}}, and then adds the associations of
+@var{hash-table@sub{2}} whose keys are not present in
+@var{hash-table@sub{1}} to @var{hash-table@sub{1}}. Return
+@var{hash-table@sub{1}}.
+@end deffn
+
+@node SRFI 125 Hash functions and reflectivity
+@subsubsection SRFI 125 Hash functions and reflectivity
+
+These functions are made part of this SRFI solely for compatibility with
+SRFI 69, and are deprecated.
+
+@quotation note
+While the SRFI 125 specifies that these deprecated procedures should be
+exported using their original names, which forces its users to rename
+these procedures to something else to avoid clashing with the SRFI 126
+and SRFI 128 variants that should be preferred instead, Guile exports
+them with the @code{deprecated:} prefix.
+@end quotation
+
+@deffn {Scheme Procedure} deprecated:hash obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:string-hash obj [ arg ]
+
+Similar to SRFI 128's @code{string-hash} procedure, except that it must
+accept (and should ignore) an optional second argument. It is
+incompatible with the procedure of the same name exported by SRFI 128
+and SRFI 126.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-by-identity obj [ arg ]
+
+The same as SRFI 128's @code{default-hash} procedure, except that it
+must accept (and should ignore) an optional second argument.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-equivalence-function hash-table
+
+Return the equivalence procedure used to create @var{hash-table}.
+@end deffn
+
+@deffn {Scheme Procedure} deprecated:hash-table-hash-function hash-table
+
+Return the hash function used to create @var{hash-table}.
+@end deffn
+
@node SRFI 126
@subsection SRFI 126 R6RS-based hash tables
@cindex SRFI 126
diff --git a/module/srfi/srfi-125.sld b/module/srfi/srfi-125.sld
new file mode 100644
index 000000000..a07cb33a5
--- /dev/null
+++ b/module/srfi/srfi-125.sld
@@ -0,0 +1,96 @@
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-library (srfi 125)
+
+ (export
+
+ make-hash-table
+ hash-table
+ hash-table-unfold
+ alist->hash-table
+
+ hash-table?
+ hash-table-contains?
+ hash-table-empty?
+ hash-table=?
+ hash-table-mutable?
+
+ hash-table-ref
+ hash-table-ref/default
+
+ hash-table-set!
+ hash-table-delete!
+ hash-table-intern!
+ hash-table-update!
+ hash-table-update!/default
+ hash-table-pop!
+ hash-table-clear!
+
+ hash-table-size
+ hash-table-keys
+ hash-table-values
+ hash-table-entries
+ hash-table-find
+ hash-table-count
+
+ hash-table-map
+ hash-table-for-each
+ hash-table-map!
+ hash-table-map->list
+ hash-table-fold
+ hash-table-prune!
+
+ hash-table-copy
+ hash-table-empty-copy
+ hash-table->alist
+
+ hash-table-union!
+ hash-table-intersection!
+ hash-table-difference!
+ hash-table-xor!
+
+ ;; The following procedures are deprecated by SRFI 125:
+
+ (rename deprecated:hash hash)
+ (rename deprecated:string-hash string-hash)
+ (rename deprecated:string-ci-hash string-ci-hash)
+ (rename deprecated:hash-by-identity hash-by-identity)
+
+ (rename deprecated:hash-table-equivalence-function
+ hash-table-equivalence-function)
+ (rename deprecated:hash-table-hash-function hash-table-hash-function)
+ (rename deprecated:hash-table-exists? hash-table-exists?)
+ (rename deprecated:hash-table-walk hash-table-walk)
+ (rename deprecated:hash-table-merge! hash-table-merge!)
+
+ )
+
+ (import (scheme base)
+ (scheme write) ; for warnings about deprecated features
+ (srfi 126)
+ (except (srfi 128)
+ hash-salt ; exported by (srfi 126)
+ string-hash ; exported by (srfi 126)
+ string-ci-hash ; exported by (srfi 126)
+ ))
+
+ (cond-expand
+ ((library (scheme char))
+ (import (scheme char)))
+ (else
+ (begin (define string-ci=? string=?))))
+
+ (include "srfi-125/125.body.scm")
+
+ ) ; eof
diff --git a/module/srfi/srfi-125/125.body.scm b/module/srfi/srfi-125/125.body.scm
new file mode 100644
index 000000000..32e9f3a06
--- /dev/null
+++ b/module/srfi/srfi-125/125.body.scm
@@ -0,0 +1,589 @@
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Private stuff, not exported.
+
+;;; Ten of the SRFI 125 procedures are deprecated, and another
+;;; two allow alternative arguments that are deprecated.
+
+(define (issue-deprecated-warnings?) #t)
+
+(define (issue-warning-deprecated name-of-deprecated-misfeature)
+ (if (not (memq name-of-deprecated-misfeature already-warned))
+ (begin
+ (set! already-warned
+ (cons name-of-deprecated-misfeature already-warned))
+ (if (issue-deprecated-warnings?)
+ (let ((out (current-error-port)))
+ (display "WARNING: " out)
+ (display name-of-deprecated-misfeature out)
+ (newline out)
+ (display " is deprecated by SRFI 125. See" out)
+ (newline out)
+ (display " " out)
+ (display url:deprecated out)
+ (newline out))))))
+
+(define url:deprecated
+ "http://srfi.schemers.org/srfi-125/srfi-125.html")
+
+; List of deprecated features for which a warning has already
+; been issued.
+
+(define already-warned '())
+
+;;; Comparators contain a type test predicate, which implementations
+;;; of the hash-table-set! procedure can use to reject invalid keys.
+;;; That's hard to do without sacrificing interoperability with R6RS
+;;; and/or SRFI 69 and/or SRFI 126 hash tables.
+;;;
+;;; Full interoperability means the hash tables implemented here are
+;;; interchangeable with the SRFI 126 hashtables used to implement them.
+;;; SRFI 69 and R6RS and SRFI 126 hashtables don't contain comparators,
+;;; so any association between a hash table and its comparator would have
+;;; to be maintained outside the representation of hash tables themselves,
+;;; which is problematic unless weak pointers are available.
+;;;
+;;; Not all of the hash tables implemented here will have comparators
+;;; associated with them anyway, because an equivalence procedure
+;;; and hash function can be used to create a hash table instead of
+;;; a comparator (although that usage is deprecated by SRFI 125).
+;;;
+;;; One way to preserve interoperability while enforcing a comparator's
+;;; type test is to incorporate that test into a hash table's hash
+;;; function. The advantage of doing that should be weighed against
+;;; these disadvantages:
+;;;
+;;; If the type test is slow, then hashing would also be slower.
+;;;
+;;; The R6RS, SRFI 69, and SRFI 126 APIs allow extraction of
+;;; a hash function from some hash tables.
+;;; Some programmers might expect that hash function to be the
+;;; hash function encapsulated by the comparator (in the sense
+;;; of eq?, perhaps) even though this API makes no such guarantee
+;;; (and extraction of that hash function from an existing hash
+;;; table can only be done by calling a deprecated procedure).
+
+;;; If %enforce-comparator-type-tests is true, then make-hash-table,
+;;; when passed a comparator, will use a hash function that enforces
+;;; the comparator's type test.
+
+(define %enforce-comparator-type-tests #t)
+
+;;; Given a comparator, return its hash function, possibly augmented
+;;; by the comparator's type test.
+
+(define (%comparator-hash-function comparator)
+ (let ((okay? (comparator-type-test-predicate comparator))
+ (hash-function (comparator-hash-function comparator)))
+ (if %enforce-comparator-type-tests
+ (lambda (x . rest)
+ (cond ((not (okay? x))
+ (error "key rejected by hash-table comparator"
+ x
+ comparator))
+ ((null? rest)
+ (hash-function x))
+ (else
+ (apply hash-function x rest))))
+ hash-function)))
+
+;;; A unique (in the sense of eq?) value that will never be found
+;;; within a hash-table.
+
+(define %not-found (list '%not-found))
+
+;;; A unique (in the sense of eq?) value that escapes only as an irritant
+;;; when a hash-table key is not found.
+
+(define %not-found-irritant (list 'not-found))
+
+;;; The error message used when a hash-table key is not found.
+
+(define %not-found-message "hash-table key not found")
+
+;;; FIXME: thread-safe, weak-keys, ephemeral-keys, weak-values,
+;;; and ephemeral-values are not supported by this portable
+;;; reference implementation.
+
+(define (%check-optional-arguments procname args)
+ (if (or (memq 'thread-safe args)
+ (memq 'weak-keys args)
+ (memq 'weak-values args)
+ (memq 'ephemeral-keys args)
+ (memq 'ephemeral-values args))
+ (error (string-append (symbol->string procname)
+ ": unsupported optional argument(s)")
+ args)))
+
+;;; This was exported by an earlier draft of SRFI 125,
+;;; and is still used by hash-table=?
+
+(define (hash-table-every proc ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals))
+ (if (null? keys)
+ #t
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (proc key val)))
+ (and x
+ (loop (cdr keys)
+ (cdr vals)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Exported procedures
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+;;; The first argument can be a comparator or an equality predicate.
+;;;
+;;; If the first argument is a comparator, any remaining arguments
+;;; are implementation-dependent, but a non-negative exact integer
+;;; should be interpreted as an initial capacity and the symbols
+;;; thread-safe, weak-keys, ephemeral-keys, weak-values, and
+;;; emphemeral-values should be interpreted specially. (These
+;;; special symbols are distinct from the analogous special symbols
+;;; in SRFI 126.)
+;;;
+;;; If the first argument is not a comparator, then it had better
+;;; be an equality predicate (which is deprecated by SRFI 125).
+;;; If a second argument is present and is a procedure, then it's
+;;; a hash function (which is allowed only for the deprecated case
+;;; in which the first argument is an equality predicate). If a
+;;; second argument is not a procedure, then it's some kind of
+;;; implementation-dependent optional argument, as are all arguments
+;;; beyond the second.
+;;;
+;;; SRFI 128 defines make-eq-comparator, make-eqv-comparator, and
+;;; make-equal-comparator procedures whose hash function is the
+;;; default-hash procedure of SRFI 128, which is inappropriate
+;;; for use with eq? and eqv? unless the object being hashed is
+;;; never mutated. Neither SRFI 125 nor 128 provide any way to
+;;; define a comparator whose hash function is truly compatible
+;;; with the use of eq? or eqv? as an equality predicate.
+;;;
+;;; That would make SRFI 125 almost as bad as SRFI 69 if not for
+;;; the following paragraph of SRFI 125:
+;;;
+;;; Implementations are permitted to ignore user-specified
+;;; hash functions in certain circumstances. Specifically,
+;;; if the equality predicate, whether passed as part of a
+;;; comparator or explicitly, is more fine-grained (in the
+;;; sense of R7RS-small section 6.1) than equal?, the
+;;; implementation is free — indeed, is encouraged — to
+;;; ignore the user-specified hash function and use something
+;;; implementation-dependent. This allows the use of addresses
+;;; as hashes, in which case the keys must be rehashed if
+;;; they are moved by the garbage collector. Such a hash
+;;; function is unsafe to use outside the context of
+;;; implementation-provided hash tables. It can of course be
+;;; exposed by an implementation as an extension, with
+;;; suitable warnings against inappropriate uses.
+;;;
+;;; That gives implementations permission to do something more
+;;; useful, but when should implementations take advantage of
+;;; that permission? This implementation uses the superior
+;;; solution provided by SRFI 126 whenever:
+;;;
+;;; A comparator is passed as first argument and its equality
+;;; predicate is eq? or eqv?.
+;;;
+;;; The eq? or eqv? procedure is passed as first argument
+;;; (which is a deprecated usage).
+
+(define (make-hash-table comparator/equiv . rest)
+ (if (comparator? comparator/equiv)
+ (let ((equiv (comparator-equality-predicate comparator/equiv))
+ (hash-function (%comparator-hash-function comparator/equiv)))
+ (%make-hash-table equiv hash-function rest))
+ (let* ((equiv comparator/equiv)
+ (hash-function (if (and (not (null? rest))
+ (procedure? (car rest)))
+ (car rest)
+ #f))
+ (rest (if hash-function (cdr rest) rest)))
+ (issue-warning-deprecated 'srfi-69-style:make-hash-table)
+ (%make-hash-table equiv hash-function rest))))
+
+(define (%make-hash-table equiv hash-function opts)
+ (%check-optional-arguments 'make-hash-table opts)
+ (cond ((equal? equiv eq?)
+ (make-eq-hashtable))
+ ((equal? equiv eqv?)
+ (make-eqv-hashtable))
+ (hash-function
+ (make-hashtable hash-function equiv))
+ ((equal? equiv equal?)
+ (make-hashtable equal-hash equiv))
+ ((equal? equiv string=?)
+ (make-hashtable string-hash equiv))
+ ((equal? equiv string-ci=?)
+ (make-hashtable string-ci-hash equiv))
+ ((equal? equiv symbol=?)
+ (make-hashtable symbol-hash equiv))
+ (else
+ (error "make-hash-table: unable to infer hash function"
+ equiv))))
+
+(define (hash-table comparator . rest)
+ (let ((ht (apply make-hash-table comparator rest)))
+ (let loop ((kvs rest))
+ (cond
+ ((null? kvs) #f)
+ ((null? (cdr kvs)) (error "hash-table: wrong number of arguments"))
+ ((hashtable-contains? ht (car kvs))
+ (error "hash-table: two equivalent keys were provided"
+ (car kvs)))
+ (else (hashtable-set! ht (car kvs) (cadr kvs))
+ (loop (cddr kvs)))))
+ (hashtable-copy ht #f)))
+
+(define (hash-table-unfold stop? mapper successor seed comparator . rest)
+ (let ((ht (apply make-hash-table comparator rest)))
+ (let loop ((seed seed))
+ (if (stop? seed)
+ ht
+ (call-with-values
+ (lambda () (mapper seed))
+ (lambda (key val)
+ (hash-table-set! ht key val)
+ (loop (successor seed))))))))
+
+(define (alist->hash-table alist comparator/equiv . rest)
+ (if (and (not (null? rest))
+ (procedure? (car rest)))
+ (issue-warning-deprecated 'srfi-69-style:alist->hash-table))
+ (let ((ht (apply make-hash-table comparator/equiv rest))
+ (entries (reverse alist)))
+ (for-each (lambda (entry)
+ (hash-table-set! ht (car entry) (cdr entry)))
+ entries)
+ ht))
+
+;;; Predicates.
+
+(define (hash-table? obj)
+ (hashtable? obj))
+
+(define (hash-table-contains? ht key)
+ (hashtable-contains? ht key))
+
+(define (hash-table-empty? ht)
+ (= 0 (hashtable-size ht)))
+
+;;; FIXME: walks both hash tables because their key comparators
+;;; might be different
+
+(define (hash-table=? value-comparator ht1 ht2)
+ (let ((val=? (comparator-equality-predicate value-comparator))
+ (n1 (hash-table-size ht1))
+ (n2 (hash-table-size ht2)))
+ (and (= n1 n2)
+ (hash-table-every (lambda (key val1)
+ (and (hashtable-contains? ht2 key)
+ (val=? val1
+ (hashtable-ref ht2 key 'ignored))))
+ ht1)
+ (hash-table-every (lambda (key val2)
+ (and (hashtable-contains? ht1 key)
+ (val=? val2
+ (hashtable-ref ht1 key 'ignored))))
+ ht2))))
+
+(define (hash-table-mutable? ht)
+ (hashtable-mutable? ht))
+
+;;; Accessors.
+
+(define (hash-table-ref ht key . rest)
+ (let ((failure (if (null? rest) #f (car rest)))
+ (success (if (or (null? rest) (null? (cdr rest))) #f (cadr rest)))
+ (val (hashtable-ref ht key %not-found)))
+ (cond ((eq? val %not-found)
+ (if (and failure (procedure? failure))
+ (failure)
+ (error %not-found-message ht key %not-found-irritant)))
+ (success
+ (success val))
+ (else
+ val))))
+
+(define (hash-table-ref/default ht key default)
+ (hashtable-ref ht key default))
+
+;;; Mutators.
+
+(define (hash-table-set! ht . rest)
+ (if (= 2 (length rest))
+ (hashtable-set! ht (car rest) (cadr rest))
+ (let loop ((kvs rest))
+ (cond ((and (not (null? kvs))
+ (not (null? (cdr kvs))))
+ (hashtable-set! ht (car kvs) (cadr kvs))
+ (loop (cddr kvs)))
+ ((not (null? kvs))
+ (error "hash-table-set!: wrong number of arguments"
+ (cons ht rest)))))))
+
+(define (hash-table-delete! ht . keys)
+ (let loop ((keys keys) (cnt 0))
+ (cond ((null? keys) cnt)
+ ((hash-table-contains? ht (car keys))
+ (hashtable-delete! ht (car keys))
+ (loop (cdr keys) (+ cnt 1)))
+ (else
+ (loop (cdr keys) cnt)))))
+
+(define (hash-table-intern! ht key failure)
+ (if (hashtable-contains? ht key)
+ (hash-table-ref ht key)
+ (let ((val (failure)))
+ (hash-table-set! ht key val)
+ val)))
+
+(define (hash-table-update! ht key updater . rest)
+ (hash-table-set! ht
+ key
+ (updater (apply hash-table-ref ht key rest))))
+
+(define (hash-table-update!/default ht key updater default)
+ (hash-table-set! ht key (updater (hashtable-ref ht key default))))
+
+(define (hash-table-pop! ht)
+ (call/cc
+ (lambda (return)
+ (hash-table-for-each
+ (lambda (key value)
+ (hash-table-delete! ht key)
+ (return key value))
+ ht)
+ (error "hash-table-pop!: hash table is empty" ht))))
+
+(define (hash-table-clear! ht)
+ (hashtable-clear! ht))
+
+;;; The whole hash table.
+
+(define (hash-table-size ht)
+ (hashtable-size ht))
+
+(define (hash-table-keys ht)
+ (vector->list (hashtable-keys ht)))
+
+(define (hash-table-values ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (vector->list vals))))
+
+(define (hash-table-entries ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (values (vector->list keys)
+ (vector->list vals)))))
+
+(define (hash-table-find proc ht failure)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals))
+ (if (null? keys)
+ (failure)
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (proc key val)))
+ (or x
+ (loop (cdr keys)
+ (cdr vals)))))))))
+
+(define (hash-table-count pred ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals)
+ (n 0))
+ (if (null? keys)
+ n
+ (let* ((key (car keys))
+ (val (car vals))
+ (x (pred key val)))
+ (loop (cdr keys)
+ (cdr vals)
+ (if x (+ n 1) n))))))))
+
+;;; Mapping and folding.
+
+(define (hash-table-map proc comparator ht)
+ (let ((result (make-hash-table comparator)))
+ (hash-table-for-each
+ (lambda (key val)
+ (hash-table-set! result key (proc val)))
+ ht)
+ result))
+
+(define (hash-table-map->list proc ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (map proc keys vals))))
+
+;;; With this particular implementation, the proc can safely mutate ht.
+;;; That property is not guaranteed by the specification, but can be
+;;; relied upon by procedures defined in this file.
+
+(define (hash-table-for-each proc ht)
+ (call-with-values
+ (lambda () (hashtable-entries ht))
+ (lambda (keys vals)
+ (vector-for-each proc keys vals))))
+
+(define (hash-table-map! proc ht)
+ (hash-table-for-each (lambda (key val)
+ (hashtable-set! ht key (proc key val)))
+ ht))
+
+(define (hash-table-fold proc init ht)
+ (if (hashtable? proc)
+ (deprecated:hash-table-fold proc init ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (let loop ((keys keys)
+ (vals vals)
+ (x init))
+ (if (null? keys)
+ x
+ (loop (cdr keys)
+ (cdr vals)
+ (proc (car keys) (car vals) x))))))))
+
+(define (hash-table-prune! proc ht)
+ (hash-table-for-each (lambda (key val)
+ (if (proc key val)
+ (hashtable-delete! ht key)))
+ ht))
+
+;;; Copying and conversion.
+
+(define (hash-table-copy ht . rest)
+ (apply hashtable-copy ht rest))
+
+(define (hash-table-empty-copy ht)
+ (let* ((ht2 (hashtable-copy ht #t))
+ (ignored (hashtable-clear! ht2)))
+ ht2))
+
+(define (hash-table->alist ht)
+ (call-with-values
+ (lambda () (hash-table-entries ht))
+ (lambda (keys vals)
+ (map cons keys vals))))
+
+;;; Hash tables as sets.
+
+(define (hash-table-union! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key2 val2)
+ (if (not (hashtable-contains? ht1 key2))
+ (hashtable-set! ht1 key2 val2)))
+ ht2)
+ ht1)
+
+(define (hash-table-intersection! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key1 val1)
+ (if (not (hashtable-contains? ht2 key1))
+ (hashtable-delete! ht1 key1)))
+ ht1)
+ ht1)
+
+(define (hash-table-difference! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key1 val1)
+ (if (hashtable-contains? ht2 key1)
+ (hashtable-delete! ht1 key1)))
+ ht1)
+ ht1)
+
+(define (hash-table-xor! ht1 ht2)
+ (hash-table-for-each
+ (lambda (key2 val2)
+ (if (hashtable-contains? ht1 key2)
+ (hashtable-delete! ht1 key2)
+ (hashtable-set! ht1 key2 val2)))
+ ht2)
+ ht1)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The following procedures are deprecated by SRFI 125, but must
+;;; be exported nonetheless.
+;;;
+;;; Programs that import the (srfi 125) library must rename the
+;;; deprecated string-hash and string-ci-hash procedures to avoid
+;;; conflict with the string-hash and string-ci-hash procedures
+;;; exported by SRFI 126 and SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (deprecated:hash obj . rest)
+ (issue-warning-deprecated 'hash)
+ (default-hash obj))
+
+(define (deprecated:string-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-hash)
+ (string-hash obj))
+
+(define (deprecated:string-ci-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-ci-hash)
+ (string-ci-hash obj))
+
+(define (deprecated:hash-by-identity obj . rest)
+ (issue-warning-deprecated 'hash-by-identity)
+ (deprecated:hash obj))
+
+(define (deprecated:hash-table-equivalence-function ht)
+ (issue-warning-deprecated 'hash-table-equivalence-function)
+ (hashtable-equivalence-function ht))
+
+(define (deprecated:hash-table-hash-function ht)
+ (issue-warning-deprecated 'hash-table-hash-function)
+ (hashtable-hash-function ht))
+
+(define (deprecated:hash-table-exists? ht key)
+ (issue-warning-deprecated 'hash-table-exists?)
+ (hash-table-contains? ht key))
+
+(define (deprecated:hash-table-walk ht proc)
+ (issue-warning-deprecated 'hash-table-walk)
+ (hash-table-for-each proc ht))
+
+(define (deprecated:hash-table-fold ht proc seed)
+ (issue-warning-deprecated 'srfi-69-style:hash-table-fold)
+ (hash-table-fold proc seed ht))
+
+(define (deprecated:hash-table-merge! ht1 ht2)
+ (issue-warning-deprecated 'hash-table-merge!)
+ (hash-table-union! ht1 ht2))
+
+; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0fb5827cc..13eb1f24f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
+ tests/srfi-125.test \
tests/srfi-126.test \
tests/srfi-128.test \
tests/srfi-171.test \
@@ -210,6 +211,7 @@ EXTRA_DIST = \
$(SCM_TESTS) \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
+ tests/srfi-125-test.scm \
tests/srfi-126-test.scm \
tests/srfi-128-test.scm \
ChangeLog-2008
diff --git a/test-suite/tests/srfi-125-test.scm b/test-suite/tests/srfi-125-test.scm
new file mode 100644
index 000000000..7816b0c20
--- /dev/null
+++ b/test-suite/tests/srfi-125-test.scm
@@ -0,0 +1,890 @@
+;;; Copyright (C) William D Clinger 2015. All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; This is a very shallow sanity test for hash tables.
+;;;
+;;; Tests marked by a "FIXME: glass-box" comment test behavior of the
+;;; reference implementation that is not required by the specification.
+
+(import (scheme base)
+ (scheme char)
+ (scheme write)
+ (only (scheme process-context) exit)
+ (scheme comparator) ; was (srfi 128)
+ (only (scheme sort) list-sort) ; was (r6rs sorting)
+ (only (srfi 126) hashtable-copy)
+ (rename (srfi 125)
+ (string-hash deprecated:string-hash)
+ (string-ci-hash deprecated:string-ci-hash)))
+
+;;; Commentary:
+
+;;; The test suite was slightly adjusted to use SRFI 64, for better
+;;; integration with the Guile test suite.
+
+;;; Code:
+
+(test-begin "srfi-125")
+
+;;; FIXME: when debugging catastrophic failures, printing every expression
+;;; before it's executed may help.
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ expr expected)
+ (test-equal expr expected))))
+
+(define-syntax test-deny
+ (syntax-rules ()
+ ((_ expr)
+ (test-assert (not expr)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from SRFI 114 to SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define default-comparator (make-default-comparator))
+
+;;; SRFI 128 says the following definition will work, but that's
+;;; an error in SRFI 128; the hash function produce non-integers.
+
+#;
+(define number-comparator
+ (make-comparator real? = < (lambda (x) (exact (abs x)))))
+
+(define number-comparator
+ (make-comparator real? = < (lambda (x) (exact (abs (round x))))))
+
+(define string-comparator
+ (make-comparator string? string=? string<? string-hash))
+
+(define string-ci-comparator
+ (make-comparator string? string-ci=? string-ci<? string-ci-hash))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Transition from earlier draft of SRFI 125 to this draft.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Returns an immutable hash table.
+
+(define (hash-table-tabulate comparator n proc)
+ (let ((ht (make-hash-table comparator)))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ (hash-table-copy ht))
+ (call-with-values
+ (lambda ()
+ (proc i))
+ (lambda (key val)
+ (hash-table-set! ht key val))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Constructors.
+
+(define ht-default (make-hash-table default-comparator))
+
+(define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
+
+(define ht-eqv (make-hash-table eqv-comparator))
+
+(define ht-eq2 (make-hash-table eq?))
+
+(define ht-eqv2 (make-hash-table eqv?))
+
+(define ht-equal (make-hash-table equal?))
+
+(define ht-string (make-hash-table string=?))
+
+(define ht-string-ci (make-hash-table string-ci=?))
+
+(define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box
+
+(define ht-fixnum (make-hash-table = abs))
+
+(define ht-default2
+ (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#()))
+
+(define ht-fixnum2
+ (hash-table-tabulate number-comparator
+ 10
+ (lambda (i) (values (* i i) i))))
+
+(define ht-string2
+ (hash-table-unfold (lambda (s) (= 0 (string-length s)))
+ (lambda (s) (values s (string-length s)))
+ (lambda (s) (substring s 0 (- (string-length s) 1)))
+ "prefixes"
+ string-comparator
+ 'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
+
+(define ht-string-ci2
+ (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
+ string-ci-comparator
+ "ignored1" 'ignored2))
+
+(define ht-symbol2
+ (alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow))
+ eq?))
+
+(define ht-equal2
+ (alist->hash-table '(((edward) . abbey)
+ ((dashiell) . hammett)
+ ((edward) . teach)
+ ((mark) . twain))
+ equal?
+ (comparator-hash-function default-comparator)))
+
+(define test-tables
+ (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z)
+ ht-eq ht-eq2 ; initially empty
+ ht-eqv ht-eqv2 ; initially empty
+ ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark)
+ ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes"
+ ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
+ ht-symbol ht-symbol2 ; initial keys: mary, noel, peter
+ ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81
+
+;;; Predicates
+
+(test (map hash-table?
+ (cons '#()
+ (cons default-comparator
+ test-tables)))
+ (append '(#f #f) (map (lambda (x) #t) test-tables)))
+
+(test (map hash-table-contains?
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t))
+
+(test (map hash-table-contains?
+ test-tables
+ '(#u8() 47.9
+ '#() '()
+ foo bar
+ 19 (henry)
+ "p" "perp"
+ "mike" "Noel"
+ jane paul
+ 0 5))
+ (map (lambda (x) #f) test-tables))
+
+(test (map hash-table-empty? test-tables)
+ '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ test-tables)
+ (map (lambda (x) #t) test-tables))
+
+(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ (do ((tables (reverse test-tables) (cddr tables))
+ (rev '() (cons (car tables) (cons (cadr tables) rev))))
+ ((null? tables)
+ rev)))
+ '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f))
+
+(test (map hash-table-mutable? test-tables)
+ '(#t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #f))
+
+;;; FIXME: glass-box
+
+(test (map hash-table-mutable? (map hash-table-copy test-tables))
+ (map (lambda (x) #f) test-tables))
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t))
+ #t)
+
+;;; Accessors.
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key)))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err))))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
+ test-tables)
+ (map (lambda (ht) 'err) test-tables))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(err "fever" err err err err err twain err 4 err 4 err stookey err 2))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key (lambda () 'eh))))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key (lambda () 'eh) list)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2)))
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (map (lambda (ht)
+ (guard (exn
+ (else 'eh))
+ (hash-table-ref/default ht 'not-a-key 'eh)))
+ test-tables)
+ (map (lambda (ht) 'eh) test-tables))
+
+(test (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref/default ht key 'eh)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2))
+
+(test (begin (hash-table-set! ht-fixnum)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '())
+
+(test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '(121 144 169))
+
+(test (begin (hash-table-set! ht-fixnum
+ 0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
+ (list-sort < (hash-table-keys ht-fixnum)))
+ '(0 1 4 9 16 25 36 49 64 81 121 144 169))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9))
+
+(test (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1))
+
+(test (begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (hash-table-intern! ht-fixnum 0 (lambda () 0))
+ (hash-table-intern! ht-fixnum 1 (lambda () 1))
+ (hash-table-intern! ht-fixnum 1 (lambda () 99))
+ (hash-table-intern! ht-fixnum 121 (lambda () 66))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1))
+
+(test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
+ (hash-table-map->list vector ht-fixnum))
+ '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13)))
+
+(test (begin (hash-table-prune! (lambda (key val)
+ (and (odd? key) (> val 10)))
+ ht-fixnum)
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum)))
+ '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13)))
+
+(test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 144 (lambda () 9999))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum)))
+ '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13)))
+
+(test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 -)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update! ht-fixnum 16 - abs)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 5)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1))
+
+(test (begin (hash-table-update!/default ht-fixnum 25 - 999)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (let* ((n0 (hash-table-size ht-fixnum))
+ (ht (hash-table-copy ht-fixnum #t)))
+ (call-with-values
+ (lambda () (hash-table-pop! ht))
+ (lambda (key val)
+ (list (= key (* val val))
+ (= (- n0 1) (hash-table-size ht))))))
+ '(#t #t))
+
+(test (begin (hash-table-delete! ht-fixnum 75)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 75 81)))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1))
+
+(let ((ht-eg (hashtable-copy (hash-table number-comparator
+ 1 1 4 2 9 3 16 4 25 5 64 8)
+ #t)))
+ (test (hash-table-delete! ht-eg)
+ 0)
+ (test (hash-table-delete! ht-eg 2 7 2000)
+ 0)
+ (test (hash-table-delete! ht-eg 1 2 4 7 64 2000)
+ 3)
+ (test-assert (= 3 (length (hash-table-keys ht-eg)))))
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1))
+
+(test (begin (hash-table-set! ht-fixnum 36 6)
+ (hash-table-set! ht-fixnum 81 9)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+ '(13 12 11 0 1 2 3 4 5 6 -1 8 9))
+
+(test (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq))
+ 0)
+
+;;; The whole hash table.
+
+(test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
+ (hash-table-size ht-eq))
+ 3)
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+ (n0 (hash-table-size ht))
+ (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
+ (n1 (hash-table-size ht)))
+ (list n0 n1 (hash-table=? default-comparator ht ht-eq)))
+ '(0 3 #t))
+
+(test (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq))
+ 0)
+
+(test (hash-table-find (lambda (key val)
+ (if (= 144 key (* val val))
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99))
+ '(144 12))
+
+(test (hash-table-find (lambda (key val)
+ (if (= 144 key val)
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99))
+ 99)
+
+(test (hash-table-count <= ht-fixnum)
+ 2)
+
+;;; Mapping and folding.
+
+(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))
+ '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))
+
+(test (let ((ht (hash-table-map (lambda (val) (* val val))
+ eqv-comparator
+ ht-fixnum)))
+ (map (lambda (i) (hash-table-ref/default ht i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+ '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1))
+
+(test (let ((keys (make-vector 15 -1))
+ (vals (make-vector 15 -1)))
+ (hash-table-for-each (lambda (key val)
+ (vector-set! keys val key)
+ (vector-set! vals val val))
+ ht-fixnum)
+ (list keys vals))
+ '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+ #(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)))
+
+(test (begin (hash-table-map! (lambda (key val)
+ (if (<= 10 key)
+ (- val)
+ val))
+ ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+ '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1))
+
+(test (hash-table-fold (lambda (key val acc)
+ (+ val acc))
+ 0
+ ht-string-ci2)
+ 13)
+
+(test (list-sort < (hash-table-fold (lambda (key val acc)
+ (cons key acc))
+ '()
+ ht-fixnum))
+ '(0 1 4 9 16 25 36 64 81 121 144 169))
+
+;;; Copying and conversion.
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum))
+ #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f))
+ #t)
+
+(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t))
+ #t)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum))
+ #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #f))
+ #f)
+
+(test (hash-table-mutable? (hash-table-copy ht-fixnum #t))
+ #t)
+
+(test (hash-table->alist ht-eq)
+ '())
+
+(test (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+;;; Hash tables as sets.
+
+(test (begin (hash-table-union! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-union! ht ht-fixnum)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13)))
+
+(test (begin (hash-table-union! ht-eqv2 ht-fixnum)
+ (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+ #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-fixnum)
+ (hash-table=? default-comparator ht-eqv2 ht-fixnum))
+ #t)
+
+(test (begin (hash-table-intersection! ht-eqv2 ht-eqv)
+ (hash-table-empty? ht-eqv2))
+ #t)
+
+(test (begin (hash-table-intersection! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9)))
+
+(test (begin (hash-table-intersection!
+ ht-fixnum
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum)))
+ '((4 . 2)
+ (25 . -5)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-difference!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-xor!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((-1 . -1)
+ (0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (100 . 10)))
+
+(test (guard (exn
+ (else 'key-not-found))
+ (hash-table-ref ht-default "this key won't be present"))
+ 'key-not-found)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Desultory tests of deprecated procedures and usages.
+;;; Deprecated usage of make-hash-table and alist->hash-table
+;;; has already been tested above.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (hash x))
+ (h2 (hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (deprecated:string-hash x))
+ (h2 (deprecated:string-hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (deprecated:string-ci-hash x))
+ (h2 (deprecated:string-ci-hash y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+ (y x)
+ (h1 (hash-by-identity x))
+ (h2 (hash-by-identity y)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (hash x 60))
+ (h2 (hash y 60)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (deprecated:string-hash x 97))
+ (h2 (deprecated:string-hash y 97)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (deprecated:string-ci-hash x 101))
+ (h2 (deprecated:string-ci-hash y 101)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20)))
+ (y x)
+ (h1 (hash-by-identity x 102))
+ (h2 (hash-by-identity y 102)))
+ (list (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2)))
+ '(#t #t #t))
+
+(test (let ((f (hash-table-equivalence-function ht-fixnum)))
+ (if (procedure? f)
+ (f 34 34)
+ #t))
+ #t)
+
+(test (let ((f (hash-table-hash-function ht-fixnum)))
+ (if (procedure? f)
+ (= (f 34) (f 34))
+ #t))
+ #t)
+
+(test (map (lambda (key) (hash-table-exists? ht-fixnum2 key))
+ '(0 1 2 3 4 5 6 7 8 9 10))
+ '(#t #t #f #f #t #f #f #f #f #t #f))
+
+(test (let ((n 0))
+ (hash-table-walk ht-fixnum2
+ (lambda (key val) (set! n (+ n key))))
+ n)
+ (apply +
+ (map (lambda (x) (* x x))
+ '(0 1 2 3 4 5 6 7 8 9))))
+
+(test (list-sort < (hash-table-fold ht-fixnum2
+ (lambda (key val acc)
+ (cons key acc))
+ '()))
+ '(0 1 4 9 16 25 36 49 64 81))
+
+(test (let ((ht (hash-table-copy ht-fixnum2 #t))
+ (ht2 (hash-table number-comparator
+ .25 .5 64 9999 81 9998 121 -11 144 -12)))
+ (hash-table-merge! ht ht2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht)))
+ '((0 . 0)
+ (.25 . .5)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12)))
+
+;;; Bugs reported on 5 January 2019 by Jéssica Milaré
+;;; ( https://srfi-email.schemers.org/srfi-125/msg/10177551 )
+
+;;; Spec says hash-table returns an immutable hash table (if that
+;;; is supported) and signal an error if there are duplicate keys,
+;;; but standard implementation returns a mutable hash table and
+;;; signals no error with duplicate keys.
+;;;
+;;; Comment by Will Clinger: the spec says specifying a duplicate
+;;; key "is an error", so hash-table is not required to signal an
+;;; error when there are duplicate keys. That part of the spec
+;;; was added on 8 May 2016, which is why it was not implemented
+;;; by the sample implementation of 2 May 2016. Because a duplicate
+;;; key "is an error" rather than "signals an error", testing for
+;;; that situation is glass-box, as is testing for immutability.
+
+;;; FIXME: glass-box
+
+(test (hash-table-mutable?
+ (hash-table number-comparator
+ .25 .5 64 9999 81 9998 121 -11 144 -12))
+ #f)
+
+;;; FIXME: glass-box (implementations not required to raise an exception here)
+
+(test (guard (exn
+ (else 'eh))
+ (hash-table number-comparator .25 .5 .25 -.5))
+ 'eh)
+
+;;; Spec says hash-table-set! must go left to right, but in
+;;; standard implementation it goes right to left.
+;;;
+;;; Comment by Will Clinger: the left-to-right requirement was
+;;; added to the spec on 8 May 2016, which is why it was not
+;;; implemented by the sample implementation of 2 May 2016.
+
+(test (let* ((ht (hash-table-empty-copy ht-eq))
+ (ignored (hash-table-set! ht 'foo 13 'bar 14 'foo 18)))
+ (hash-table-ref ht 'foo))
+ 18)
+
+;;; Spec says hash-table-empty-copy returns a mutable hash table,
+;;; but in standard implementation it returns an immutable hash
+;;; table if the given hash table is immutable.
+
+;;; FIXME: glass-box (immutable tables need not be supported)
+
+(test (hash-table-mutable?
+ (hash-table number-comparator))
+ #f)
+
+(test (hash-table-mutable?
+ (hash-table-empty-copy
+ (hash-table-copy (hash-table number-comparator) #f)))
+ #t)
+
+;;; hash-table-delete! seems to loop infinitely once it finds a key.
+;;;
+;;; Comment by Will Clinger: that bug was added by
+;;; commit e17c15203a934ab741300e59619f880f363c2b2f
+;;; on 26 September 2018. I do not understand the purpose of that
+;;; commit, as its one change appears to have had no substantive
+;;; effect apart from inserting this bug.
+
+(test (let* ((ht
+ (hash-table default-comparator 'foo 1 'bar 2 'baz 3))
+ (ht (hash-table-copy ht #t)))
+ (hash-table-delete! ht 'foo)
+ (hash-table-size ht))
+ 2)
+
+(test-end "srfi-125")
+
+; eof
diff --git a/test-suite/tests/srfi-125.test b/test-suite/tests/srfi-125.test
new file mode 100644
index 000000000..32580f0b6
--- /dev/null
+++ b/test-suite/tests/srfi-125.test
@@ -0,0 +1,45 @@
+;;;; srfi-125.test --- Test suite for SRFI-125. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(import (srfi 64))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-125-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 13/16] module: Add SRFI 151.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (11 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 12/16] module: Add SRFI 125 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 14/16] module: Add SRFI 160 Maxim Cournoyer
` (2 subsequent siblings)
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-151.scm
* module/srfi/srfi-151/bitwise-33.scm
* module/srfi/srfi-151/bitwise-60.scm
* module/srfi/srfi-151/bitwise-other.scm
* test-suite/tests/srfi-151.test
* test-suite/tests/srfi-151-test.scm: New files.
* am/bootstrap.am (SOURCES): Register srfi-151.scm.
(NOCOMP_SOURCES): Register srfi-151/bitwise-33.scm,
srfi-151/bitwise-60.scm and srfi-151/bitwise-other.scm.
* test-suite/Makefile.am (SCM_TESTS): Register srfi-151.test.
(EXTRA_DIST): Register srfi-151-test.scm.
* doc/ref/srfi-modules.texi (SRFI 151): Document it.
* NEWS: Update news.
---
(no changes since v5)
Changes in v5:
- Update NEWS
Changes in v4:
- Mention Expat license of SRFI 151 in guile.tex copying section
- Update copyright line for John Cowan in srfi-modules.texi
- Rename srfi/srfi-151.scm to srfi/srfi-151.sld
Changes in v3:
- Add SRFI 151
NEWS | 1 +
am/bootstrap.am | 4 +
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 815 ++++++++++++++++++++++++-
module/srfi/srfi-151.sld | 56 ++
module/srfi/srfi-151/bitwise-33.scm | 108 ++++
module/srfi/srfi-151/bitwise-60.scm | 70 +++
module/srfi/srfi-151/bitwise-other.scm | 62 ++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-151-test.scm | 381 ++++++++++++
test-suite/tests/srfi-151.test | 46 ++
11 files changed, 1547 insertions(+), 4 deletions(-)
create mode 100644 module/srfi/srfi-151.sld
create mode 100644 module/srfi/srfi-151/bitwise-33.scm
create mode 100644 module/srfi/srfi-151/bitwise-60.scm
create mode 100644 module/srfi/srfi-151/bitwise-other.scm
create mode 100644 test-suite/tests/srfi-151-test.scm
create mode 100644 test-suite/tests/srfi-151.test
diff --git a/NEWS b/NEWS
index b7099673d..a33e5bbb1 100644
--- a/NEWS
+++ b/NEWS
@@ -26,6 +26,7 @@ the compiler reports it as "possibly unused".
** Add (scheme comparator)
** Add (scheme sort)
** Add (srfi 125), a mutators library
+** Add (srfi 151), a bitwise operations library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 048379ca9..57c603a0a 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -354,6 +354,7 @@ SOURCES = \
srfi/srfi-125.sld \
srfi/srfi-126.scm \
srfi/srfi-128.sld \
+ srfi/srfi-151.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -448,6 +449,9 @@ NOCOMP_SOURCES = \
srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
srfi/srfi-128/128.body2.scm \
+ srfi/srfi-151/bitwise-33.scm \
+ srfi/srfi-151/bitwise-60.scm \
+ srfi/srfi-151/bitwise-other.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index e10916948..f94c10209 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,9 +24,9 @@ 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, and 128 SRFI modules is
-adapted from their specification text, which is made available under the
-following Expat license:
+Additionally, the documentation of the 125, 126, 128, and 151 SRFI
+modules is adapted from their specification text, which is made
+available under the following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 3c276dfb0..b6782f183 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 John Cowan
+@c Copyright (C) 2015-2016 John Cowan
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -69,6 +69,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 125:: Mutators.
* SRFI 126:: R6RS-based hash tables.
* SRFI 128:: Comparators.
+* SRFI 151:: Bitwise Operations.
* SRFI-171:: Transducers.
@end menu
@@ -7416,6 +7417,818 @@ returns true, @var{greater-than} is evaluated and its value returned.
If @var{comparator} is omitted, a default comparator is used.
@end deffn
+@node SRFI 151
+@subsection SRFI 151 Bitwise Operations
+@cindex SRFI 151
+
+@menu
+* SRFI 151 Abstract::
+* SRFI 151 Rationale::
+* SRFI 151 Procedure index::
+* SRFI 151 Basic operations::
+* SRFI 151 Integer operations::
+* SRFI 151 Single-bit operations::
+* SRFI 151 Bit field operations::
+* SRFI 151 Bits conversion::
+* SRFI 151 Fold/unfold and generate::
+@end menu
+
+@node SRFI 151 Abstract
+@subsubsection SRFI 151 Abstract
+
+This SRFI proposes a coherent and comprehensive set of procedures for
+performing bitwise logical operations on integers; it is accompanied by
+a reference implementation of the spec in terms of a set of seven core
+operators.
+
+The precise semantics of these operators is almost never an issue. A
+consistent, portable set of @emph{names} and @emph{parameter
+conventions}, however, is. Hence this SRFI, which is based mainly on
+@url{https://srfi.schemers.org/srfi-33/srfi-33.html, SRFI 33}, with some
+changes and additions from
+@url{http://srfi.schemers.org/srfi-33/mail-archive/msg00023.html, Olin's
+late revisions to SRFI 33} (which were never consummated).
+@url{https://srfi.schemers.org/srfi-60/srfi-60.html, SRFI 60} (based on
+SLIB) is smaller but has a few procedures of its own; some of its
+procedures have both native (often Common Lisp) and SRFI 33 names. They
+have been incorporated into this SRFI.
+@url{http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-12.html#node_sec_11.4,
+R6RS} is a subset of SRFI 60, except that all procedure names begin with
+a @code{bitwise-} prefix. A few procedures have been added from the
+general vector @url{https://srfi.schemers.org/srfi-133/srfi-133.html,
+SRFI 133}.
+
+Among the applications of bitwise operations are: hashing, Galois-field
+calculations of error-detecting and error-correcting codes, cryptography
+and ciphers, pseudo-random number generation, register-transfer-level
+modeling of digital logic designs, Fast-Fourier transforms, packing and
+unpacking numbers in persistent data structures, space-filling curves
+with applications to dimension reduction and sparse multi-dimensional
+database indexes, and generating approximate seed values for
+root-finders and transcendental function algorithms.
+
+@noindent
+This SRFI differs from SRFI 142 in only two ways:
+
+@enumerate
+@item
+The @code{bitwise-if} function has the argument ordering of
+SLIB, SRFI 60, and R6RS rather than the ordering of SRFI 33.
+
+@item
+The order in which bits are processed by the procedures listed in the
+``Bits conversion'' section has been clarified and some of the
+procedures' names have been changed. See the ``Bit processing order''
+section for details.
+@end enumerate
+
+@node SRFI 151 Rationale
+@subsubsection SRFI 151 Rationale
+
+@subheading General design principles
+
+@itemize
+@item
+These operations interpret exact integers using two's-complement
+representation.
+
+@item
+The associative bitwise ops are required to be n-ary. Programmers can
+reliably write @code{bitwise-and} with 3 arguments, for example.
+
+@item
+The word @code{or} is never used by itself, only with modifiers:
+@code{xor}, @code{ior}, @code{nor}, @code{orc1}, or @code{orc2}. This
+is the same rule as Common Lisp.
+
+@item
+Extra and redundant functions such as @code{bitwise-count},
+@code{bitwise-nor}and the bit-field ops have been included. Settling on
+a standard choice of names makes it easier to read code that uses these
+sorts of operations. It also means computations can be clearly
+expressed using the more powerful ops rather than synthesized with a
+snarled mess of @code{bitwise-and}s, @code{bitwise-or}s, and
+@code{bitwise-not}s. What we gain is having an agreed-upon set of names
+by which we can refer to these functions. If you believe in "small is
+beautiful," then what is your motivation for including anything beyond
+@code{bitwise-nand}?
+
+@item
+Programmers don't have to re-implement the redundant functions, and
+stumble over the boundary cases and error checking, but can express
+themselves using a full palette of building blocks.
+
+@item
+Compilers can directly implement many of these ops for great efficiency
+gains without requiring any tricky analysis.
+
+@item
+Logical right or left shift operations are excluded because they are not
+well defined on general integers; they are only defined on integers in
+some finite range. Remember that, in this library, integers are
+interpreted as semi-infinite bit strings that have only a finite number
+of ones or a finite number of zeros. Logical shifting operates on bit
+strings of some fixed size. If we shift left, then leftmost bits "fall
+off" the end (and zeros shift in on the right). If we shift right, then
+zeros shift into the string on the left (and rightmost bits fall off the
+end). So to define a logical shift operation, we must specify the size
+of the window.
+@end itemize
+
+@subheading Common Lisp
+
+The core of this design mirrors the structure of Common Lisp's pretty
+closely. Here are some differences:
+
+@itemize
+@item
+"load" and "deposit" are the wrong verbs (e.g., Common Lisp's @code{ldb}
+and @code{dpb} ops), since they have nothing to do with the store.
+
+@item
+@code{boole} has been removed; it is not one with the Way of Scheme.
+Boolean functions are directly encoded in Scheme as first-class
+functions.
+
+@item
+The name choices are more in tune with Scheme conventions (hyphenation,
+using @code{?} to mark a predicate, etc.) Common Lisp's name choices
+were more historically motivated, for reasons of backward compatibility
+with Maclisp and Zetalisp.
+
+@item
+The prefix @code{log} has been changed to @code{bitwise-} (e.g,
+@code{lognot} to @code{bitwise-not}), as the prefix @code{bitwise-} more
+accurately reflects what they do.
+
+@item
+The six trivial binary boolean ops that return constants, the left or
+right arguments, and the @code{bitwise-not} of the left or right
+arguments, do not appear in this SRFI.
+
+@end itemize
+
+@subheading SRFI 33
+
+This SRFI contains all the procedures of SRFI 33, and retains their
+original names with these exceptions:
+
+@itemize
+@item
+The name @code{bitwise-merge} is replaced by @code{bitwise-if}, the name
+used in SRFI 60 and R6RS.
+
+@item
+The name @code{extract-bit-field} (@code{bit-field-extract} in Olin's
+revisions) is replaced by @code{bit-field}, the name used in SRFI 60 and
+R6RS.
+
+@item
+The names @code{any-bits-set?} and @code{all-bits-set?} are replaced by
+@code{any-bit-set?} and @code{every-bit-set?}, in accordance with Olin's
+revisions.
+
+@item
+The name @code{test-bit-field?} has been renamed @code{bit-field-any?}
+and supplemented with @code{bit-field-every?}, in accordance with Olin's
+revisions.
+
+@item
+Because @code{copy-bit-field} means different things in SRFI 33 and SRFI
+60, SRFI 33's name @code{copy-bit-field} (@code{bit-field-copy} in
+Olin's revisions) has been changed to @code{bit-field-replace-same}
+@end itemize
+
+@subheading SRFI 60
+
+SRFI 60 includes six procedures that do not have SRFI 33 equivalents.
+They are incorporated into this SRFI as follows:
+
+@itemize
+@item
+The names @code{rotate-bit-field} and @code{reverse-bit-field} are
+replaced by @code{bit-field-rotate} and @code{bit-field-reverse}, by
+analogy with Olin's revisions.
+
+@item
+The procedure @code{copy-bit} is incorporated into this SRFI with the
+same name.
+
+@item
+The procedures @code{integer->list} and @code{list->integer}are
+incorporated into this SRFI with the slightly different names
+@code{integer->bits}and @code{bits->integer} because they are
+incompatible with SRFI 60.
+
+@item
+The procedure @code{booleans->integer} is a convenient way to specify a
+bitwise integer: it accepts an arbitrary number of boolean arguments and
+returns a non-negative integer. So in this SRFI it has the short name
+@code{bits}, roughly analogous to @code{list}, @code{string}, and
+@code{vector}
+@end itemize
+
+@subheading Other sources
+
+@itemize
+@item
+The following procedures are inspired by
+@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}:
+@code{bit-swap}, @code{bitwise-fold}, @code{bitwise-for-each},
+@code{bitwise-unfold}.
+
+@item
+The procedure @code{bit-field-set} is the counterpart of
+@code{bit-field-clear}.
+
+@item
+The procedures @code{bits->vector} and @code{vector->bits} are inspired
+by their list counterparts.
+
+@item
+The @code{make-bitwise-generator} procedure is a generator constructor
+similar to those provided by
+@url{https://srfi.schemers.org/srfi/srfi-127.html, SRFI 127}.
+@end itemize
+
+@subheading Argument ordering and semantics
+
+In general, these procedures place the bitstring arguments to be
+operated on first. Where the operation is not commutative, the
+"destination" argument that provides the background bits to be operated
+on is placed before the "source" argument that provides the bits to be
+transferred to it.
+
+@itemize
+@item
+In SRFI 33, @code{bitwise-nand} and @code{bitwise-nor} accepted an
+arbitrary number of arguments even though they are not commutative.
+Olin's late revisions made them dyadic, and so does this SRFI.
+
+@item
+Common Lisp bit-field operations use a @emph{byte spec} to encapsulate
+the position and size of the field. SRFI 33 bit-field operations had
+leading @emph{position} and @emph{size}arguments instead. These have
+been replaced in this SRFI by trailing @emph{start} (inclusive) and
+@emph{end} (exclusive) arguments, the convention used not only in SRFI
+60 and R6RS but also in most other subsequence operations in Scheme
+standards and SRFIs.
+
+@item
+In SRFI 60, the @code{bitwise-if} function was defined with a different
+argument ordering from SRFI 33's @code{bitwise-merge}, but was provided
+under both names, using the SLIB ordering. SRFI 142 adopted the SRFI 33
+ordering rather than the SLIB and R6RS ordering. Since SLIB and R6RS
+have seen far more usage than SRFI 33, this SRFI adopts the SRFI 60
+ordering instead.
+@end itemize
+
+@subheading Bit processing order
+
+In SLIB and SRFI 60, the the order in which bits were processed by
+@code{integer->list} and @code{list->integer} was not clearly specified.
+When SRFI 142 was written, the specification was clarified to process
+bits from least significant to most significant, so that
+@samp{(integer->list 6) => (#f #t #t)}. However, the SLIB and SRFI 60
+implementation processed them from the most significant bit to the
+least-significant bit, so that @samp{(integer->list 6) => (#t #t #f)}.
+This SRFI retains the little-endian order, but renames the procedures to
+@code{bits->list} and @code{list->bits} to avoid a silent breaking
+change from SLIB and SRFI 60. The same is true of the closely analogous
+@code{integer->vector}, @code{vector->integer}, and @code{bits}
+procedures.
+
+@node SRFI 151 Procedure index
+@subsubsection SRFI 151 Procedure index
+
+@lisp
+bitwise-not
+bitwise-and bitwise-ior
+bitwise-xor bitwise-eqv
+bitwise-nand bitwise-nor
+bitwise-andc1 bitwise-andc2
+bitwise-orc1 bitwise-orc2
+arithmetic-shift bit-count
+integer-length bitwise-if
+bit-set? copy-bit bit-swap
+any-bit-set? every-bit-set?
+first-set-bit
+bit-field bit-field-any? bit-field-every?
+bit-field-clear bit-field-set
+bit-field-replace bit-field-replace-same
+bit-field-rotate bit-field-reverse
+bits->list list->bits bits->vector vector->bits
+bits
+bitwise-fold bitwise-for-each bitwise-unfold
+make-bitwise-generator
+@end lisp
+
+In the following procedure specifications all parameters and return
+values are exact integers unless otherwise indicated (except that
+procedures with names ending in @samp{?} are predicates, as usual). It
+is an error to pass values of other types as arguments to these
+functions.
+
+Bitstrings are represented by exact integers, using a two's-complement
+encoding of the bitstring. Thus every integer represents a
+semi-infinite bitstring, having either a finite number of zeros
+(negative integers) or a finite number of ones (non-negative integers).
+The bits of a bitstring are numbered from the
+rightmost/least-significant bit: bit #0 is the rightmost or 2@sup{0}
+bit, bit #1 is the next or 2@sup{1} bit, and so forth.
+
+@node SRFI 151 Basic operations
+@subsubsection SRFI 151 Basic operations
+
+@deffn {Scheme Procedure} bitwise-not i
+
+Returns the bitwise complement of @emph{i}; that is, all 1 bits are changed
+to 0 bits and all 0 bits to 1 bits.
+
+@lisp
+ (bitwise-not 10) => -11
+ (bitwise-not -37) => 36
+@end lisp
+
+@end deffn
+
+The following ten procedures correspond to the useful set of non-trivial
+two-argument boolean functions. For each such function, the
+corresponding bitwise operator maps that function across a pair of
+bitstrings in a bit-wise fashion. The core idea of this group of
+functions is this bitwise ``lifting'' of the set of dyadic boolean
+functions to bitstring parameters.
+
+@deffn {Scheme Procedure} bitwise-and i @dots{}
+@deffnx {Scheme Procedure} bitwise-ior i @dots{}
+@deffnx {Scheme Procedure} bitwise-xor i @dots{}
+@deffnx {Scheme Procedure} bitwise-eqv i @dots{}
+
+These operations are associative. When passed no arguments, the procedures
+return the identity values -1, 0, 0, and -1 respectively.
+
+The @code{bitwise-eqv} procedure produces the complement of the
+@code{bitwise-xor} procedure. When applied to three arguments, it does
+@emph{not} produce a 1 bit everywhere that @var{a}, @var{b} and @var{c}
+all agree. That is, it does @emph{not} produce:
+
+@lisp
+ (bitwise-ior (bitwise-and a b c)
+ (bitwise-and (bitwise-not a)
+ (bitwise-not b)
+ (bitwise-not c)))
+@end lisp
+
+Rather, it produces @samp{(bitwise-eqv @var{a} (bitwise-eqv @var{b}
+@var{c}))} or the equivalent @samp{(bitwise-eqv (bitwise-eqv @var{a}
+@var{b}) @var{c})}:
+
+@lisp
+ (bitwise-ior 3 10) => 11
+ (bitwise-and 11 26) => 10
+ (bitwise-xor 3 10) => 9
+ (bitwise-eqv 37 12) => -42
+ (bitwise-and 37 12) => 4
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-nand i j
+@deffnx {Scheme Procedure} bitwise-nor i j
+@deffnx {Scheme Procedure} bitwise-andc1 i j
+@deffnx {Scheme Procedure} bitwise-andc2 i j
+@deffnx {Scheme Procedure} bitwise-orc1 i j
+@deffnx {Scheme Procedure} bitwise-orc2 i j
+
+These operations are not associative.
+
+@lisp
+ (bitwise-nand 11 26) => -11
+ (bitwise-nor 11 26) => -28
+ (bitwise-andc1 11 26) => 16
+ (bitwise-andc2 11 26) => 1
+ (bitwise-orc1 11 26) => -2
+ (bitwise-orc2 11 26) => -17
+@end lisp
+@end deffn
+
+@node SRFI 151 Integer operations
+@subsubsection SRFI 151 Integer operations
+
+@deffn {Scheme Procedure} arithmetic-shift i count
+
+Return the arithmetic left shift when @var{count}>0; right shift when
+@var{count}<0.
+
+@lisp
+ (arithmetic-shift 8 2) => 32
+ (arithmetic-shift 4 0) => 4
+ (arithmetic-shift 8 -1) => 4
+ (arithmetic-shift -100000000000000000000000000000000 -100) => -79
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-count i
+
+Return the population count of 1's (@emph{i} >= 0) or 0's (@emph{i} <
+0). The result is always non-negative.
+
+@quotation note
+The R6RS analogue @code{bitwise-bit-count} applies @code{bitwise-not} to
+the population count before returning it if @emph{i} is negative.
+@end quotation
+
+@lisp
+ (bit-count 0) => 0
+ (bit-count -1) => 0
+ (bit-count 7) => 3
+ (bit-count 13) => 3 ;Two's-complement binary: ...0001101
+ (bit-count -13) => 2 ;Two's-complement binary: ...1110011
+ (bit-count 30) => 4 ;Two's-complement binary: ...0011110
+ (bit-count -30) => 4 ;Two's-complement binary: ...1100010
+ (bit-count (expt 2 100)) => 1
+ (bit-count (- (expt 2 100))) => 100
+ (bit-count (- (1+ (expt 2 100)))) => 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} integer-length i
+
+The number of bits needed to represent @var{i}, i.e.
+
+@lisp
+ (ceiling (/ (log (if (negative? integer)
+ (- integer)
+ (+ 1 integer)))
+ (log 2)))
+@end lisp
+
+The result is always non-negative.
+
+For non-negative @var{i}, this is the number of bits needed to represent
+@var{i} in an unsigned binary representation. For all @var{i}, @samp{(+
+1 (integer-length @var{i}))} is the number of bits needed to represent
+@var{i} in a signed twos-complement representation.
+
+@lisp
+ (integer-length 0) => 0
+ (integer-length 1) => 1
+ (integer-length -1) => 0
+ (integer-length 7) => 3
+ (integer-length -7) => 3
+ (integer-length 8) => 4
+ (integer-length -8) => 3
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-if mask i j
+
+Merge the bitstrings @var{i} and @var{j}, with bitstring @var{mask}
+determining from which string to take each bit. That is, if the
+@var{k}th bit of @var{mask} is 1, then the @var{k}th bit of the result
+is the @var{k}th bit of @var{i}, otherwise the @var{k}th bit of @var{j}.
+
+@lisp
+ (bitwise-if 3 1 8) => 9
+ (bitwise-if 3 8 1) => 0
+ (bitwise-if 1 1 2) => 3
+ (bitwise-if #b00111100 #b11110000 #b00001111) => #b00110011
+@end lisp
+@end deffn
+
+@node SRFI 151 Single-bit operations
+@subsubsection SRFI 151 Single-bit operations
+
+As always, the rightmost/least-significant bit in @var{i} is bit 0.
+
+@deffn {Scheme Procedure} bit-set? index i
+
+Is bit @var{index} set in bitstring @var{i} (where @var{index} is a
+non-negative exact integer)?
+
+@quotation note
+The R6RS analogue @code{bitwise-bit-set?} accepts its arguments in the
+opposite order.
+@end quotation
+
+@lisp
+ (bit-set? 1 1) => false
+ (bit-set? 0 1) => true
+ (bit-set? 3 10) => true
+ (bit-set? 1000000 -1) => true
+ (bit-set? 2 6) => true
+ (bit-set? 0 6) => false
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} copy-bit index i boolean
+
+Return an integer the same as @var{i} except in the @var{index}th bit,
+which is 1 if @var{boolean} is @code{#t} and 0 if @var{boolean} is
+@code{#f}.
+
+@quotation note
+The R6RS analogue @code{bitwise-copy-bit} as originally documented has a
+completely different interface. @samp{(bitwise-copy-bit @var{dest}
+@var{ndex} @var{source})} replaces the @var{index}'th bit of @var{dest}
+with the @var{index}'th bit of @var{source}. It is equivalent to
+@samp{(bit-field-replace-same @var{dest} @var{source} @var{index} (+
+@var{index} 1))}.
+@end quotation
+
+@lisp
+(copy-bit 0 0 #t) => #b1
+(copy-bit 2 0 #t) => #b100
+(copy-bit 2 #b1111 #f) => #b1011
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-swap index@sub{1} index@sub{2} i
+
+Return an integer the same as @var{i} except that the
+@var{index@sub{1}}th bit and the @var{index@sub{2}}th bit have been
+exchanged.
+
+@lisp
+(bit-swap 0 2 4) => #b1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} any-bit-set? test-bits i
+@deffnx {Scheme Procedure} every-bit-set? test-bits i
+
+Determine if any/all of the bits set in bitstring @var{test-bits} are
+set in bitstring @var{i}. I.e., return @samp{(not (zero? (bitwise-and
+@var{test-bits} @var{i})))} and @samp{(= @var{test-bits} (bitwise-and
+@var{test-bits} @var{i}))} respectively.
+
+@lisp
+ (any-bit-set? 3 6) => #t
+ (any-bit-set? 3 12) => #f
+ (every-bit-set? 4 6) => #t
+ (every-bit-set? 7 6) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} first-set-bit i
+
+Return the index of the first (smallest index) 1 bit in bitstring
+@var{i}. Return -1 if @var{i} contains no 1 bits (i.e., if @var{i} is
+zero).
+
+@lisp
+ (first-set-bit 1) => 0
+ (first-set-bit 2) => 1
+ (first-set-bit 0) => -1
+ (first-set-bit 40) => 3
+ (first-set-bit -28) => 2
+ (first-set-bit (expt 2 99)) => 99
+ (first-set-bit (expt -2 99)) => 99
+@end lisp
+@end deffn
+
+@node SRFI 151 Bit field operations
+@subsubsection SRFI 151 Bit field operations
+
+These functions operate on a contiguous field of bits (a "byte", in
+Common Lisp parlance) in a given bitstring. The @var{start} and
+@var{end} arguments, which are not optional, are non-negative exact
+integers specifying the field: it is the @var{end-start} bits running
+from bit @var{start} to bit @var{end}-1.
+
+@deffn {Scheme Procedure} bit-field i start end
+
+Return the field from @var{i}, shifted down to the least-significant
+position in the result.
+
+@lisp
+ (bit-field #b1101101010 0 4) => #b1010
+ (bit-field #b1101101010 3 9) => #b101101
+ (bit-field #b1101101010 4 9) => #b10110
+ (bit-field #b1101101010 4 10) => #b110110
+ (bit-field 6 0 1) => 0
+ (bit-field 6 1 3) => 3
+ (bit-field 6 2 999) => 1
+ (bit-field #x100000000000000000000000000000000 128 129) => 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-any? i start end
+
+Return true if any of the field's bits are set in bitstring @var{i},
+and false otherwise.
+
+@lisp
+ (bit-field-any? #b1001001 1 6) => #t
+ (bit-field-any? #b1000001 1 6) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-every? i start end
+
+Return false if any of the field's bits are not set in bitstring
+@var{i}, and true otherwise.
+
+@lisp
+ (bit-field-every? #b1011110 1 5) => #t
+ (bit-field-every? #b1011010 1 5) => #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-clear i start end
+@deffnx {Scheme Procedure} bit-field-set i start end
+
+Return @var{i} with the field's bits set to all 0s/1s.
+
+@lisp
+ (bit-field-clear #b101010 1 4) => #b100000
+ (bit-field-set #b101010 1 4) => #b101110
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-replace dest source start end
+
+Return @var{dest} with the field replaced by the least-significant
+@var{end-start} bits in @var{source}.
+
+@lisp
+ (bit-field-replace #b101010 #b010 1 4) => #b100100
+ (bit-field-replace #b110 1 0 1) => #b111
+ (bit-field-replace #b110 1 1 2) => #b110
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-replace-same dest source start end
+
+Return @var{dest} with its field replaced by the corresponding field in
+@var{source}.
+
+@lisp
+ (bit-field-replace-same #b1111 #b0000 1 3) => #b1001
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-rotate i count start end
+
+Return @var{i} with the field cyclically permuted by @var{count} bits
+towards high-order.
+
+@quotation note
+The R6RS analogue @code{bitwise-rotate-bit-field} uses the argument
+ordering @var{i} @var{start} @var{end} @var{count}.
+@end quotation
+
+@lisp
+ (bit-field-rotate #b110 0 0 10) => #b110
+ (bit-field-rotate #b110 0 0 256) => #b110
+ (bit-field-rotate #x100000000000000000000000000000000 1 0 129) => 1
+ (bit-field-rotate #b110 1 1 2) => #b110
+ (bit-field-rotate #b110 1 2 4) => #b1010
+ (bit-field-rotate #b0111 -1 1 4) => #b1011
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-field-reverse i start end
+
+Return @var{i} with the order of the bits in the field reversed.
+
+@lisp
+ (bit-field-reverse 6 1 3) => 6
+ (bit-field-reverse 6 1 4) => 12
+ (bit-field-reverse 1 0 32) => #x80000000
+ (bit-field-reverse 1 0 31) => #x40000000
+ (bit-field-reverse 1 0 30) => #x20000000
+ (bit-field-reverse #x140000000000000000000000000000000 0 129) => 5
+@end lisp
+@end deffn
+
+@node SRFI 151 Bits conversion
+@subsubsection SRFI 151 Bits conversion
+
+@deffn {Scheme Procedure} bits->list i [len]
+@deffnx {Scheme Procedure} bits->vector i [len]
+
+Return a list/vector of @var{len} booleans corresponding to each bit of
+the non-negative integer @var{i}, returning bit #0 as the first element,
+bit #1 as the second, and so on. @code{#t} is returned for each 1;
+@code{#f} for 0.
+
+@lisp
+ (bits->list #b1110101) => (#t #f #t #f #t #t #t)
+ (bits->list 3 5) => (#t #t #f #f #f)
+ (bits->list 6 4) => (#f #t #t #f)
+ (bits->vector #b1110101) => #(#t #f #t #f #t #t #t)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} list->bits list
+@deffnx {Scheme Procedure} vector->bits vector
+
+Return an integer formed from the booleans in @var{list}/@var{vector},
+using the first element as bit #0, the second element as bit #1, and so
+on. It is an error if @var{list}/@var{vector} contains non-booleans. A
+1 bit is coded for each @code{#t}; a 0 bit for @code{#f}. Note that the
+result is never a negative integer.
+
+@lisp
+ (list->bits '(#t #f #t #f #t #t #t)) => #b1110101
+ (list->bits '(#f #f #t #f #t #f #t #t #t)) => #b111010100
+ (list->bits '(#f #t #t)) => 6
+ (list->bits '(#f #t #t #f)) => 6
+ (list->bits '(#f #f #t #t)) => 12
+ (vector->bits '#(#t #f #t #f #t #t #t)) => #b1110101
+ (vector->bits '#(#f #f #t #f #t #f #t #t #t)) => #b111010100
+ (vector->bits '#(#f #t #t)) => 6
+ (vector->bits '#(#f #t #t #f)) => 6
+ (vector->bits '#(#f #f #t #t)) => 12
+@end lisp
+
+For positive integers,
+@code{bits->list} and @code{list->bits} are inverses in the sense of @code{equal?},
+and so are @code{bits->vector} and @code{vector->bits}
+@end deffn
+
+@deffn {Scheme Procedure} bits bool @dots{}
+
+Return the integer coded by the @code{bool} arguments. The first
+argument is bit #0, the second argument is bit #1, and so on. Note that
+the result is never a negative integer.
+
+@lisp
+ (bits #t #f #t #f #t #t #t) => #b1110101
+ (bits #f #f #t #f #t #f #t #t #t) => #b111010100
+@end lisp
+@end deffn
+
+@node SRFI 151 Fold/unfold and generate
+@subsubsection SRFI 151 Fold, unfold, and generate
+
+It is an error if the arguments named @var{proc}, @var{top}?,
+@var{apper} or @var{successor} are not procedures. The arguments named
+@var{seed} may be any Scheme object.
+
+@deffn {Scheme Procedure} bitwise-fold proc seed i
+
+For each bit @var{b} of @var{i} from bit #0 (inclusive) to bit
+@samp{(integer-length @var{i})}(exclusive), @var{proc} is called as
+@samp{(@var{proc} @var{b} @var{r})}, where @var{r} is the current
+accumulated result. The initial value of @var{r} is @var{seed}, and
+the value returned by @var{proc} becomes the next accumulated result.
+When the last bit has been processed, the final accumulated result
+becomes the result of @code{bitwise-fold}.
+
+@lisp
+ (bitwise-fold cons '() #b1010111) => (#t #f #t #f #t #t #t)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-for-each proc i
+
+Repeatedly apply @var{proc} to the bits of @var{i} starting with bit
+#0 (inclusive) and ending with bit @samp{(integer-length @var{i})}
+(exclusive). The values returned by @var{proc} are discarded. Return
+an unspecified value.
+
+@lisp
+ (let ((count 0))
+ (bitwise-for-each (lambda (b) (if b (set! count (+ count 1))))
+ #b1010111)
+ count)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bitwise-unfold stop? mapper successor seed
+
+Generate a non-negative integer bit by bit, starting with bit 0. If the
+result of applying @var{stop?} to the current state (whose initial value
+is @var{seed}) is true, return the currently accumulated bits as an
+integer. Otherwise, apply @var{mapper} to the current state to obtain
+the next bit of the result by interpreting a true value as a 1 bit and a
+false value as a 0 bit. Then get a new state by applying
+@var{successor} to the current state, and repeat this algorithm.
+
+@lisp
+ (bitwise-unfold (lambda (i) (= i 10))
+ even?
+ (lambda (i) (+ i 1))
+ 0) => #b101010101
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} make-bitwise-generator i
+
+Return a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI
+121} generator that generates all the bits of @var{i} starting with bit
+#0. Note that the generator is infinite.
+
+@lisp
+ (let ((g (make-bitwise-generator #b110)))
+ (test #f (g))
+ (test #t (g))
+ (test #t (g))
+ (test #f (g)))
+@end lisp
+@end deffn
+
@node SRFI-171
@subsection Transducers
@cindex SRFI-171
diff --git a/module/srfi/srfi-151.sld b/module/srfi/srfi-151.sld
new file mode 100644
index 000000000..beb004b87
--- /dev/null
+++ b/module/srfi/srfi-151.sld
@@ -0,0 +1,56 @@
+;; Copyright (C) John Cowan (2016). All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-library (srfi srfi-151)
+ (import (scheme base))
+ (import (scheme case-lambda))
+
+ (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv
+ bitwise-nand bitwise-nor bitwise-andc1 bitwise-andc2
+ bitwise-orc1 bitwise-orc2)
+ (export arithmetic-shift bit-count integer-length bitwise-if
+ bit-set? copy-bit bit-swap any-bit-set? every-bit-set? first-set-bit)
+ (export bit-field bit-field-any? bit-field-every? bit-field-clear bit-field-set
+ bit-field-replace bit-field-replace-same
+ bit-field-rotate bit-field-reverse)
+ (export bits->list list->bits bits->vector vector->bits bits
+ bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator)
+
+ ;; Provide core functions
+ (import (only (rnrs arithmetic bitwise)
+ bitwise-not bitwise-and bitwise-ior bitwise-xor
+ bitwise-bit-count))
+ (import (rename (only (rnrs arithmetic bitwise)
+ bitwise-arithmetic-shift bitwise-length)
+ (bitwise-arithmetic-shift arithmetic-shift)
+ (bitwise-length integer-length)))
+
+ (begin
+ (define (bit-count i) ; Negative case different to R6RS bitwise-bit-count
+ (if (>= i 0)
+ (bitwise-bit-count i)
+ (bitwise-bit-count (bitwise-not i)))))
+
+ ;; Stable part of the implementation
+ (include "srfi-151/bitwise-33.scm")
+ (include "srfi-151/bitwise-60.scm")
+ (include "srfi-151/bitwise-other.scm"))
diff --git a/module/srfi/srfi-151/bitwise-33.scm b/module/srfi/srfi-151/bitwise-33.scm
new file mode 100644
index 000000000..92f8056d0
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-33.scm
@@ -0,0 +1,108 @@
+;;;; bitwise-33 - Olin Shivers's code from SRFI-33 with modified names
+
+;;; Olin Shivers is the sole author of this code, and he has placed it in
+;;; the public domain.
+;;;
+;;; A good implementation might choose to provide direct compiler/interpreter
+;;; support for these derived functions, or might simply define them to be
+;;; integrable -- i.e., inline-expanded.
+;;;
+;;; The seven non-trivial boolean functions in terms
+;;; of not, and, or & xor.
+
+(define (bitwise-nand i j) (bitwise-not (bitwise-and i j)))
+(define (bitwise-nor i j) (bitwise-not (bitwise-ior i j)))
+(define (bitwise-andc1 i j) (bitwise-and (bitwise-not i) j))
+(define (bitwise-andc2 i j) (bitwise-and i (bitwise-not j)))
+(define (bitwise-orc1 i j) (bitwise-ior (bitwise-not i) j))
+(define (bitwise-orc2 i j) (bitwise-ior i (bitwise-not j)))
+
+;;; This is a general definition, but less than efficient. It should also
+;;; receive primitive compiler/interpreter support so that the expensive
+;;; n-ary mechanism is not invoked in the standard cases -- that is,
+;;; an application of BITWISE-EQV should be rewritten into an equivalent
+;;; tree applying some two-argument primitive to the arguments, in the
+;;; same manner that statically-known n-ary applications of associative
+;;; operations such as + and * are handled efficiently:
+;;; (bitwise-eqv) => -1
+;;; (bitwise-eqv i) => i
+;;; (bitwise-eqv i j) => (%bitwise-eqv i j)
+;;; (bitwise-eqv i j k) => (%bitwise-eqv (%bitwise-eqv i j) k)
+;;; (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l)
+
+(define (bitwise-eqv . args)
+ (let lp ((args args) (ans -1))
+ (if (pair? args)
+ (lp (cdr args) (bitwise-not (bitwise-xor ans (car args))))
+ ans)))
+
+;;; Helper function -- make a mask of SIZE 1-bits, e.g. (%MASK 3) = #b111.
+;;; Suppose your Scheme's fixnums are N bits wide (counting the sign bit,
+;;; not counting any tag bits). This version, due to Marc Feeley, will
+;;; handle SIZE in the range [0,N-1] without overflowing to bignums.
+;;; (For SIZE >= N, the correct bignum value is also produced.)
+
+(define (mask start end) (bitwise-not (arithmetic-shift -1 (- end start))))
+
+;;; This alternate, mathematically-equivalent expression
+;;; (- (arithmetic-shift 1 size) 1)
+;;; is not as good -- it only handles SIZE in the range [0,N-2] without
+;;; overflowing to bignums.
+;;;
+;;; Finally, note that even Feeley's expression can't build an N-bit mask
+;;; without bignum help. This is fundamental, since the interpretation
+;;; of fixed-size fixnum bit patterns as semi-infinite-bit-strings is that
+;;; you replicate the high bit out to infinity. So you have to have a
+;;; zero "stop bit" appearing after that highest one bit to turn off the
+;;; replication of the ones.
+
+(define (bit-set? index n)
+ (not (zero? (bitwise-and (arithmetic-shift 1 index) n))))
+
+(define (any-bit-set? test-bits n) (not (zero? (bitwise-and test-bits n))))
+
+(define (every-bit-set? test-bits n) (= test-bits (bitwise-and test-bits n)))
+
+;;; Bit-field ops
+
+(define (bit-field n start end)
+ (bitwise-and (mask start end) (arithmetic-shift n (- start))))
+
+(define (bit-field-any? n start end)
+ (not (zero? (bitwise-and (arithmetic-shift n (- start)) (mask start end)))))
+
+;; Part of Olin's late revisions; code by John Cowan; public domain.
+(define (bit-field-every? n start end)
+ (let ((m (mask start end)))
+ (eqv? m (bitwise-and (arithmetic-shift n (- start)) m))))
+
+;; Integrating i-b-f reduces nicely.
+(define (bit-field-clear n start end)
+ (bit-field-replace n 0 start end))
+
+;; Counterpart to above, not in SRFI 33, written by John Cowan, public domain
+(define (bit-field-set n start end)
+ (bit-field-replace n -1 start end))
+
+;;; Oops -- intermediate ARITHMETIC-SHIFT can fixnum-overflow on fixnum args.
+;(define (bit-field-replace newfield n start end)
+; (bit-field-replace-same (arithmetic-shift newfield start) n start end))
+
+;;; This three-line version won't fixnum-overflow on fixnum args.
+(define (bit-field-replace n newfield start end)
+ (let ((m (mask start end)))
+ (bitwise-ior (bitwise-and n (bitwise-not (arithmetic-shift m start)))
+ (arithmetic-shift (bitwise-and newfield m) start))))
+
+(define (bit-field-replace-same to from start end)
+ (bitwise-if (arithmetic-shift (mask start end) start) from to))
+
+;; Simple definition
+;(define (first-set-bit i)
+; (and (not (zero? i))
+; (let lp ((j 0) (i start))
+; (if (bit-set? i 0) j
+; (lp (+ j 1) (arithmetic-shift i 1))))))
+
+;;; Clever definition, assuming you have a fast BIT-COUNT.
+(define (first-set-bit i) (- (bit-count (bitwise-xor i (- i 1))) 1))
diff --git a/module/srfi/srfi-151/bitwise-60.scm b/module/srfi/srfi-151/bitwise-60.scm
new file mode 100644
index 000000000..3f91cd632
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-60.scm
@@ -0,0 +1,70 @@
+;;;; bitwise-60 - SRFI-60 procedures without SRFI-33 analogues, renamed
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define (bit-field-rotate n count start end)
+ (define width (- end start))
+ (set! count (modulo count width))
+ (let ((mask (bitwise-not (arithmetic-shift -1 width))))
+ (define zn (bitwise-and mask (arithmetic-shift n (- start))))
+ (bitwise-ior (arithmetic-shift
+ (bitwise-ior (bitwise-and mask (arithmetic-shift zn count))
+ (arithmetic-shift zn (- count width)))
+ start)
+ (bitwise-and (bitwise-not (arithmetic-shift mask start)) n))))
+
+(define (bit-reverse k n)
+ (do ((m (if (negative? n) (bitwise-not n) n) (arithmetic-shift m -1))
+ (k (+ -1 k) (+ -1 k))
+ (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
+ ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
+
+
+(define (bit-field-reverse n start end)
+ (define width (- end start))
+ (let ((mask (bitwise-not (arithmetic-shift -1 width))))
+ (define zn (bitwise-and mask (arithmetic-shift n (- start))))
+ (bitwise-ior (arithmetic-shift (bit-reverse width zn) start)
+ (bitwise-and (bitwise-not (arithmetic-shift mask start)) n))))
+
+(define (copy-bit index to bool)
+ (if bool
+ (bitwise-ior to (arithmetic-shift 1 index))
+ (bitwise-and to (bitwise-not (arithmetic-shift 1 index)))))
+
+(define (bits->list k . len)
+ (if (null? len)
+ (do ((k k (arithmetic-shift k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((<= k 0) (reverse lst)))
+ (do ((idx (+ -1 (car len)) (+ -1 idx))
+ (k k (arithmetic-shift k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((negative? idx) (reverse lst)))))
+
+(define (list->bits bools)
+ (do ((bs (reverse bools) (cdr bs))
+ (acc 0 (+ acc acc (if (car bs) 1 0))))
+ ((null? bs) acc)))
+
+(define (bits . bools)
+ (list->bits bools))
+
+(define (bitwise-if mask n0 n1)
+ (bitwise-ior (bitwise-and mask n0)
+ (bitwise-and (bitwise-not mask) n1)))
diff --git a/module/srfi/srfi-151/bitwise-other.scm b/module/srfi/srfi-151/bitwise-other.scm
new file mode 100644
index 000000000..7f7b9b96e
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-other.scm
@@ -0,0 +1,62 @@
+;;;; bitwise-other - functions not from SRFI 33 or SRFI 60
+;;; Copyright John Cowan 2017
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define bits->vector
+ (case-lambda
+ ((i) (list->vector (bits->list i)))
+ ((i len) (list->vector (bits->list i len)))))
+
+(define (vector->bits vector) (list->bits (vector->list vector)))
+
+(define (bit-swap n1 n2 i)
+ (let ((n1-bit (bit-set? n1 i))
+ (n2-bit (bit-set? n2 i)))
+ (copy-bit n2 (copy-bit n1 i n2-bit) n1-bit)))
+
+(define (bitwise-fold proc seed i)
+ (let ((len (integer-length i)))
+ (let loop ((n 0) (r seed))
+ (if (= n len)
+ r
+ (loop (+ n 1) (proc (bit-set? n i) r))))))
+
+(define (bitwise-for-each proc i)
+ (let ((len (integer-length i)))
+ (let loop ((n 0))
+ (when (< n len)
+ (proc (bit-set? n i))
+ (loop (+ n 1))))))
+
+(define (bitwise-unfold stop? mapper successor seed)
+ (let loop ((n 0) (result 0) (state seed))
+ (if (stop? state)
+ result
+ (loop (+ n 1)
+ (copy-bit n result (mapper state))
+ (successor state)))))
+
+(define (make-bitwise-generator i)
+ (lambda ()
+ (let ((bit (bit-set? 0 i)))
+ (set! i (arithmetic-shift i -1))
+ bit)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 13eb1f24f..f51db8830 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -165,6 +165,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-125.test \
tests/srfi-126.test \
tests/srfi-128.test \
+ tests/srfi-151.test \
tests/srfi-171.test \
tests/srfi-4.test \
tests/srfi-9.test \
@@ -214,6 +215,7 @@ EXTRA_DIST = \
tests/srfi-125-test.scm \
tests/srfi-126-test.scm \
tests/srfi-128-test.scm \
+ tests/srfi-151-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-151-test.scm b/test-suite/tests/srfi-151-test.scm
new file mode 100644
index 000000000..b5f6d32cd
--- /dev/null
+++ b/test-suite/tests/srfi-151-test.scm
@@ -0,0 +1,381 @@
+;; Copyright (C) John Cowan (2016). All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; START Guile-specific modifications.
+;;;
+;;; The 'imports' are turned into 'use-modules' and srfi-64 is used.
+;;; Two macros are added for compatibility with Chicken Scheme's 'test'
+;;; library. A 'test-begin' call is added.
+(use-modules (srfi srfi-151)
+ (srfi srfi-64))
+
+(define-syntax-rule (test arg ...)
+ (test-equal arg ...))
+
+(define-syntax-rule (test-exit arg ...)
+ (test-end))
+
+(test-begin "srfi-151")
+;;; END Guile-specific modifications.
+
+(test-group "bitwise"
+ (test-group "bitwise/basic"
+ (test "test-1" -1 (bitwise-not 0))
+ (test "test-122" 0 (bitwise-not -1))
+ (test "test-248" -11 (bitwise-not 10))
+ (test "test-249" 36 (bitwise-not -37))
+ (test "test-2" 0 (bitwise-and #b0 #b1))
+ (test "test-10" 1680869008 (bitwise-and -193073517 1689392892))
+ (test "test-20" 3769478 (bitwise-and 1694076839 -4290775858))
+ (test "test-115" 6 (bitwise-and 14 6))
+ (test "test-251" 10 (bitwise-and 11 26))
+ (test "test-254" 4 (bitwise-and 37 12))
+ (test "test-288" 1 (bitwise-and #b1 #b1))
+ (test "test-289" 0 (bitwise-and #b1 #b10))
+ (test "test-290" #b10 (bitwise-and #b11 #b10))
+ (test "test-291" #b101 (bitwise-and #b101 #b111))
+ (test "test-292" #b111 (bitwise-and -1 #b111))
+ (test "test-293" #b110 (bitwise-and -2 #b111))
+ (test "test-294" 3769478 (bitwise-and -4290775858 1694076839))
+ (test "test-11" -4294967295 (bitwise-ior 1 (- -1 #xffffffff)))
+ (test "test-12" -18446744073709551615 (bitwise-ior 1 (- -1 #xffffffffffffffff)))
+ (test "test-117" 14 (bitwise-ior 10 12))
+ (test "test-250" 11 (bitwise-ior 3 10))
+ (test "test-13" -4294967126 (bitwise-xor #b10101010 (- -1 #xffffffff)))
+ (test "test-15" -18446744073709551446 (bitwise-xor #b10101010 (- -1 #xffffffffffffffff)))
+ (test "test-16" -2600468497 (bitwise-ior 1694076839 -4290775858))
+ (test "test-17" -184549633 (bitwise-ior -193073517 1689392892))
+ (test "test-18" -2604237975 (bitwise-xor 1694076839 -4290775858))
+ (test "test-19" -1865418641 (bitwise-xor -193073517 1689392892))
+ (test "test-119" 6 (bitwise-xor 10 12))
+ (test "test-252" 9 (bitwise-xor 3 10))
+ (test "test-14" (bitwise-not -4294967126) (bitwise-eqv #b10101010 (- -1 #xffffffff)))
+ (test "test-253" -42 (bitwise-eqv 37 12))
+ (test "test-27" -1 (bitwise-nand 0 0))
+ (test "test-28" -1 (bitwise-nand 0 -1))
+ (test "test-29" -124 (bitwise-nand -1 123))
+ (test "test-326" -11 (bitwise-nand 11 26))
+ (test "test-327" -28 (bitwise-nor 11 26))
+ (test "test-317" 0 (bitwise-nor -1 123))
+ (test "test-328" 16 (bitwise-andc1 11 26))
+ (test "test-329" 1 (bitwise-andc2 11 26))
+ (test "test-330" -2 (bitwise-orc1 11 26))
+ (test "test-30" -1 (bitwise-nor 0 0))
+ (test "test-31" 0 (bitwise-nor 0 -1))
+ (test "test-22" 0 (bitwise-andc1 0 0))
+ (test "test-23" -1 (bitwise-andc1 0 -1))
+ (test "test-24" 123 (bitwise-andc1 0 123))
+ (test "test-25" 0 (bitwise-andc2 0 0))
+ (test "test-26" -1 (bitwise-andc2 -1 0))
+ (test "test-318" -1 (bitwise-orc1 0 0))
+ (test "test-319" -1 (bitwise-orc1 0 -1))
+ (test "test-320" 0 (bitwise-orc1 -1 0))
+ (test "test-321" -124 (bitwise-orc1 123 0))
+ (test "test-322" -1 (bitwise-orc2 0 0))
+ (test "test-323" -1 (bitwise-orc2 -1 0))
+ (test "test-324" 0 (bitwise-orc2 0 -1))
+ (test "test-325" -124 (bitwise-orc2 0 123))
+ )
+ (test-group "bitwise/integer"
+ (test "test-78" #x1000000000000000100000000000000000000000000000000
+ (arithmetic-shift #x100000000000000010000000000000000 64))
+ (test "test-79" #x8e73b0f7da0e6452c810f32b809079e5
+ (arithmetic-shift #x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b -64))
+ (test "test-196" 2 (arithmetic-shift 1 1))
+ (test "test-197" 0 (arithmetic-shift 1 -1))
+ (test "test-331" 1 (arithmetic-shift 1 0))
+ (test "test-333" 4 (arithmetic-shift 1 2))
+ (test "test-334" 8 (arithmetic-shift 1 3))
+ (test "test-335" 16 (arithmetic-shift 1 4))
+ (test "test-336" (expt 2 31) (arithmetic-shift 1 31))
+ (test "test-337" (expt 2 32) (arithmetic-shift 1 32))
+ (test "test-338" (expt 2 33) (arithmetic-shift 1 33))
+ (test "test-339" (expt 2 63) (arithmetic-shift 1 63))
+ (test "test-340" (expt 2 64) (arithmetic-shift 1 64))
+ (test "test-341" (expt 2 65) (arithmetic-shift 1 65))
+ (test "test-342" (expt 2 127) (arithmetic-shift 1 127))
+ (test "test-343" (expt 2 128) (arithmetic-shift 1 128))
+ (test "test-344" (expt 2 129) (arithmetic-shift 1 129))
+ (test "test-345" 3028397001194014464 (arithmetic-shift 11829675785914119 8))
+ (test "test-346" -1 (arithmetic-shift -1 0))
+ (test "test-347" -2 (arithmetic-shift -1 1))
+ (test "test-348" -4 (arithmetic-shift -1 2))
+ (test "test-349" -8 (arithmetic-shift -1 3))
+ (test "test-350" -16 (arithmetic-shift -1 4))
+ (test "test-351" (- (expt 2 31)) (arithmetic-shift -1 31))
+ (test "test-352" (- (expt 2 32)) (arithmetic-shift -1 32))
+ (test "test-353" (- (expt 2 33)) (arithmetic-shift -1 33))
+ (test "test-354" (- (expt 2 63)) (arithmetic-shift -1 63))
+ (test "test-355" (- (expt 2 64)) (arithmetic-shift -1 64))
+ (test "test-356" (- (expt 2 65)) (arithmetic-shift -1 65))
+ (test "test-357" (- (expt 2 127)) (arithmetic-shift -1 127))
+ (test "test-358" (- (expt 2 128)) (arithmetic-shift -1 128))
+ (test "test-359" (- (expt 2 129)) (arithmetic-shift -1 129))
+ (test "test-360" 0 (arithmetic-shift 1 -63))
+ (test "test-361" 0 (arithmetic-shift 1 -64))
+ (test "test-362" 0 (arithmetic-shift 1 -65))
+ (test "test-255" 32 (arithmetic-shift 8 2))
+ (test "test-256" 4 (arithmetic-shift 4 0))
+ (test "test-257" 4 (arithmetic-shift 8 -1))
+ (test "test-258" -79 (arithmetic-shift -100000000000000000000000000000000 -100))
+ (test "test-135" 2 (bit-count 12))
+ (test "test-263" 0 (integer-length 0))
+ (test "test-264" 1 (integer-length 1))
+ (test "test-265" 0 (integer-length -1))
+ (test "test-266" 3 (integer-length 7))
+ (test "test-267" 3 (integer-length -7))
+ (test "test-268" 4 (integer-length 8))
+ (test "test-269" 3 (integer-length -8))
+ (test "test-125" 9 (bitwise-if 3 1 8))
+ (test "test-126" 0 (bitwise-if 3 8 1))
+ (test "test-373" 3 (bitwise-if 1 1 2))
+ (test "test-378" #b00110011 (bitwise-if #b00111100 #b11110000 #b00001111))
+ )
+ (test-group "bitwise/single"
+ (test "test-160" #t (bit-set? 0 1))
+ (test "test-161" #f (bit-set? 1 1))
+ (test "test-162" #f (bit-set? 1 8))
+ (test "test-163" #t (bit-set? 10000 -1))
+ (test "test-167" #t (bit-set? 1000 -1))
+ (test "test-541" #t (bit-set? 64 #x10000000000000000))
+ (test "test-542" #f (bit-set? 64 1))
+ (test "test-272" #t (bit-set? 3 10))
+ (test "test-273" #t (bit-set? 2 6))
+ (test "test-274" #f (bit-set? 0 6))
+ (test "test-168" 0 (copy-bit 0 0 #f))
+ (test "test-169" 0 (copy-bit 30 0 #f))
+ (test "test-170" 0 (copy-bit 31 0 #f))
+ (test "test-171" 0 (copy-bit 62 0 #f))
+ (test "test-172" 0 (copy-bit 63 0 #f))
+ (test "test-173" 0 (copy-bit 128 0 #f))
+ (test "test-174" -1 (copy-bit 0 -1 #t))
+ (test "test-175" -1 (copy-bit 30 -1 #t))
+ (test "test-176" -1 (copy-bit 31 -1 #t))
+ (test "test-177" -1 (copy-bit 62 -1 #t))
+ (test "test-178" -1 (copy-bit 63 -1 #t))
+ (test "test-179" -1 (copy-bit 128 -1 #t))
+ (test "test-180" 1 (copy-bit 0 0 #t))
+ (test "test-181" #x106 (copy-bit 8 6 #t))
+ (test "test-182" 6 (copy-bit 8 6 #f))
+ (test "test-183" -2 (copy-bit 0 -1 #f))
+ (test "test-184" 0 (copy-bit 128 #x100000000000000000000000000000000 #f))
+ (test "test-185" #x100000000000000000000000000000000
+ (copy-bit 128 #x100000000000000000000000000000000 #t))
+ (test "test-186" #x100000000000000000000000000000000
+ (copy-bit 64 #x100000000000000000000000000000000 #f))
+ (test "test-187" #x-100000000000000000000000000000000
+ (copy-bit 64 #x-100000000000000000000000000000000 #f))
+ (test "test-188" #x-100000000000000000000000000000000
+ (copy-bit 256 #x-100000000000000000000000000000000 #t))
+ (test "test-276" #b100 (copy-bit 2 0 #t))
+ (test "test-277" #b1011 (copy-bit 2 #b1111 #f))
+ (test "test-379" #b1 (copy-bit 0 0 #t))
+ (test "test-100" #b1011 (bit-swap 1 2 #b1101))
+ (test "test-101" #b1011 (bit-swap 2 1 #b1101))
+ (test "test-382" #b1110 (bit-swap 0 1 #b1101))
+ (test "test-102" #b10000000101 (bit-swap 3 10 #b1101))
+ (test "test-278" 1 (bit-swap 0 2 4))
+ (test "test-129" #t (any-bit-set? 3 6))
+ (test "test-130" #f (any-bit-set? 3 12))
+ (test "test-133" #t (every-bit-set? 4 6))
+ (test "test-134" #f (every-bit-set? 7 6))
+ (test "test-141" -1 (first-set-bit 0))
+ (test "test-142" 0 (first-set-bit 1))
+ (test "test-143" 0 (first-set-bit 3))
+ (test "test-144" 2 (first-set-bit 4))
+ (test "test-145" 1 (first-set-bit 6))
+ (test "test-146" 0 (first-set-bit -1))
+ (test "test-147" 1 (first-set-bit -2))
+ (test "test-148" 0 (first-set-bit -3))
+ (test "test-149" 2 (first-set-bit -4))
+ (test "test-150" 128 (first-set-bit #x100000000000000000000000000000000))
+ (test "test-280" 1 (first-set-bit 2))
+ (test "test-282" 3 (first-set-bit 40))
+ (test "test-283" 2 (first-set-bit -28))
+ (test "test-284" 99 (first-set-bit (expt 2 99)))
+ (test "test-285" 99 (first-set-bit (expt -2 99)))
+ )
+ (test-group "bitwise/field"
+ (test "test-189" 0 (bit-field 6 0 1))
+ (test "test-190" 3 (bit-field 6 1 3))
+ (test "test-191" 1 (bit-field 6 2 999))
+ (test "test-192" 1 (bit-field #x100000000000000000000000000000000 128 129))
+ (test "test-363" #b1010 (bit-field #b1101101010 0 4))
+ (test "test-364" #b101101 (bit-field #b1101101010 3 9))
+ (test "test-365" #b10110 (bit-field #b1101101010 4 9))
+ (test "test-366" #b110110 (bit-field #b1101101010 4 10))
+ (test "test-367" #t (bit-field-any? #b101101 0 2))
+ (test "test-368" #t (bit-field-any? #b101101 2 4))
+ (test "test-369" #f (bit-field-any? #b101101 1 2))
+ (test "test-370" #f (bit-field-every? #b101101 0 2))
+ (test "test-371" #t (bit-field-every? #b101101 2 4))
+ (test "test-372" #t (bit-field-every? #b101101 0 1))
+ (test "test-374" #b100000 (bit-field-clear #b101010 1 4))
+ (test "test-375" #b101110 (bit-field-set #b101010 1 4))
+ (test "test-193" #b111 (bit-field-replace #b110 1 0 1))
+ (test "test-194" #b110 (bit-field-replace #b110 1 1 2))
+ (test "test-195" #b010 (bit-field-replace #b110 1 1 3))
+ (test "test-376" #b100100 (bit-field-replace #b101010 #b010 1 4))
+ (test "test-377" #b1001 (bit-field-replace-same #b1111 #b0000 1 3))
+ (test "test-200" #b110 (bit-field-rotate #b110 1 1 2))
+ (test "test-201" #b1010 (bit-field-rotate #b110 1 2 4))
+ (test "test-202" #b1011 (bit-field-rotate #b0111 -1 1 4))
+ (test "test-203" #b0 (bit-field-rotate #b0 128 0 256))
+ (test "test-204" #b1 (bit-field-rotate #b1 128 1 256))
+ (test "test-205" #x100000000000000000000000000000000
+ (bit-field-rotate #x100000000000000000000000000000000 128 0 64))
+ (test "test-206" #x100000000000000000000000000000008
+ (bit-field-rotate #x100000000000000000000000000000001 3 0 64))
+ (test "test-207" #x100000000000000002000000000000000
+ (bit-field-rotate #x100000000000000000000000000000001 -3 0 64))
+ (test "test-208" #b110 (bit-field-rotate #b110 0 0 10))
+ (test "test-209" #b110 (bit-field-rotate #b110 0 0 256))
+ (test "test-475" 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129))
+ (test "test-211" 6 (bit-field-reverse 6 1 3))
+ (test "test-212" 12 (bit-field-reverse 6 1 4))
+ (test "test-213" #x80000000 (bit-field-reverse 1 0 32))
+ (test "test-214" #x40000000 (bit-field-reverse 1 0 31))
+ (test "test-215" #x20000000 (bit-field-reverse 1 0 30))
+ (test "test-216" (bitwise-ior (arithmetic-shift -1 32) #xFBFFFFFF)
+ (bit-field-reverse -2 0 27))
+ (test "test-217" (bitwise-ior (arithmetic-shift -1 32) #xF7FFFFFF)
+ (bit-field-reverse -2 0 28))
+ (test "test-218" (bitwise-ior (arithmetic-shift -1 32) #xEFFFFFFF)
+ (bit-field-reverse -2 0 29))
+ (test "test-219" (bitwise-ior (arithmetic-shift -1 32) #xDFFFFFFF)
+ (bit-field-reverse -2 0 30))
+ (test "test-220" (bitwise-ior (arithmetic-shift -1 32) #xBFFFFFFF)
+ (bit-field-reverse -2 0 31))
+ (test "test-221" (bitwise-ior (arithmetic-shift -1 32) #x7FFFFFFF)
+ (bit-field-reverse -2 0 32))
+ (test "test-222" 5 (bit-field-reverse #x140000000000000000000000000000000 0 129))
+ )
+ (test-group "bitwise/conversion"
+ (test "test-103" '(#t #f #t #f #t #t #t) (bits->list #b1110101))
+ (test "test-104" '(#f #t #f #t) (bits->list #b111010 4))
+ (test "test-106" #b1110101 (list->bits '(#t #f #t #f #t #t #t)))
+ (test "test-107" #b111010100 (list->bits '(#f #f #t #f #t #f #t #t #t)))
+ (test "test-223" '(#t #t) (bits->list 3))
+ (test "test-224" '(#f #t #t #f) (bits->list 6 4))
+ (test "test-225" '(#f #t) (bits->list 6 2))
+ (test "test-226" '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
+ (bits->list 1 128))
+ (test "test-228" '(#f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
+ (bits->list #x100000000000000000000000000000000))
+ (test "test-229" 6 (list->bits '(#f #t #t)))
+ (test "test-230" 12 (list->bits '(#f #f #t #t)))
+ (test "test-231" 6 (list->bits '(#f #t #t #f)))
+ (test "test-232" 2 (list->bits '(#f #t)))
+ (test "test-233" 1 (list->bits
+ '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)))
+ (test "test-234" #x100000000000000000000000000000000
+ (list->bits
+ '(#f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)))
+ (test "test-235" #x03FFFFFF (list->bits '(#t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-236" #x07FFFFFF (list->bits '(#t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-237" #x0FFFFFFF (list->bits '(#t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-238" #x1FFFFFFF (list->bits '(#t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-239" #x3FFFFFFF (list->bits '(#t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-240" #x7FFFFFFF (list->bits '(#t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-241" #xFFFFFFFF (list->bits '(#t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-242" #x1FFFFFFFF (list->bits '(#t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))
+ (test "test-490" 1 (list->bits '(#t #f)))
+ (test "test-108" #b1110101 (vector->bits '#(#t #f #t #f #t #t #t)))
+ (test "test-109" #b00011010100 (vector->bits '#(#f #f #t #f #t #f #t #t)))
+ (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))
+ (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))
+ (test "test-110" #b1110101 (bits #t #f #t #f #t #t #t))
+ (test "test-243" 0 (bits))
+ (test "test-111" #b111010100 (bits #f #f #t #f #t #f #t #t #t))
+ )
+ (test-group "bitwise/fold"
+ (test "test-112" '(#t #f #t #f #t #t #t) (bitwise-fold cons '() #b1010111))
+ (test "test-113" 5
+ (let ((count 0))
+ (bitwise-for-each (lambda (b) (if b (set! count (+ count 1))))
+ #b1010111)
+ count))
+ (test "test-114" #b101010101
+ (bitwise-unfold (lambda (i) (= i 10)) even? (lambda (i) (+ i 1)) 0))
+ (let ((g (make-bitwise-generator #b110)))
+ (test "test-244a" #f (g))
+ (test "test-244b" #t (g))
+ (test "test-244c" #t (g))
+ (test "test-244d" #f (g)))
+ )
+)
+(test-exit)
diff --git a/test-suite/tests/srfi-151.test b/test-suite/tests/srfi-151.test
new file mode 100644
index 000000000..6c535b39e
--- /dev/null
+++ b/test-suite/tests/srfi-151.test
@@ -0,0 +1,46 @@
+;;;; srfi-151.test --- Test suite for SRFI-151. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-151)
+ #:use-module (srfi srfi-64))
+
+(define report (@@ (test-suite lib) report))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-151-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 14/16] module: Add SRFI 160.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (12 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 13/16] module: Add SRFI 151 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 15/16] module: Add SRFI 178 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 16/16] module: Add SRFI 209 Maxim Cournoyer
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* 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.
* NEWS: Update news.
---
(no changes since v5)
Changes in v5:
- Generate Texinfo menu entries
- Update NEWS
NEWS | 1 +
am/bootstrap.am | 40 ++
doc/ref/guile.texi | 2 +-
doc/ref/srfi-modules.texi | 649 +++++++++++++++++-
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 ++
49 files changed, 9425 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/NEWS b/NEWS
index a33e5bbb1..c36b55643 100644
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,7 @@ the compiler reports it as "possibly unused".
** Add (scheme sort)
** Add (srfi 125), a mutators library
** Add (srfi 151), a bitwise operations library
+** Add (srfi 160), an homogeneous numeric vector library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 57c603a0a..f7fa9e145 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 \
@@ -452,6 +465,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..23e030b99 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
@@ -70,6 +70,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 126:: R6RS-based hash tables.
* SRFI 128:: Comparators.
* SRFI 151:: Bitwise Operations.
+* SRFI 160:: Homogeneous numeric vectors.
* SRFI-171:: Transducers.
@end menu
@@ -8229,6 +8230,652 @@ 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
+
+@menu
+* SRFI 160 Abstract::
+* SRFI 160 Rationale::
+* SRFI 160 Datatypes::
+* SRFI 160 Notation::
+* SRFI 160 Packaging::
+* SRFI 160 Procedures::
+* SRFI 160 Optional lexical syntax::
+@end menu
+
+@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
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 15/16] module: Add SRFI 178.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (13 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 14/16] module: Add SRFI 160 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 16/16] module: Add SRFI 209 Maxim Cournoyer
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-178.sld: New file.
* am/bootstrap.am (SOURCES): Register it.
* module/srfi/srfi-178/convert.scm
* module/srfi/srfi-178/fields.scm
* module/srfi/srfi-178/gen-acc.scm
* module/srfi/srfi-178/logic-ops.scm
* module/srfi/srfi-178/macros.scm
* module/srfi/srfi-178/map2list.scm
* module/srfi/srfi-178/quasi-ints.scm
* module/srfi/srfi-178/quasi-strs.scm
* module/srfi/srfi-178/unfolds.scm
* module/srfi/srfi-178/wrappers.scm: New module implementation files.
* am/bootstrap.am (NOCOMP_SOURCES): Register them.
* test-suite/tests/srfi-178.test: New test.
* test-suite/Makefile.am (SCM_TESTS): Register it.
* test-suite/tests/srfi-178-test/constructors.scm
* test-suite/tests/srfi-178-test/conversions.scm
* test-suite/tests/srfi-178-test/fields.scm
* test-suite/tests/srfi-178-test/gen-accum.scm
* test-suite/tests/srfi-178-test/iterators.scm
* test-suite/tests/srfi-178-test/logic-ops.scm
* test-suite/tests/srfi-178-test/mutators.scm
* test-suite/tests/srfi-178-test/quasi-ints.scm
* test-suite/tests/srfi-178-test/quasi-string.scm
* test-suite/tests/srfi-178-test/selectors.scm: New test implementation
files.
* test-suite/Makefile.am (EXTRA_DIST): Register them.
* doc/ref/srfi-modules.texi (SRFI 178): New subsection.
* NEWS: Update news.
---
(no changes since v1)
NEWS | 1 +
am/bootstrap.am | 11 +
doc/ref/guile.texi | 4 +-
doc/ref/srfi-modules.texi | 604 ++++++++++++++++++
module/srfi/srfi-178.sld | 105 +++
module/srfi/srfi-178/convert.scm | 83 +++
module/srfi/srfi-178/fields.scm | 88 +++
module/srfi/srfi-178/gen-acc.scm | 25 +
module/srfi/srfi-178/logic-ops.scm | 105 +++
module/srfi/srfi-178/macros.scm | 26 +
module/srfi/srfi-178/map2list.scm | 27 +
module/srfi/srfi-178/quasi-ints.scm | 54 ++
module/srfi/srfi-178/quasi-strs.scm | 88 +++
module/srfi/srfi-178/unfolds.scm | 44 ++
module/srfi/srfi-178/wrappers.scm | 285 +++++++++
test-suite/Makefile.am | 11 +
.../tests/srfi-178-test/constructors.scm | 88 +++
.../tests/srfi-178-test/conversions.scm | 108 ++++
test-suite/tests/srfi-178-test/fields.scm | 98 +++
test-suite/tests/srfi-178-test/gen-accum.scm | 72 +++
test-suite/tests/srfi-178-test/iterators.scm | 150 +++++
test-suite/tests/srfi-178-test/logic-ops.scm | 125 ++++
test-suite/tests/srfi-178-test/mutators.scm | 79 +++
test-suite/tests/srfi-178-test/quasi-ints.scm | 41 ++
.../tests/srfi-178-test/quasi-string.scm | 62 ++
test-suite/tests/srfi-178-test/selectors.scm | 13 +
test-suite/tests/srfi-178.test | 147 +++++
27 files changed, 2542 insertions(+), 2 deletions(-)
create mode 100644 module/srfi/srfi-178.sld
create mode 100644 module/srfi/srfi-178/convert.scm
create mode 100644 module/srfi/srfi-178/fields.scm
create mode 100644 module/srfi/srfi-178/gen-acc.scm
create mode 100644 module/srfi/srfi-178/logic-ops.scm
create mode 100644 module/srfi/srfi-178/macros.scm
create mode 100644 module/srfi/srfi-178/map2list.scm
create mode 100644 module/srfi/srfi-178/quasi-ints.scm
create mode 100644 module/srfi/srfi-178/quasi-strs.scm
create mode 100644 module/srfi/srfi-178/unfolds.scm
create mode 100644 module/srfi/srfi-178/wrappers.scm
create mode 100644 test-suite/tests/srfi-178-test/constructors.scm
create mode 100644 test-suite/tests/srfi-178-test/conversions.scm
create mode 100644 test-suite/tests/srfi-178-test/fields.scm
create mode 100644 test-suite/tests/srfi-178-test/gen-accum.scm
create mode 100644 test-suite/tests/srfi-178-test/iterators.scm
create mode 100644 test-suite/tests/srfi-178-test/logic-ops.scm
create mode 100644 test-suite/tests/srfi-178-test/mutators.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-ints.scm
create mode 100644 test-suite/tests/srfi-178-test/quasi-string.scm
create mode 100644 test-suite/tests/srfi-178-test/selectors.scm
create mode 100644 test-suite/tests/srfi-178.test
diff --git a/NEWS b/NEWS
index c36b55643..b1a21c59b 100644
--- a/NEWS
+++ b/NEWS
@@ -28,6 +28,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 125), a mutators library
** Add (srfi 151), a bitwise operations library
** Add (srfi 160), an homogeneous numeric vector library
+** Add (srfi 178), a bitvector library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index f7fa9e145..7ebf4ca67 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -371,6 +371,7 @@ SOURCES = \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
+ srfi/srfi-178.sld \
\
statprof.scm \
\
@@ -492,6 +493,16 @@ NOCOMP_SOURCES = \
srfi/srfi-160/u16-impl.scm \
srfi/srfi-160/u32-impl.scm \
srfi/srfi-160/u64-impl.scm \
+ srfi/srfi-178/macros.scm \
+ srfi/srfi-178/convert.scm \
+ srfi/srfi-178/fields.scm \
+ srfi/srfi-178/gen-acc.scm \
+ srfi/srfi-178/logic-ops.scm \
+ srfi/srfi-178/map2list.scm \
+ srfi/srfi-178/quasi-ints.scm \
+ srfi/srfi-178/quasi-strs.scm \
+ srfi/srfi-178/unfolds.scm \
+ srfi/srfi-178/wrappers.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 3226ee53b..22d234b1b 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,8 +24,8 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-Additionally, the documentation of the 125, 126, 128, 151 and 160 SRFI
-modules is adapted from their specification text, which is made
+Additionally, the documentation of the 125, 126, 128, 151, 160 and 178
+SRFI modules is adapted from their specification text, which is made
available under the following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 23e030b99..216a4e045 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -72,6 +72,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 151:: Bitwise Operations.
* SRFI 160:: Homogeneous numeric vectors.
* SRFI-171:: Transducers.
+* SRFI 178:: Bitvectors.
@end menu
@@ -9362,6 +9363,609 @@ The generator version of list-reduce. It reduces over @code{gen} until
it returns the EOF object
@end deffn
+@node SRFI 178
+@subsection SRFI 178: Bitvector library
+@cindex SRFI 178
+
+@menu
+* SRFI 178 Abstract::
+* SRFI 178 Rationale::
+* SRFI 178 Notation::
+* SRFI 178 Bit conversion::
+* SRFI 178 Constructors::
+* SRFI 178 Predicates::
+* SRFI 178 Selectors::
+* SRFI 178 Iteration::
+* SRFI 178 Prefixes suffixes trimming padding::
+* SRFI 178 Mutators::
+* SRFI 178 Conversion::
+* SRFI 178 Generators::
+* SRFI 178 Basic operations::
+* SRFI 178 Quasi-integer operations::
+* SRFI 178 Bit field operations::
+* SRFI 178 Bitvector literals::
+@end menu
+
+@node SRFI 178 Abstract
+@subsubsection SRFI 178 Abstract
+
+This SRFI describes a set of operations on homogeneous bitvectors.
+Operations analogous to those provided on the other homogeneous vector
+types described in
+@url{https://srfi.schemers.org/srfi-160/srfi-160.html, SRFI 160} are
+provided, along with operations analogous to the bitwise operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}.
+
+@node SRFI 178 Rationale
+@subsubsection SRFI 178 Rationale
+
+Bitvectors were excluded from the final draft of SRFI 160 because they
+are the only type of homogeneous numeric vectors for which bitwise
+operations make sense. In addition, there are two ways to view them: as
+vectors of exact integers limited to the values 0 and 1, and as vectors
+of booleans. This SRFI is designed to allow bitvectors to be viewed in
+either way.
+
+@node SRFI 178 Notation
+@subsubsection SRFI 178 Notation
+
+Bitvectors are disjoint from all other Scheme types with the possible
+exception of u1vectors, if the Scheme implementation supports them.
+
+The procedures of this SRFI that accept single bits or lists of bits can
+be passed any of the values 0, 1, #f, #t. Procedures that return a bit
+or a list of bits come in two flavors: one ending in @samp{/int} that
+returns an exact integer, and one ending in @samp{/bool} that returns a
+boolean.
+
+Mapping and folding procedures also come in two flavors: those ending in
+@samp{/int} pass exact integers to their procedure arguments, whereas
+those ending in @samp{/bool} pass booleans to theirs.
+
+Procedures whose names end in @samp{!} are the same as the corresponding
+procedures without @samp{!}, except that the first bitvector argument is
+mutated and an unspecified result is returned. Consequently, only the
+non-@samp{!} version is documented below.
+
+It is an error unless all bitvector arguments passed to procedures that
+accept more than one are of the same length (except as otherwise noted).
+
+In the section containing specifications of procedures, the following
+notation is used to specify parameters and return values:
+
+@table @asis
+@item (@var{f} @var{arg@sub{1}} @var{arg@sub{2}} @dots{}) -> something
+A procedure @var{f} that takes the parameters @var{arg@sub{1}}
+@var{arg@sub{2}} @dots{} and returns a value of the type
+@code{something}. If two values are returned, two types are specified.
+If @code{something} is @code{unspecified}, then @var{f} returns a single
+implementation-dependent value; this SRFI does not specify what it
+returns, and in order to write portable code, the return value should be
+ignored.
+
+@item @var{vec}
+An heterogeneous vector; that is, it must satisfy the predicate
+@code{vector?}.
+
+@item @var{bvec}, @var{to}, @var{from}
+A bitvector, i.e., it must satisfy the predicate @code{bitvector?}. In
+@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{to} is the
+destination and @var{from} is the source.
+
+@item @var{i}, @var{j}, @var{start}, @var{at}
+An exact nonnegative integer less than the length of the bitvector. In
+@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{at} refers
+to the destination and @var{start} to the source.
+
+@item @var{end}
+An exact nonnegative integer not less than @var{start}. This indicates
+the index directly before which traversal will stop --- processing will
+occur until the index of the vector is one less than @var{end}. It is
+the open right side of a range.
+
+@item @var{f}
+A procedure taking one or more arguments, which returns (except as noted
+otherwise) exactly one value.
+
+@item @var{=}
+An equivalence procedure.
+
+@item @var{obj}, @var{seed}, @var{knil}
+Any Scheme object.
+
+@item @var{[something]}
+An optional argument; it needn't necessarily be applied.
+@var{something} needn't necessarily be one thing; for example, this
+usage of it is perfectly valid:
+
+@example
+[@var{start} [@var{end}]]
+@end example
+
+@noindent
+and is indeed used quite often.
+
+@item @var{something} @dots{}
+Zero or more @var{something}s are allowed to be arguments.
+
+@item @var{something@sub{1}} @var{something@sub{2}} @dots{}
+One or more @var{something}s must be arguments.
+@end table
+
+All procedures that return bitvectors, vectors, or lists newly allocate
+their results, except those that end in @samp{!}. However, a
+zero-length value need not be separately allocated.
+
+Except as otherwise noted, the semantics of each procedure are those of
+the corresponding SRFI 133 or SRFI 151 procedure.
+
+@node SRFI 178 Bit conversion
+@subsubsection SRFI 178 Bit conversion
+
+@deffn {Scheme Procedure} bit->integer bit -> exact integer
+
+Returns 0 if @var{bit} is 0 or @code{#f} and 1 if @var{bit} is 1 or
+@code{#t}.
+@end deffn
+
+@deffn {Scheme Procedure} bit->boolean bit -> boolean
+
+Returns @code{#f} if @var{bit} is 0 or @code{#f} and @code{#t} if
+@var{bit} is 1 or @code{#t}.
+@end deffn
+
+@node SRFI 178 Constructors
+@subsubsection SRFI 178 Constructors
+
+@deffn {Scheme Procedure} make-bitvector size [bit] -> bitvector
+
+Returns a bitvector whose length is @var{size}. If @var{bit} is provided,
+all the elements of the bitvector are initialized to it.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector value @dots{} -> bitvector
+
+Returns a bitvector initialized with @var{values}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-unfold f length seed @dots{} -> bitvector
+
+Creates a vector whose length is @var{length} and iterates across each
+index @var{k} between 0 and @var{length}, applying @var{f} at each
+iteration to the current index and current states, in that order, to
+receive @var{n} + 1 values: the bit to put in the @var{k}th slot of the
+new vector and new states for the next iteration. On the first call to
+@var{f}, the states' values are the @var{seeds}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-unfold-right f length seed -> bitvector
+
+The same as @code{bitvector-unfold}, but initializes the bitvector from
+right to left.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-copy bvec [start [end]] -> bitvector
+
+Makes a copy of the portion of @var{bvec} from @var{start} to @var{end} and
+returns it.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-reverse-copy bvec [start [end]] -> bitvector
+
+The same as @code{bitvector-copy}, but in reverse order.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-append bvec @dots{} -> bitvector
+
+Returns a bitvector containing all the elements of the @var{bvecs} in
+order.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-concatenate list-of-bitvectors -> bitvector
+
+The same as @code{bitvector-append}, but takes a list of bitvectors
+rather than multiple arguments.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-append-subbitvectors [bvec start end] @dots{} -> bitvector
+
+Concatenates the result of applying @code{bitvector-copy} to each
+triplet of @var{bvec}, @var{start}, @var{end} arguments.
+@end deffn
+
+@node SRFI 178 Predicates
+@subsubsection SRFI 178 Predicates
+
+@deffn {Scheme Procedure} bitvector? obj -> boolean
+
+Returns @code{#t} if @var{obj} is a bitvector, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-empty? bvec -> boolean
+
+Returns @code{#t} if @var{bvec} has a length of zero, and @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector=? bvec @dots{} -> boolean
+
+Compares the @var{bvecs} for element-wise equality, using @code{eqv?} to
+do the comparisons, and returns @code{#t} or @code{#f} accordingly.
+@end deffn
+
+@node SRFI 178 Selectors
+@subsubsection SRFI 178 Selectors
+
+@deffn {Scheme Procedure} bitvector-ref/int bvec i -> integer
+@deffnx {Scheme Procedure} bitvector-ref/bool bvec i -> boolean
+
+Returns the @var{i}th element of @var{bvec} as an exact integer or
+boolean, respectively.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-length bvec -> exact nonnegative integer
+
+Returns the length of @var{bvec}.
+@end deffn
+
+@node SRFI 178 Iteration
+@subsubsection SRFI 178 Iteration
+
+@deffn {Scheme Procedure} bitvector-take bvec n -> bitvector
+@deffnx {Scheme Procedure} bitvector-take-right bvec n -> bitvector
+
+Returns a bitvector containing the first/last @var{n} elements of
+@var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-drop bvec n -> bitvector
+@deffnx {Scheme Procedure} bitvector-drop-right bvec n -> bitvector
+
+Returns a bitvector containing all except the first/last @var{n}
+elements of @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-segment bvec n -> list
+
+Returns a list of bitvectors, each of which contains @var{n} consecutive
+elements of @var{bvec}. The last bitvector may be shorter than @var{n}.
+It is an error if @var{n} is not an exact positive integer.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-fold/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold-right/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+@deffnx {Scheme Procedure} bitvector-fold-right/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object
+
+Folds @var{kons} over the elements of @var{bvec} in
+increasing/decreasing order using @var{knil} as the initial value. The
+kons procedure is called with the states first and the new element last,
+as in SRFIs 43, 133, and 160.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-map/int f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector
+@deffnx {Scheme Procedure} bitvector-map/bool f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector
+@deffnx {Scheme Procedure} bitvector-map!/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-map!/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-map- > list/int f bvec@sub{1} bvec@sub{2} @dots{} -> list
+@deffnx {Scheme Procedure} bitvector-map- > list/bool f bvec@sub{1} bvec@sub{2} @dots{} -> list
+@deffnx {Scheme Procedure} bitvector-for-each/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+@deffnx {Scheme Procedure} bitvector-for-each/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified
+
+Iterate over the corresponding elements of the @var{bvecs} and apply
+@var{f} to each, returning respectively: a bitvector of the results, an
+undefined value with the results placed back in @var{bvec1}, a list of
+the results, and an undefined value with no change to @var{bvec1}.
+@end deffn
+
+@node SRFI 178 Prefixes suffixes trimming padding
+@subsubsection SRFI 178 Prefixes, suffixes, trimming, padding
+
+@deffn {Scheme Procedure} bitvector-prefix-length bvec1 bvec2 -> index
+@deffnx {Scheme Procedure} bitvector-suffix-length bvec1 bvec2 -> index
+
+Return the number of elements that are equal in the prefix/suffix
+of the two @i{bvecs}, which are allowed to be of different lengths.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-prefix? bvec1 bvec2 -> boolean
+@deffnx {Scheme Procedure} bitvector-suffix? bvec1 bvec2 -> boolean
+
+Returns @code{#t} if @var{bvec1} is a prefix/suffix of @var{bvec2}, and
+@code{#f} otherwise. The arguments are allowed to be of different
+lengths.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-pad bit bvec length -> bvec
+@deffnx {Scheme Procedure} bitvector-pad-right bit bvec length -> bvec
+
+Returns a copy of @var{bvec} with leading/trailing elements equal to
+@var{bit} added (if necessary) so that the length of the result is
+@var{length}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-trim bit bvec -> bvec
+@deffnx {Scheme Procedure} bitvector-trim-right bit bvec -> bvec
+@deffnx {Scheme Procedure} bitvector-trim-both bit bvec -> bvec
+
+Returns a copy of @var{bvec} with leading/trailing/both elements equal to
+@var{bit} removed.
+@end deffn
+
+@node SRFI 178 Mutators
+@subsubsection SRFI 178 Mutators
+
+@deffn {Scheme Procedure} bitvector-set! bvec i bit -> unspecified
+
+Sets the @var{i}th element of @var{bvec} to @var{bit}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-swap! bvec i j -> unspecified
+
+Interchanges the @var{i}th and @var{j}th elements of @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-reverse! bvec [start [end]] -> unspecified
+
+Reverses the portion of @var{bvec} from @var{start} to @var{end}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-copy! to at from [start [end]] -> unspecified
+
+Copies the portion of @var{from} from @var{start} to @var{end} onto
+@var{to}, starting at index @var{at}.
+@end deffn
+
+
+@deffn {Scheme Procedure} bitvector-reverse-copy! to at from [start [end]] -> unspecified
+
+The same as @code{bitvector-copy!}, but copies in reverse.
+@end deffn
+
+@node SRFI 178 Conversion
+@subsubsection SRFI 178 Conversion
+
+@deffn {Scheme Procedure} bitvector->list/int bvec [start [end]] -> list of integers
+@deffnx {Scheme Procedure} bitvector->list/bool bvec [start [end]] -> list of booleans
+@deffnx {Scheme Procedure} reverse-bitvector->list/int bvec [start [end]] -> list of integers
+@deffnx {Scheme Procedure} reverse-bitvector->list/bool bvec [start [end]] -> list of booleans
+@deffnx {Scheme Procedure} list->bitvector list -> bitvector
+@deffnx {Scheme Procedure} reverse-list->bitvector list -> bitvector
+@deffnx {Scheme Procedure} bitvector->vector/int bvec [start [end]] -> vector of integers
+@deffnx {Scheme Procedure} bitvector->vector/bool bvec [start [end]] -> vector of booleans
+@deffnx {Scheme Procedure} reverse-bitvector->vector/int bvec [start [end]] -> vector of integers
+@deffnx {Scheme Procedure} reverse-bitvector->vector/bool bvec [start [end]] -> vector of booleans
+@deffnx {Scheme Procedure} vector->bitvector vec [start [end]] -> bitvector
+@deffnx {Scheme Procedure} reverse-vector->bitvector vec [start [end]] -> bitvector
+
+Returns a list, bitvector, or heterogeneous vector with the same
+elements as the argument, in reverse order where specified.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector->string bvec -> string
+
+Returns a string beginning with @samp{"#*"} and followed by the values
+of @var{bvec} represented as 0 and 1 characters. This is the Common
+Lisp representation of a bitvector.
+@end deffn
+
+@deffn {Scheme Procedure} string->bitvector string -> bitvector
+
+Parses a string in the format generated by @code{bitvector->string} and
+returns the corresponding bitvector, or @code{#f} if the string is not
+in this format.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector->integer bitvector
+
+Returns a non-negative exact integer whose bits, starting with the least
+significant bit as bit 0, correspond to the values in @var{bitvector}.
+This ensures compatibility with the integers-as-bits operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}.
+@end deffn
+
+@deffn {Scheme Procedure} integer->bitvector integer [len]
+
+Returns a bitvector whose length is @var{len} whose values correspond to
+the bits of @var{integer}, a non-negative exact integer, starting with
+the least significant bit as bit 0. This ensures compatibility with the
+integers-as-bits operations of
+@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}
+
+The default value of @var{len} is @samp{(integer-length @var{integer})}.
+If the value of @var{len} is less than the default, the resulting
+bitvector cannot be converted back by @code{bitvector->integer}
+correctly.
+@end deffn
+
+@node SRFI 178 Generators
+@subsubsection SRFI 178 Generators
+
+@deffn {Scheme Procedure} make-bitvector/int-generator bitvector
+@deffnx {Scheme Procedure} make-bitvector/bool-generator bitvector
+
+Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI
+158} generator that generates all the values of @var{bitvector} in
+order. Note that the generator is finite.
+@end deffn
+
+@deffn {Scheme Procedure} make-bitvector-accumulator
+
+Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI
+158} accumulator that collects all the bits it is invoked on. When
+invoked on an end-of-file object, returns a bitvector containing all the
+bits in order.
+@end deffn
+
+@node SRFI 178 Basic operations
+@subsubsection SRFI 178 Basic operations
+
+@deffn {Scheme Procedure} bitvector-not bvec
+@deffnx {Scheme Procedure} bitvector-not! bvec
+
+Returns the element-wise complement of @var{bvec}; that is, each value
+is changed to the opposite value.
+@end deffn
+
+The following ten procedures correspond to the useful set of non-trivial
+two-argument boolean functions. For each such function, the
+corresponding bitvector operator maps that function across two or more
+bitvectors in an element-wise fashion. The core idea of this group of
+functions is this element-wise "lifting" of the set of dyadic boolean
+functions to bitvector parameters.
+
+@deffn {Scheme Procedure} bitvector-and bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-and! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-ior bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-ior! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-xor bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-xor! bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-eqv bvec1 bvec2 bvec @dots{}
+@deffnx {Scheme Procedure} bitvector-eqv! bvec1 bvec2 bvec @dots{}
+
+These operations are associative.
+
+The @code{bitvector-eqv} procedure produces the complement of the
+@code{bitvector-xor} procedure. When applied to three arguments, it
+does @emph{not} produce a @code{#t} value everywhere that @var{a},
+@var{b} and @var{c} all agree. That is, it does @emph{not} produce:
+
+@lisp
+ (bitvector-ior (bitvector-and a b c)
+ (bitvector-and (bitvector-not a)
+ (bitvector-not b)
+ (bitvector-not c)))
+@end lisp
+
+Rather, it produces @samp{(bitvector-eqv @var{a} (bitvector-eqv @var{b}
+@var{c}))} or the equivalent @samp{(bitvector-eqv (bitvector-eqv @var{a}
+@var{b}) @var{c})}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-nand bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nand! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nor bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-nor! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc1 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc1! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc2 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-andc2! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc1 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc1! bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc2 bvec1 bvec2
+@deffnx {Scheme Procedure} bitvector-orc2! bvec1 bvec2
+
+These operations are not associative.
+@end deffn
+
+@node SRFI 178 Quasi-integer operations
+@subsubsection SRFI 178 Quasi-integer operations
+
+@deffn {Scheme Procedure} bitvector-logical-shift bvec count bit
+
+Returns a bitvector equal in length to @var{bvec} containing the logical
+left shift (toward lower indices) when @var{count}>=0 or the right shift
+(toward upper indices) when @var{count}<0. Newly vacated elements are
+filled with @var{bit}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-count bit bvec
+
+Returns the number of @var{bit} values in @var{bvec}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-count-run bit bvec i
+
+Returns the number of consecutive @var{bit} values in @var{bvec},
+starting at index @var{i}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-if if-bitvector then-bitvector else-bitvector
+
+Returns a bitvector that merges the bitvectors @var{then-bitvector} and
+@var{else-bitvector}, with the bitvector @var{if-bitvector} determining
+from which bitvector to take each value. That is, if the @var{k}th
+value of @var{if-bitvector} is @code{#t} (or 1, depending in how you
+look at it), then the @var{k}th bit of the result is the @var{k}th bit
+of @var{then-bitvector}, otherwise the @var{k}th bit of
+@var{else-bitvector}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-first-bit bit bvec
+
+Return the index of the first (smallest index) @var{bit} value in
+@var{bvec}. Return @code{-1} if @var{bvec} contains no values equal to
+@var{bit}.
+@end deffn
+
+@node SRFI 178 Bit field operations
+@subsubsection SRFI 178 Bit field operations
+
+These procedures operate on a contiguous field of bits (a "byte" in
+Common Lisp parlance) in a given bitvector. The @var{start} and
+@var{end} arguments, which are not optional, are non-negative exact
+integers specifying the field: it is the @var{end} --- @var{start} bits
+running from bit @var{start} to bit @samp{@var{end} - 1}.
+
+@deffn {Scheme Procedure} bitvector-field-any? bvec start end
+
+Returns @code{#t} if any of the field's bits are set in @var{bvec}, and
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-every? bvec start end
+
+Returns @code{#f} if any of the field's bits are not set in @var{bvec},
+and @code{#t} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-clear bvec start end
+@deffnx {Scheme Procedure} bitvector-field-clear! bvec start end
+@deffnx {Scheme Procedure} bitvector-field-set bvec start end
+@deffnx {Scheme Procedure} bitvector-field-set! bvec start end
+
+Returns a bitvector containing @var{bvec} with the field's bits set
+appropriately.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-replace dest source start end
+@deffnx {Scheme Procedure} bitvector-field-replace! dest source start end
+
+Returns a bitvector containing @var{dest} with the field replaced by the
+first @var{end-start} bits in @var{source}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-replace-same dest source start end
+@deffnx {Scheme Procedure} bitvector-field-replace-same! dest source start end
+
+Returns a bitvector containing @var{dest} with its field replaced by
+the corresponding field in @var{source}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-rotate bvec count start end
+
+Returns @var{bvec} with the field cyclically permuted by @var{count}
+bits towards higher indices when @var{count} is negative, and toward
+lower indices otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-field-flip bvec start end
+@deffnx {Scheme Procedure} bitvector-field-flip! bvec start end
+
+Returns @var{bvec} with the bits in the field flipped: that is, each
+value is replaced by the opposite value. There is no SRFI 151
+equivalent.
+@end deffn
+
+@node SRFI 178 Bitvector literals
+@subsubsection SRFI 178 Bitvector literals
+
+The compact string representation used by @code{bitvector->string} and
+@code{string->bitvector} may be supported by the standard @code{read}
+and @code{write} procedures and by the program parser, so that programs
+can contain references to literal bitvectors. On input, it is an error
+if such a literal is not followed by a <delimiter> or the end of input.
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/module/srfi/srfi-178.sld b/module/srfi/srfi-178.sld
new file mode 100644
index 000000000..e0d991ee7
--- /dev/null
+++ b/module/srfi/srfi-178.sld
@@ -0,0 +1,105 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define-library (srfi 178)
+ (import (scheme base))
+ (import (scheme case-lambda))
+ (import (srfi 151))
+ (import (srfi 160 u8))
+
+ (cond-expand
+ ((library (srfi 133))
+ (import (only (srfi 133) vector-unfold)))
+ (else
+ (begin
+ ;; The "seedless" case is all we need.
+ (define (vector-unfold f len)
+ (let ((res (make-vector len)))
+ (let lp ((i 0))
+ (cond ((= i len) res)
+ (else (vector-set! res i (f i))
+ (lp (+ i 1))))))))))
+
+ (export bit->integer bit->boolean ; Bit conversion
+
+ ;; Constructors
+ make-bitvector bitvector bitvector-unfold
+ bitvector-unfold-right bitvector-copy
+ bitvector-reverse-copy bitvector-append bitvector-concatenate
+ bitvector-append-subbitvectors
+
+ ;; Predicates
+ bitvector? bitvector-empty? bitvector=?
+
+ ;; Selectors
+ bitvector-ref/int bitvector-ref/bool bitvector-length
+
+ ;; Iteration
+ bitvector-take bitvector-take-right
+ bitvector-drop bitvector-drop-right bitvector-segment
+ bitvector-fold/int bitvector-fold/bool bitvector-fold-right/int
+ bitvector-fold-right/bool bitvector-map/int bitvector-map/bool
+ bitvector-map!/int bitvector-map!/bool bitvector-map->list/int
+ bitvector-map->list/bool bitvector-for-each/int
+ bitvector-for-each/bool
+
+ ;; Prefixes, suffixes, trimming, padding
+ bitvector-prefix-length
+ bitvector-suffix-length bitvector-prefix? bitvector-suffix?
+ bitvector-pad bitvector-pad-right bitvector-trim
+ bitvector-trim-right bitvector-trim-both
+
+ ;; Mutators
+ bitvector-set!
+ bitvector-swap! bitvector-reverse!
+ bitvector-copy! bitvector-reverse-copy!
+
+ ;; Conversion
+ bitvector->list/int
+ bitvector->list/bool reverse-bitvector->list/int
+ reverse-bitvector->list/bool list->bitvector
+ reverse-list->bitvector bitvector->vector/int
+ bitvector->vector/bool vector->bitvector bitvector->string
+ string->bitvector bitvector->integer integer->bitvector
+ reverse-vector->bitvector reverse-bitvector->vector/int
+ reverse-bitvector->vector/bool
+
+ ;; Generators and accumulators
+ make-bitvector/int-generator make-bitvector/bool-generator
+ make-bitvector-accumulator
+
+ ;; Basic operations
+ bitvector-not bitvector-not!
+ bitvector-and bitvector-and! bitvector-ior bitvector-ior!
+ bitvector-xor bitvector-xor! bitvector-eqv bitvector-eqv!
+ bitvector-nand bitvector-nand! bitvector-nor bitvector-nor!
+ bitvector-andc1 bitvector-andc1! bitvector-andc2
+ bitvector-andc2! bitvector-orc1 bitvector-orc1!
+ bitvector-orc2 bitvector-orc2!
+
+ ;; Quasi-integer operations
+ bitvector-logical-shift
+ bitvector-count bitvector-if
+ bitvector-first-bit bitvector-count-run
+
+ ;; Bit field operations
+ bitvector-field-any? bitvector-field-every?
+ bitvector-field-clear bitvector-field-clear!
+ bitvector-field-set bitvector-field-set!
+ bitvector-field-replace-same bitvector-field-replace-same!
+ bitvector-field-rotate bitvector-field-flip
+ bitvector-field-flip!
+ bitvector-field-replace bitvector-field-replace!
+ )
+
+ (include "srfi-178/macros.scm")
+ (include "srfi-178/convert.scm")
+ (include "srfi-178/fields.scm")
+ (include "srfi-178/gen-acc.scm")
+ (include "srfi-178/logic-ops.scm")
+ (include "srfi-178/map2list.scm")
+ (include "srfi-178/quasi-ints.scm")
+ (include "srfi-178/quasi-strs.scm")
+ (include "srfi-178/unfolds.scm")
+ (include "srfi-178/wrappers.scm")
+)
diff --git a/module/srfi/srfi-178/convert.scm b/module/srfi/srfi-178/convert.scm
new file mode 100644
index 000000000..86f61b950
--- /dev/null
+++ b/module/srfi/srfi-178/convert.scm
@@ -0,0 +1,83 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; Bit conversions
+
+(define (bit->integer bit) (I bit))
+
+(define (bit->boolean bit) (B bit))
+
+(define (bitvector->string bvec)
+ (let loop ((i (- (bitvector-length bvec) 1))
+ (r '()))
+ (if (< i 0)
+ (list->string (cons #\# (cons #\* r)))
+ (loop (- i 1)
+ (cons (if (bitvector-ref/bool bvec i) #\1 #\0) r)))))
+
+(define (string->bitvector str)
+ (call/cc
+ (lambda (return)
+ (and
+ (> (string-length str) 1)
+ (char=? (string-ref str 0) #\#)
+ (char=? (string-ref str 1) #\*)
+ (bitvector-unfold
+ (lambda (ri si)
+ (case (string-ref str si)
+ ((#\0) (values 0 (+ si 1)))
+ ((#\1) (values 1 (+ si 1)))
+ (else (return #f))))
+ (- (string-length str) 2)
+ 2)))))
+
+;;;; Bitvector/integer conversions
+
+(define (bitvector->integer bvec)
+ (bitvector-fold-right/int (lambda (r b) (+ (* r 2) b)) 0 bvec))
+
+(define integer->bitvector
+ (case-lambda
+ ((int) (integer->bitvector int (integer-length int)))
+ ((int len)
+ (bitvector-unfold
+ (lambda (_ int)
+ (values (bit-set? 0 int) (arithmetic-shift int -1)))
+ len
+ int))))
+
+;;; Additional vector conversions
+
+(define reverse-vector->bitvector
+ (case-lambda
+ ((vec) (reverse-vector->bitvector vec 0 (vector-length vec)))
+ ((vec start) (reverse-vector->bitvector vec start (vector-length vec)))
+ ((vec start end)
+ (bitvector-unfold
+ (lambda (i)
+ (vector-ref vec (- end 1 i)))
+ (- end start)))))
+
+(define reverse-bitvector->vector/int
+ (case-lambda
+ ((bvec)
+ (reverse-bitvector->vector/int bvec 0 (bitvector-length bvec)))
+ ((bvec start)
+ (reverse-bitvector->vector/int bvec start (bitvector-length bvec)))
+ ((bvec start end)
+ (let ((u8vec (U bvec)))
+ (vector-unfold (lambda (i)
+ (u8vector-ref u8vec (- end 1 i)))
+ (- end start))))))
+
+(define reverse-bitvector->vector/bool
+ (case-lambda
+ ((bvec)
+ (reverse-bitvector->vector/bool bvec 0 (bitvector-length bvec)))
+ ((bvec start)
+ (reverse-bitvector->vector/bool bvec start (bitvector-length bvec)))
+ ((bvec start end)
+ (let ((u8vec (U bvec)))
+ (vector-unfold (lambda (i)
+ (B (u8vector-ref u8vec (- end 1 i))))
+ (- end start))))))
diff --git a/module/srfi/srfi-178/fields.scm b/module/srfi/srfi-178/fields.scm
new file mode 100644
index 000000000..e2c172e0e
--- /dev/null
+++ b/module/srfi/srfi-178/fields.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-field-any? bvec start end)
+ (let lp ((i start))
+ (and (< i end)
+ (or (bitvector-ref/bool bvec i)
+ (lp (+ i 1))))))
+
+(define (bitvector-field-every? bvec start end)
+ (let lp ((i start))
+ (or (>= i end)
+ (and (bitvector-ref/bool bvec i)
+ (lp (+ i 1))))))
+
+(define (%bitvector-field-modify bvec bit start end)
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ bit
+ (bitvector-ref/int bvec i)))
+ (bitvector-length bvec)))
+
+(define (bitvector-field-clear bvec start end)
+ (%bitvector-field-modify bvec 0 start end))
+
+(define (%bitvector-fill!/int bvec int start end)
+ (u8vector-fill! (U bvec) int start end))
+
+(define (bitvector-field-clear! bvec start end)
+ (%bitvector-fill!/int bvec 0 start end))
+
+(define (bitvector-field-set bvec start end)
+ (%bitvector-field-modify bvec 1 start end))
+
+(define (bitvector-field-set! bvec start end)
+ (%bitvector-fill!/int bvec 1 start end))
+
+(define (bitvector-field-replace dest source start end)
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ (bitvector-ref/int source (- i start))
+ (bitvector-ref/int dest i)))
+ (bitvector-length dest)))
+
+(define (bitvector-field-replace! dest source start end)
+ (bitvector-copy! dest start source 0 (- end start)))
+
+(define (bitvector-field-replace-same dest source start end)
+ (bitvector-unfold
+ (lambda (i)
+ (bitvector-ref/int (if (and (>= i start) (< i end))
+ source
+ dest)
+ i))
+ (bitvector-length dest)))
+
+(define (bitvector-field-replace-same! dest source start end)
+ (bitvector-copy! dest start source start end))
+
+(define (bitvector-field-rotate bvec count start end)
+ (if (zero? count)
+ bvec
+ (let ((field-len (- end start)))
+ (bitvector-unfold
+ (lambda (i)
+ (if (and (>= i start) (< i end))
+ (bitvector-ref/int
+ bvec
+ (+ start (floor-remainder (+ (- i start) count) field-len)))
+ (bitvector-ref/int bvec i)))
+ (bitvector-length bvec)))))
+
+(define (bitvector-field-flip bvec start end)
+ (bitvector-unfold
+ (lambda (i)
+ (I (if (and (>= i start) (< i end))
+ (not (bitvector-ref/bool bvec i))
+ (bitvector-ref/bool bvec i))))
+ (bitvector-length bvec)))
+
+(define (bitvector-field-flip! bvec start end)
+ (let lp ((i start))
+ (unless (>= i end)
+ (bitvector-set! bvec i (not (bitvector-ref/bool bvec i)))
+ (lp (+ i 1)))))
+
diff --git a/module/srfi/srfi-178/gen-acc.scm b/module/srfi/srfi-178/gen-acc.scm
new file mode 100644
index 000000000..863f5358c
--- /dev/null
+++ b/module/srfi/srfi-178/gen-acc.scm
@@ -0,0 +1,25 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (%make-bitvector-generator bvec ref-proc)
+ (let ((len (bitvector-length bvec))
+ (i 0))
+ (lambda ()
+ (if (= i len)
+ (eof-object)
+ (let ((r (ref-proc bvec i)))
+ (set! i (+ i 1))
+ r)))))
+
+(define (make-bitvector/int-generator bvec)
+ (%make-bitvector-generator bvec bitvector-ref/int))
+
+(define (make-bitvector/bool-generator bvec)
+ (%make-bitvector-generator bvec bitvector-ref/bool))
+
+(define (make-bitvector-accumulator)
+ (let ((r '()))
+ (lambda (x)
+ (if (eof-object? x)
+ (reverse-list->bitvector r)
+ (set! r (cons x r))))))
diff --git a/module/srfi/srfi-178/logic-ops.scm b/module/srfi/srfi-178/logic-ops.scm
new file mode 100644
index 000000000..b14b357da
--- /dev/null
+++ b/module/srfi/srfi-178/logic-ops.scm
@@ -0,0 +1,105 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (u1-not a)
+ (- 1 a))
+
+(define (bitvector-not avec)
+ (bitvector-map/int u1-not avec))
+
+(define (bitvector-not! avec)
+ (bitvector-map!/int u1-not avec))
+
+(define (u1-and . args)
+ (I (apply * args)))
+
+(define (bitvector-and . vecs)
+ (apply bitvector-map/int u1-and vecs))
+
+(define (bitvector-and! . vecs)
+ (apply bitvector-map!/int u1-and vecs))
+
+(define (u1-ior . args)
+ (I (apply + args)))
+
+(define (bitvector-ior . vecs)
+ (apply bitvector-map/int u1-ior vecs))
+
+(define (bitvector-ior! . vecs)
+ (apply bitvector-map!/int u1-ior vecs))
+
+(define (u1-xor . args)
+ (I (odd? (apply + args))))
+
+(define (bitvector-xor . vecs)
+ (apply bitvector-map/int u1-xor vecs))
+
+(define (bitvector-xor! . vecs)
+ (apply bitvector-map!/int u1-xor vecs))
+
+(define (u1-eqv . args)
+ (let ((xor-value (apply u1-xor args)))
+ (if (odd? (length args))
+ xor-value
+ (u1-not xor-value))))
+
+(define (bitvector-eqv . vecs)
+ (apply bitvector-map/int u1-eqv vecs))
+
+(define (bitvector-eqv! . vecs)
+ (apply bitvector-map!/int u1-eqv vecs))
+
+(define (u1-nand a b)
+ (u1-not (u1-and a b)))
+
+(define (bitvector-nand a b)
+ (bitvector-map/int u1-nand a b))
+
+(define (bitvector-nand! a b)
+ (bitvector-map!/int u1-nand a b))
+
+(define (u1-nor a b)
+ (u1-not (u1-ior a b)))
+
+(define (bitvector-nor a b)
+ (bitvector-map/int u1-nor a b))
+
+(define (bitvector-nor! a b)
+ (bitvector-map!/int u1-nor a b))
+
+(define (u1-andc1 a b)
+ (u1-and (u1-not a) b))
+
+(define (bitvector-andc1 a b)
+ (bitvector-map/int u1-andc1 a b))
+
+(define (bitvector-andc1! a b)
+ (bitvector-map!/int u1-andc1 a b))
+
+(define (u1-andc2 a b)
+ (u1-and a (u1-not b)))
+
+(define (bitvector-andc2 a b)
+ (bitvector-map/int u1-andc2 a b))
+
+(define (bitvector-andc2! a b)
+ (bitvector-map!/int u1-andc2 a b))
+
+(define (u1-orc1 a b)
+ (u1-ior (u1-not a) b))
+
+(define (bitvector-orc1 a b)
+ (bitvector-map/int u1-orc1 a b))
+
+(define (bitvector-orc1! a b)
+ (bitvector-map!/int u1-orc1 a b))
+
+(define (u1-orc2 a b)
+ (u1-ior a (u1-not b)))
+
+(define (bitvector-orc2 a b)
+ (bitvector-map/int u1-orc2 a b))
+
+(define (bitvector-orc2! a b)
+ (bitvector-map!/int u1-orc2 a b))
+
diff --git a/module/srfi/srfi-178/macros.scm b/module/srfi/srfi-178/macros.scm
new file mode 100644
index 000000000..9e5900512
--- /dev/null
+++ b/module/srfi/srfi-178/macros.scm
@@ -0,0 +1,26 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;;; SRFI 178 macros for internal use
+
+;;; Bitvector type definition
+;;; W wraps a u8vector as a bitvector, U unwraps it again
+
+(define-record-type <bitvector>
+ (W u8vec)
+ bitvector?
+ (u8vec U))
+
+;; Convert a bit to an integer
+(define-syntax I
+ (syntax-rules ()
+ ((I bit)
+ (cond
+ ((eqv? bit 0) 0)
+ ((not bit) 0)
+ (else 1)))))
+
+;; Convert a bit to a bool
+(define-syntax B
+ (syntax-rules ()
+ ((B bit) (not (or (eqv? bit 0) (not bit))))))
diff --git a/module/srfi/srfi-178/map2list.scm b/module/srfi/srfi-178/map2list.scm
new file mode 100644
index 000000000..7118f59cc
--- /dev/null
+++ b/module/srfi/srfi-178/map2list.scm
@@ -0,0 +1,27 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define bitvector-map->list/int
+ (case-lambda
+ ((f bvec) ; fast path
+ (bitvector-fold-right/int (lambda (xs b) (cons (f b) xs))
+ '()
+ bvec))
+ ((f . bvecs)
+ (apply bitvector-fold-right/int
+ (lambda (xs . bs) (cons (apply f bs) xs))
+ '()
+ bvecs))))
+
+(define bitvector-map->list/bool
+ (case-lambda
+ ((f bvec) ; fast path
+ (bitvector-fold-right/bool (lambda (xs b) (cons (f b) xs))
+ '()
+ bvec))
+ ((f . bvecs)
+ (apply bitvector-fold-right/bool
+ (lambda (xs . bs) (cons (apply f bs) xs))
+ '()
+ bvecs))))
+
diff --git a/module/srfi/srfi-178/quasi-ints.scm b/module/srfi/srfi-178/quasi-ints.scm
new file mode 100644
index 000000000..f66e4ee27
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-ints.scm
@@ -0,0 +1,54 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-logical-shift bvec count bit)
+ (cond ((positive? count)
+ (%bitvector-left-shift bvec count (I bit)))
+ ((negative? count)
+ (%bitvector-right-shift bvec (- count) (I bit)))
+ (else bvec)))
+
+(define (%bitvector-left-shift bvec count bit)
+ (let ((len (bitvector-length bvec)))
+ (bitvector-unfold
+ (lambda (i)
+ (let ((i* (+ i count)))
+ (if (< i* len) (bitvector-ref/int bvec i*) bit)))
+ len)))
+
+(define (%bitvector-right-shift bvec count bit)
+ (bitvector-unfold
+ (lambda (i)
+ (if (< i count)
+ bit
+ (bitvector-ref/int bvec (- i count))))
+ (bitvector-length bvec)))
+
+(define (bitvector-count bit bvec)
+ (let ((int (I bit)))
+ (bitvector-fold/int (lambda (n b) (if (= b int) (+ n 1) n))
+ 0
+ bvec)))
+
+(define (bitvector-count-run bit bvec index)
+ (let ((int (I bit))
+ (len (bitvector-length bvec)))
+ (let lp ((i index) (c 0))
+ (if (or (>= i len) (not (= int (bitvector-ref/int bvec i))))
+ c
+ (lp (+ i 1) (+ c 1))))))
+
+(define (bitvector-if if-bvec then-bvec else-bvec)
+ (bitvector-map/bool (lambda (bit then-bit else-bit)
+ (if bit then-bit else-bit))
+ if-bvec
+ then-bvec
+ else-bvec))
+
+(define (bitvector-first-bit bit bvec)
+ (let ((int (I bit)) (len (bitvector-length bvec)))
+ (let lp ((i 0))
+ (cond ((>= i len) -1)
+ ((= int (bitvector-ref/int bvec i)) i)
+ (else (lp (+ i 1)))))))
+
diff --git a/module/srfi/srfi-178/quasi-strs.scm b/module/srfi/srfi-178/quasi-strs.scm
new file mode 100644
index 000000000..2d63b43ad
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-strs.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (bitvector-prefix-length bvec1 bvec2)
+ (let ((end (min (bitvector-length bvec1) (bitvector-length bvec2))))
+ (if (eqv? bvec1 bvec2)
+ end
+ (let lp ((i 0))
+ (if (or (>= i end)
+ (not (= (bitvector-ref/int bvec1 i)
+ (bitvector-ref/int bvec2 i))))
+ i
+ (lp (+ i 1)))))))
+
+(define (bitvector-suffix-length bvec1 bvec2)
+ (let ((end1 (bitvector-length bvec1))
+ (end2 (bitvector-length bvec2)))
+ (let* ((delta (min end1 end2))
+ (start (- end1 delta)))
+ (if (eqv? bvec1 bvec2)
+ delta
+ (let lp ((i (- end1 1)) (j (- end2 1)))
+ (if (or (< i start)
+ (not (= (bitvector-ref/int bvec1 i)
+ (bitvector-ref/int bvec2 j))))
+ (- (- end1 i) 1)
+ (lp (- i 1) (- j 1))))))))
+
+(define (bitvector-prefix? bvec1 bvec2)
+ (let ((len1 (bitvector-length bvec1)))
+ (and (<= len1 (bitvector-length bvec2))
+ (= (bitvector-prefix-length bvec1 bvec2) len1))))
+
+(define (bitvector-suffix? bvec1 bvec2)
+ (let ((len1 (bitvector-length bvec1)))
+ (and (<= len1 (bitvector-length bvec2))
+ (= (bitvector-suffix-length bvec1 bvec2) len1))))
+
+(define (bitvector-pad bit bvec len)
+ (let ((old-len (bitvector-length bvec)))
+ (if (<= len old-len)
+ bvec
+ (let ((result (make-bitvector len bit)))
+ (bitvector-copy! result (- len old-len) bvec)
+ result))))
+
+(define (bitvector-pad-right bit bvec len)
+ (if (<= len (bitvector-length bvec))
+ bvec
+ (let ((result (make-bitvector len bit)))
+ (bitvector-copy! result 0 bvec)
+ result)))
+
+(define (%bitvector-skip bvec bit)
+ (let ((len (bitvector-length bvec))
+ (int (bit->integer bit)))
+ (let lp ((i 0))
+ (and (< i len)
+ (if (= int (bitvector-ref/int bvec i))
+ (lp (+ i 1))
+ i)))))
+
+(define (%bitvector-skip-right bvec bit)
+ (let ((len (bitvector-length bvec))
+ (int (bit->integer bit)))
+ (let lp ((i (- len 1)))
+ (and (>= i 0)
+ (if (= int (bitvector-ref/int bvec i))
+ (lp (- i 1))
+ i)))))
+
+(define (bitvector-trim bit bvec)
+ (cond ((%bitvector-skip bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec skip (bitvector-length bvec))))
+ (else (bitvector))))
+
+(define (bitvector-trim-right bit bvec)
+ (cond ((%bitvector-skip-right bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec 0 (+ skip 1))))
+ (else (bitvector))))
+
+(define (bitvector-trim-both bit bvec)
+ (cond ((%bitvector-skip bvec bit) =>
+ (lambda (skip)
+ (bitvector-copy bvec skip (+ 1 (%bitvector-skip-right bvec bit)))))
+ (else (bitvector))))
diff --git a/module/srfi/srfi-178/unfolds.scm b/module/srfi/srfi-178/unfolds.scm
new file mode 100644
index 000000000..fa5956926
--- /dev/null
+++ b/module/srfi/srfi-178/unfolds.scm
@@ -0,0 +1,44 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; unfold
+
+;;; These procedures work by building temporary lists, then converting
+;;; them to vectors. This uses more space than pre-allocating a bitvector
+;;; and filling it, but it's referentially transparent: there's no way
+;;; to capture a partially-filled bitvector through continuation tricks.
+
+;; Unfold a list. f is passed the current index and list of seeds
+;; on each step, and must return a bit and new seeds on each step.
+(define (%unfold/index f len seeds)
+ (letrec
+ ((build
+ (lambda (i seeds)
+ (if (= i len)
+ '()
+ (let-values (((b . seeds*) (apply f i seeds)))
+ (cons b (build (+ i 1) seeds*)))))))
+
+ (build 0 seeds)))
+
+(define (bitvector-unfold f len . seeds)
+ (list->bitvector (%unfold/index f len seeds)))
+
+;;;; unfold-right
+
+;; Unfold a list from the right. f is passed the current index and
+;; list of seeds on each step, and must return a bit and new seeds
+;; on each step.
+(define (%unfold-right/index f len seeds)
+ (letrec
+ ((build
+ (lambda (i seeds res)
+ (if (< i 0)
+ res
+ (let-values (((b . seeds*) (apply f i seeds)))
+ (build (- i 1) seeds* (cons b res)))))))
+
+ (build (- len 1) seeds '())))
+
+(define (bitvector-unfold-right f len . seeds)
+ (list->bitvector (%unfold-right/index f len seeds)))
diff --git a/module/srfi/srfi-178/wrappers.scm b/module/srfi/srfi-178/wrappers.scm
new file mode 100644
index 000000000..bb439dd12
--- /dev/null
+++ b/module/srfi/srfi-178/wrappers.scm
@@ -0,0 +1,285 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+;;;; SRFI 178 procedures that are just wrappers
+
+(define make-bitvector
+ (case-lambda
+ ((size) (W (make-u8vector size)))
+ ((size bit) (W (make-u8vector size (I bit))))))
+
+(define bitvector-copy
+ (case-lambda
+ ((bvec) (W (u8vector-copy (U bvec))))
+ ((bvec start) (W (u8vector-copy (U bvec) start)))
+ ((bvec start end) (W (u8vector-copy (U bvec) start end)))))
+
+(define bitvector-reverse-copy
+ (case-lambda
+ ((bvec) (W (u8vector-reverse-copy (U bvec))))
+ ((bvec start) (W (u8vector-reverse-copy (U bvec) start)))
+ ((bvec start end) (W (u8vector-reverse-copy (U bvec) start end)))))
+
+(define (bitvector-append . bvecs)
+ (bitvector-concatenate bvecs))
+
+(define (bitvector-concatenate bvecs)
+ (W (u8vector-concatenate (map U bvecs))))
+
+(define (bitvector-append-subbitvectors . args)
+ (W (apply u8vector-append-subvectors
+ (map (lambda (x) (if (bitvector? x) (U x) x)) args))))
+
+(define (bitvector-empty? bvec)
+ (eqv? 0 (u8vector-length (U bvec))))
+
+(define (bitvector=? . bvecs)
+ (apply u8vector= (map U bvecs)))
+
+(define (bitvector-ref/int bvec i)
+ (u8vector-ref (U bvec) i))
+
+(define (bitvector-ref/bool bvec i)
+ (B (u8vector-ref (U bvec) i)))
+
+(define (bitvector-length bvec)
+ (u8vector-length (U bvec)))
+
+(define (bitvector-take bvec n)
+ (W (u8vector-take (U bvec) n)))
+
+(define (bitvector-take-right bvec n)
+ (W (u8vector-take-right (U bvec) n)))
+
+(define (bitvector-drop bvec n)
+ (W (u8vector-drop (U bvec) n)))
+
+(define (bitvector-drop-right bvec n)
+ (W (u8vector-drop-right (U bvec) n)))
+
+(define (bitvector-segment bvec n)
+ (unless (and (integer? n) (positive? n))
+ (error "bitvector-segment: not a positive integer" n))
+ (map W (u8vector-segment (U bvec) n)))
+
+(define bitvector-fold/int
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold kons knil (U bvec))) ; fast path
+ ((kons knil . bvecs)
+ (apply u8vector-fold kons knil (map U bvecs)))))
+
+(define bitvector-fold/bool
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold (lambda (x b) (kons x (B b))) ; fast path
+ knil
+ (U bvec)))
+ ((kons knil . bvecs)
+ (apply u8vector-fold
+ (lambda (x . bits)
+ (apply kons x (map bit->boolean bits)))
+ knil
+ (map U bvecs)))))
+
+(define bitvector-fold-right/int
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold-right kons knil (U bvec))) ; fast path
+ ((kons knil . bvecs)
+ (apply u8vector-fold-right kons knil (map U bvecs)))))
+
+(define bitvector-fold-right/bool
+ (case-lambda
+ ((kons knil bvec)
+ (u8vector-fold-right (lambda (x bit) (kons x (B bit))) ; fast path
+ knil
+ (U bvec)))
+ ((kons knil . bvecs)
+ (apply u8vector-fold-right
+ (lambda (x . bits)
+ (apply kons x (map bit->boolean bits)))
+ knil
+ (map U bvecs)))))
+
+(define bitvector-map/int
+ (case-lambda
+ ((f bvec)
+ (W (u8vector-map f (U bvec)))) ; one-bitvector fast path
+ ((f bvec1 bvec2)
+ (%bitvector-map2/int f bvec1 bvec2)) ; two-bitvector fast path
+ ((f . bvecs)
+ (W (apply u8vector-map f (map U bvecs)))))) ; normal path
+
+;; Tuned two-bitvector version, mainly for binary logical ops.
+(define (%bitvector-map2/int f bvec1 bvec2)
+ (let ((u8vec1 (U bvec1))
+ (u8vec2 (U bvec2)))
+ (bitvector-unfold
+ (lambda (i)
+ (f (u8vector-ref u8vec1 i) (u8vector-ref u8vec2 i)))
+ (bitvector-length bvec1))))
+
+(define bitvector-map/bool
+ (case-lambda
+ ((f bvec) ; one-bitvector fast path
+ (W (u8vector-map (lambda (n) (I (f (B n)))) (U bvec))))
+ ((f bvec1 bvec2) ; two-bitvector fast path
+ (%bitvector-map2/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2))
+ ((f . bvecs) ; normal path (ugh)
+ (W (apply u8vector-map
+ (lambda ns (I (apply f (map bit->boolean ns))))
+ (map U bvecs))))))
+
+(define bitvector-map!/int
+ (case-lambda
+ ((f bvec)
+ (u8vector-map! f (U bvec))) ; one-bitvector fast path
+ ((f bvec1 bvec2)
+ (%bitvector-map2!/int f bvec1 bvec2)) ; two-bitvector fast path
+ ((f . bvecs)
+ (apply u8vector-map! f (map U bvecs))))) ; normal path
+
+;; Tuned two-bitvector version, mainly for binary logical ops.
+(define (%bitvector-map2!/int f bvec1 bvec2)
+ (let ((len (bitvector-length bvec1))
+ (u8vec1 (U bvec1))
+ (u8vec2 (U bvec2)))
+ (let lp ((i 0))
+ (unless (>= i len)
+ (u8vector-set! u8vec1 i (f (u8vector-ref u8vec1 i)
+ (u8vector-ref u8vec2 i)))
+ (lp (+ i 1))))
+ bvec1))
+
+(define bitvector-map!/bool
+ (case-lambda
+ ((f bvec) ; one-bitvector fast path
+ (u8vector-map! (lambda (n) (I (f (B n)))) (U bvec)))
+ ((f bvec1 bvec2) ; two-bitvector fast path
+ (%bitvector-map2!/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2))
+ ((f . bvecs) ; normal path (ugh)
+ (apply u8vector-map!
+ (lambda ns (I (apply f (map bit->boolean ns))))
+ (map U bvecs)))))
+
+(define bitvector-for-each/int
+ (case-lambda
+ ((f bvec)
+ (u8vector-for-each f (U bvec))) ; fast path
+ ((f . bvecs)
+ (apply u8vector-for-each f (map U bvecs)))))
+
+(define bitvector-for-each/bool
+ (case-lambda
+ ((f bvec)
+ (u8vector-for-each (lambda (n) (f (B n))) (U bvec))) ; fast path
+ ((f . bvecs)
+ (apply u8vector-for-each
+ (lambda ns (apply f (map bit->boolean ns)))
+ (map U bvecs)))))
+
+(define (bitvector-set! bvec i bit)
+ (u8vector-set! (U bvec) i (I bit)))
+
+(define (bitvector-swap! bvec i j)
+ (u8vector-swap! (U bvec) i j))
+
+
+(define bitvector-reverse!
+ (case-lambda
+ ((bvec)
+ (u8vector-reverse! (U bvec)))
+ ((bvec start)
+ (u8vector-reverse! (U bvec) start))
+ ((bvec start end)
+ (u8vector-reverse! (U bvec) start end))))
+
+(define bitvector-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-copy! (U to) at (U from)))
+ ((to at from start)
+ (u8vector-copy! (U to) at (U from) start))
+ ((to at from start end)
+ (u8vector-copy! (U to) at (U from) start end))))
+
+(define bitvector-reverse-copy!
+ (case-lambda
+ ((to at from)
+ (u8vector-reverse-copy! (U to) at (U from)))
+ ((to at from start)
+ (u8vector-reverse-copy! (U to) at (U from) start))
+ ((to at from start end)
+ (u8vector-reverse-copy! (U to) at (U from) start end))))
+
+(define bitvector->list/int
+ (case-lambda
+ ((bvec)
+ (u8vector->list (U bvec)))
+ ((bvec start)
+ (u8vector->list (U bvec) start))
+ ((bvec start end)
+ (u8vector->list (U bvec) start end))))
+
+(define bitvector->list/bool
+ (case-lambda
+ ((bvec)
+ (map bit->boolean (u8vector->list (U bvec))))
+ ((bvec start)
+ (map bit->boolean (u8vector->list (U bvec) start)))
+ ((bvec start end)
+ (map bit->boolean (u8vector->list (U bvec) start end)))))
+
+(define reverse-bitvector->list/int
+ (case-lambda
+ ((bvec)
+ (reverse-u8vector->list (U bvec)))
+ ((bvec start)
+ (reverse-u8vector->list (U bvec) start))
+ ((bvec start end)
+ (reverse-u8vector->list (U bvec) start end))))
+
+(define reverse-bitvector->list/bool
+ (case-lambda
+ ((bvec)
+ (map bit->boolean (reverse-u8vector->list (U bvec))))
+ ((bvec start)
+ (map bit->boolean (reverse-u8vector->list (U bvec) start)))
+ ((bvec start end)
+ (map bit->boolean (reverse-u8vector->list (U bvec) start end)))))
+
+(define bitvector->vector/int
+ (case-lambda
+ ((bvec)
+ (u8vector->vector (U bvec)))
+ ((bvec start)
+ (u8vector->vector (U bvec) start))
+ ((bvec start end)
+ (u8vector->vector (U bvec) start end))))
+
+(define bitvector->vector/bool
+ (case-lambda
+ ((bvec)
+ (vector-map bit->boolean (u8vector->vector (U bvec))))
+ ((bvec start)
+ (vector-map bit->boolean (u8vector->vector (U bvec) start)))
+ ((bvec start end)
+ (vector-map bit->boolean (u8vector->vector (U bvec) start end)))))
+
+(define (list->bitvector list)
+ (W (list->u8vector (map bit->integer list))))
+
+(define (reverse-list->bitvector list)
+ (W (reverse-list->u8vector (map bit->integer list))))
+
+(define (bitvector . bits) (list->bitvector bits))
+
+(define vector->bitvector
+ (case-lambda
+ ((vec)
+ (W (vector->u8vector (vector-map bit->integer vec))))
+ ((vec start)
+ (W (vector->u8vector (vector-map bit->integer vec) start)))
+ ((vec start end)
+ (W (vector->u8vector (vector-map bit->integer vec) start end)))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 1afac2bca..6ee26e869 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -169,6 +169,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-160-base.test \
tests/srfi-160.test \
tests/srfi-171.test \
+ tests/srfi-178.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
@@ -220,6 +221,16 @@ EXTRA_DIST = \
tests/srfi-151-test.scm \
tests/srfi-160-base-test.scm \
tests/srfi-160-test.scm \
+ tests/srfi-178-test/constructors.scm \
+ tests/srfi-178-test/conversions.scm \
+ tests/srfi-178-test/fields.scm \
+ tests/srfi-178-test/gen-accum.scm \
+ tests/srfi-178-test/iterators.scm \
+ tests/srfi-178-test/logic-ops.scm \
+ tests/srfi-178-test/mutators.scm \
+ tests/srfi-178-test/quasi-ints.scm \
+ tests/srfi-178-test/quasi-string.scm \
+ tests/srfi-178-test/selectors.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-178-test/constructors.scm b/test-suite/tests/srfi-178-test/constructors.scm
new file mode 100644
index 000000000..3e133703a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/constructors.scm
@@ -0,0 +1,88 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-constructors)
+ (print-header "Checking constructors...")
+
+ (check (bitvector-length (make-bitvector 8)) => 8)
+ (check (bitvector= (make-bitvector 4 0) (bitvector 0 0 0 0)) => #t)
+ (check (bitvector= (make-bitvector 4 #t) (bitvector 1 1 1 1)) => #t)
+
+ ;;; unfolds
+
+ (check (bitvector=
+ (bitvector-unfold (lambda (_) 0) 4)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ b) (values b (not b))) 4 #f)
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ b c)
+ (values (and b c) (not b) c))
+ 4
+ #t
+ #t)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_) 0) 4)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_ b) (values b (not b))) 4 #f)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold-right (lambda (_ b c)
+ (values (and b c) (not b) c))
+ 4
+ #t
+ #t)
+ (bitvector 0 1 0 1))
+ => #t)
+
+ ;;; copy
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= bvec (bitvector-copy bvec)) => #t)
+ (check (eqv? bvec (bitvector-copy bvec)) => #f)) ; fresh copy?
+ (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 1) (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 2 4) (bitvector 1 0))
+ => #t)
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (equal? (bitvector->list/int (bitvector-reverse-copy bvec))
+ (reverse (bitvector->list/int bvec)))
+ => #t)
+ (check (eqv? bvec (bitvector-reverse-copy bvec)) => #f)) ; fresh copy?
+ (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 2 4)
+ (bitvector 0 1))
+ => #t)
+
+ ;;; append & concatenate
+
+ (check (bitvector=
+ (bitvector-append (bitvector 1 0) (bitvector 0 1))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-append (bitvector 1 0) (bitvector 0 1) (bitvector))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-concatenate
+ (list (bitvector 1 0) (bitvector 0 1) (bitvector)))
+ (bitvector 1 0 0 1))
+ => #t)
+ (check (bitvector=
+ (bitvector-append-subbitvectors (bitvector 1 0 0 1) 0 2
+ (bitvector 1 1 1 1) 2 4)
+ (bitvector 1 0 1 1))
+ => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/conversions.scm b/test-suite/tests/srfi-178-test/conversions.scm
new file mode 100644
index 000000000..7d3b3f232
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/conversions.scm
@@ -0,0 +1,108 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bitvector-conversions)
+ (print-header "Checking bitvector conversions...")
+
+ ;;; lists
+
+ (check (bitvector->list/int (bitvector)) => '())
+ (check (bitvector->list/int (bitvector 1 0 1 0)) => '(1 0 1 0))
+ (check (bitvector->list/int (bitvector 1 0 1 0) 2) => '(1 0))
+ (check (bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(0 1))
+ (check (bitvector->list/bool (bitvector)) => '())
+ (check (bitvector->list/bool (bitvector 1 0 1 0)) => '(#t #f #t #f))
+ (check (bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#t #f))
+ (check (bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#f #t))
+
+ (check (reverse-bitvector->list/int (bitvector)) => '())
+ (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 2) => '(0 1))
+ (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(1 0))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (equal? (reverse-bitvector->list/int bvec)
+ (reverse (bitvector->list/int bvec)))
+ => #t)
+ (check (equal? (reverse-bitvector->list/bool bvec)
+ (reverse (bitvector->list/bool bvec)))
+ => #t))
+ (check (reverse-bitvector->list/bool (bitvector)) => '())
+ (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#f #t))
+ (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#t #f))
+
+ (check (bitvector= (list->bitvector '(1 0 #t #f)) (bitvector 1 0 1 0)) => #t)
+ (let ((bs '(1 0 1 0)))
+ (check (equal? bs (bitvector->list/int (list->bitvector bs))) => #t)
+ (check (equal? bs
+ (reverse-bitvector->list/int
+ (reverse-list->bitvector bs)))
+ => #t))
+ (check (bitvector= (reverse-list->bitvector '(1 0 #t #f)) (bitvector 0 1 0 1))
+ => #t)
+
+ ;;; vectors
+
+ (check (bitvector->vector/int (bitvector)) => #())
+ (check (bitvector->vector/int (bitvector 1 0 1 0)) => #(1 0 1 0))
+ (check (bitvector->vector/int (bitvector 1 0 1 0) 1) => #(0 1 0))
+ (check (bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(0 1))
+ (check (bitvector->vector/bool (bitvector)) => #())
+ (check (bitvector->vector/bool (bitvector 1 0 1 0)) => #(#t #f #t #f))
+ (check (bitvector->vector/bool (bitvector 1 0 1 0) 1) => #(#f #t #f))
+ (check (bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#f #t))
+
+ (check (reverse-bitvector->vector/int (bitvector)) => #())
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0)) => #(0 1 0 1))
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 2) => #(0 1))
+ (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(1 0))
+ (check (reverse-bitvector->vector/bool (bitvector)) => #())
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0))
+ => #(#f #t #f #t))
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 2) => #(#f #t))
+ (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#t #f))
+
+ (check (bitvector-empty? (vector->bitvector #())) => #t)
+ (check (bitvector= (vector->bitvector #(1 0 #t #f))
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector= (vector->bitvector #(1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector= (vector->bitvector #(1 0 1 0) 1 3)
+ (bitvector 0 1))
+ => #t)
+ (check (bitvector-empty? (reverse-vector->bitvector #())) => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 #t #f))
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 2)
+ (bitvector 0 1))
+ => #t)
+ (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 1 3)
+ (bitvector 1 0))
+ => #t)
+
+ ;;; strings
+
+ (check (bitvector->string (bitvector 1 0 1 0)) => "#*1010")
+ (check (bitvector->string (bitvector)) => "#*")
+ (check (bitvector= (string->bitvector "#*1010") (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector-empty? (string->bitvector "#*")) => #t)
+ (check (string->bitvector "") => #f)
+ (check (string->bitvector "1010") => #f)
+ (check (string->bitvector "#") => #f)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (string->bitvector (bitvector->string bvec))
+ bvec)
+ => #t))
+
+ ;;; integers
+
+ ;; Remember, these are little-endian!
+ (check (bitvector->integer (bitvector 0 1 0 1)) => #xa)
+ (check (bitvector->integer (bitvector 1 0 1 0 1 1 0 1)) => #xb5)
+ (check (bitvector= (integer->bitvector #xa) (bitvector 0 1 0 1)) => #t)
+ (check (bitvector= (integer->bitvector #xb5) (bitvector 1 0 1 0 1 1 0 1))
+ => #t)
+ (check (bitvector= (integer->bitvector #xb5 4) (bitvector 1 0 1 0)) => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/fields.scm b/test-suite/tests/srfi-178-test/fields.scm
new file mode 100644
index 000000000..bde5f4aaf
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/fields.scm
@@ -0,0 +1,98 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bit-field-operations)
+ (print-header "Checking bit field operations...")
+
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 0 4) => #t)
+ (check (bitvector-field-any? (bitvector 0 0 0 0) 0 4) => #f)
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 1 3) => #t)
+ (check (bitvector-field-any? (bitvector 0 1 0 0) 2 4) => #f)
+
+ (check (bitvector-field-every? (make-bitvector 4 1) 0 4) => #t)
+ (check (bitvector-field-every? (bitvector 1 1 1 0) 0 4) => #f)
+ (check (bitvector-field-every? (bitvector 1 1 0 0) 0 2) => #t)
+ (check (bitvector-field-every? (bitvector 1 1 0 0) 2 4) => #f)
+
+ (check (bitvector= (bitvector-field-clear (make-bitvector 4 1) 0 2)
+ (bitvector 0 0 1 1))
+ => #t)
+ (let ((bvec (make-bitvector 4 1)))
+ (check (bitvector= (begin (bitvector-field-clear! bvec 0 2) bvec)
+ (bitvector 0 0 1 1))
+ => #t))
+ (check (bitvector= (bitvector-field-set (make-bitvector 4 0) 0 2)
+ (bitvector 1 1 0 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check (bitvector= (begin (bitvector-field-set! bvec 0 2) bvec)
+ (bitvector 1 1 0 0))
+ => #t))
+
+ ;;; replace-same and replace
+
+ (check
+ (bitvector=
+ (bitvector-field-replace-same (make-bitvector 4 0)
+ (make-bitvector 4 1)
+ 1
+ 3)
+ (bitvector 0 1 1 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check
+ (bitvector= (begin
+ (bitvector-field-replace-same! bvec
+ (make-bitvector 4 1)
+ 1
+ 3)
+ bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+ (check
+ (bitvector=
+ (bitvector-field-replace (make-bitvector 4 0) (bitvector 1 0 0 0) 1 3)
+ (bitvector 0 1 0 0))
+ => #t)
+ (let ((bvec (make-bitvector 4 0)))
+ (check
+ (bitvector= (begin
+ (bitvector-field-replace! bvec (make-bitvector 4 1) 1 3)
+ bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+
+ ;;; rotate
+
+ (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) 1 0 4)
+ (bitvector 0 0 1 1))
+ => #t)
+ (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) -1 0 4)
+ (bitvector 1 1 0 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) 2 2 6)
+ (bitvector 1 0 1 0 0 1 1 0))
+ => #t)
+ (check (bitvector=
+ (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) -3 2 6)
+ (bitvector 1 0 1 1 0 0 1 0))
+ => #t)
+
+ ;;; flip
+
+ (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 0 4)
+ (bitvector 1 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 2 4)
+ (bitvector 0 1 1 0))
+ => #t)
+ (let ((bvec (bitvector 0 1 0 1)))
+ (check (bitvector= (begin (bitvector-field-flip! bvec 0 4) bvec)
+ (bitvector 1 0 1 0))
+ => #t))
+ (let ((bvec (bitvector 0 1 0 1)))
+ (check (bitvector= (begin (bitvector-field-flip! bvec 2 4) bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/gen-accum.scm b/test-suite/tests/srfi-178-test/gen-accum.scm
new file mode 100644
index 000000000..ab14912f3
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/gen-accum.scm
@@ -0,0 +1,72 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-generators-and-accumulators)
+ (define test-bvec (bitvector 1 0 1 1 0 1 0 1))
+ (print-header "Checking generators and accumulators...")
+
+ ;;; Generators
+
+ (check (eof-object? ((make-bitvector/int-generator (bitvector)))) => #t)
+ (check (eof-object? ((make-bitvector/bool-generator (bitvector)))) => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ g) (values (g) g))
+ (bitvector-length test-bvec)
+ (make-bitvector/int-generator test-bvec))
+ test-bvec)
+ => #t)
+ (check (bitvector=
+ (bitvector-unfold (lambda (_ g) (values (g) g))
+ (bitvector-length test-bvec)
+ (make-bitvector/bool-generator test-bvec))
+ test-bvec)
+ => #t)
+
+ ;;; Accumulator
+
+ (check (bitvector-empty? ((make-bitvector-accumulator) (eof-object)))
+ => #t)
+ ;; Accumulate integers.
+ (check (bitvector= test-bvec
+ (let ((acc (make-bitvector-accumulator)))
+ (bitvector-for-each/int acc test-bvec)
+ (acc (eof-object))))
+ => #t)
+ ;; Accumulate booleans.
+ (check (bitvector= test-bvec
+ (let ((acc (make-bitvector-accumulator)))
+ (bitvector-for-each/bool acc test-bvec)
+ (acc (eof-object))))
+ => #t)
+
+ ;;; Generator/accumulator identities
+
+ ;; Accumulating generated values yields the original structure.
+ (check (bitvector=
+ (let ((gen (make-bitvector/int-generator test-bvec))
+ (acc (make-bitvector-accumulator)))
+ (generator-for-each acc gen)
+ (acc (eof-object)))
+ test-bvec)
+ => #t)
+
+ ;; Generating accumulated values yields the original values.
+ ;; Integer generator.
+ (let ((lis (bitvector->list/int test-bvec)))
+ (check (equal?
+ (let ((acc (make-bitvector-accumulator)))
+ (for-each acc lis)
+ (generator->list
+ (make-bitvector/int-generator (acc (eof-object)))))
+ lis)
+ => #t))
+ ;; Boolean generator.
+ (let ((lis (bitvector->list/bool test-bvec)))
+ (check (equal?
+ (let ((acc (make-bitvector-accumulator)))
+ (for-each acc lis)
+ (generator->list
+ (make-bitvector/bool-generator (acc (eof-object)))))
+ lis)
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/iterators.scm b/test-suite/tests/srfi-178-test/iterators.scm
new file mode 100644
index 000000000..239572b6a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/iterators.scm
@@ -0,0 +1,150 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-iterators)
+ (print-header "Checking iteration...")
+
+ ;;; take & take-right
+
+ (check (bitvector= (bitvector-take (bitvector 1 0 1 0) 2)
+ (bitvector 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-take (bitvector 1 0) 0)) => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-take bvec (bitvector-length bvec))
+ bvec)
+ => #t)
+ (check (bitvector= (bitvector-take-right bvec (bitvector-length bvec))
+ bvec)
+ => #t))
+ (check (bitvector= (bitvector-take-right (bitvector 1 0 1 0) 3)
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-take-right (bitvector 1 0) 0)) => #t)
+
+ ;;; drop & drop-right
+
+ (check (bitvector= (bitvector-drop (bitvector 1 0 1 0) 1)
+ (bitvector 0 1 0))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector-empty? (bitvector-drop bvec (bitvector-length bvec)))
+ => #t)
+ (check (bitvector= (bitvector-drop bvec 0) bvec) => #t)
+ (check (bitvector= (bitvector-drop-right bvec 0) bvec) => #t)
+ (check (bitvector-empty?
+ (bitvector-drop-right bvec (bitvector-length bvec)))
+ => #t))
+ (check (bitvector= (bitvector-drop-right (bitvector 1 0 1 0) 1)
+ (bitvector 1 0 1))
+ => #t)
+
+ ;;; segment
+
+ (check (bitvector= (car (bitvector-segment (bitvector 1 0 1 0) 2))
+ (bitvector 1 0))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-concatenate (bitvector-segment bvec 1))
+ bvec)
+ => #t))
+\f
+ ;;; fold
+
+ (check (bitvector-fold/int + 0 (bitvector)) => 0)
+ (check (bitvector-fold/int + 0 (bitvector 1)) => 1)
+ (check (bitvector-fold/bool proc-or #f (bitvector)) => #f)
+ (check (bitvector-fold/bool proc-or #f (bitvector #t)) => #t)
+ (check (bitvector-fold-right/int + 0 (bitvector)) => 0)
+ (check (bitvector-fold-right/int + 0 (bitvector 1)) => 1)
+ (check (bitvector-fold-right/bool proc-or #f (bitvector)) => #f)
+ (check (bitvector-fold-right/bool proc-or #f (bitvector #t)) => #t)
+
+ ;;; map
+
+ (check (bitvector-empty? (bitvector-map/int values (bitvector))) => #t)
+ (check (bitvector= (bitvector-map/int (constantly 1) (bitvector 0 0 1))
+ (bitvector 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-map/int (lambda (a b c) b)
+ (bitvector 1 0 0)
+ (bitvector 0 1 0)
+ (bitvector 0 0 1))
+ (bitvector 0 1 0))
+ => #t)
+ (check (bitvector-empty? (bitvector-map/bool values (bitvector))) => #t)
+ (check (bitvector= (bitvector-map/bool (constantly #t)
+ (bitvector #f #f #t))
+ (bitvector #t #t #t))
+ => #t)
+ (check (bitvector= (bitvector-map/bool (lambda (a b c) b)
+ (bitvector #t #f #f)
+ (bitvector #f #t #f)
+ (bitvector #f #f #t))
+ (bitvector #f #t #f))
+ => #t)
+
+ ;;; map!
+
+ (check (let ((bvec (bitvector)))
+ (bitvector-map!/int values bvec)
+ (bitvector-empty? bvec))
+ => #t)
+ (check (let ((bvec (bitvector 1 0 1 0)))
+ (bitvector-map!/int (constantly 1) bvec)
+ (bitvector= bvec (bitvector 1 1 1 1)))
+ => #t)
+ (check (let ((bvec1 (bitvector 1 0 0))
+ (bvec2 (bitvector 0 1 0))
+ (bvec3 (bitvector 0 0 1)))
+ (bitvector-map!/int (lambda (a b c) b) bvec1 bvec2 bvec3)
+ (bitvector= bvec1 bvec2))
+ => #t)
+ (check (let ((bvec (bitvector)))
+ (bitvector-map!/bool values bvec)
+ (bitvector-empty? bvec))
+ => #t)
+ (check (let ((bvec (bitvector #t #f #t #f)))
+ (bitvector-map!/bool (constantly #t) bvec)
+ (bitvector= bvec (bitvector #t #t #t #t)))
+ => #t)
+ (check (let ((bvec1 (bitvector #t #f #f))
+ (bvec2 (bitvector #f #t #f))
+ (bvec3 (bitvector #f #f #t)))
+ (bitvector-map!/bool (lambda (a b c) b) bvec1 bvec2 bvec3)
+ (bitvector= bvec1 bvec2))
+ => #t)
+
+\f
+ ;;; map->list
+
+ (check (bitvector-map->list/bool values (bitvector)) => '())
+ (check (bitvector-map->list/int (constantly 1) (bitvector 1 0 0)) => '(1 1 1))
+ (check (bitvector-map->list/int list (bitvector 1 0) (bitvector 0 1))
+ => '((1 0) (0 1)))
+ (check (bitvector-map->list/bool values (bitvector)) => '())
+ (check (bitvector-map->list/bool (constantly #t) (bitvector 1 0 0))
+ => '(#t #t #t))
+ (check (bitvector-map->list/bool list (bitvector 1 0) (bitvector 0 1))
+ => '((#t #f) (#f #t)))
+
+ ;;; for-each
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (let ((c 0))
+ (bitvector-for-each/int (lambda (_) (set! c (+ c 1))) bvec)
+ c)
+ => (bitvector-length bvec))
+ (check (let ((lis '()))
+ (bitvector-for-each/int (lambda (b) (set! lis (cons b lis))) bvec)
+ lis)
+ => (reverse-bitvector->list/int bvec))
+ (check (let ((c 0))
+ (bitvector-for-each/bool (lambda (_) (set! c (+ c 1))) bvec)
+ c)
+ => (bitvector-length bvec))
+ (check (let ((lis '()))
+ (bitvector-for-each/bool (lambda (b) (set! lis (cons b lis))) bvec)
+ lis)
+ => (reverse-bitvector->list/bool bvec)))
+)
diff --git a/test-suite/tests/srfi-178-test/logic-ops.scm b/test-suite/tests/srfi-178-test/logic-ops.scm
new file mode 100644
index 000000000..e68fdebda
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/logic-ops.scm
@@ -0,0 +1,125 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-bitwise-operations)
+ (define test-bvec1 (bitvector 1 0 1 0))
+ (define test-bvec2 (bitvector 1 1 0 0))
+ (define test-bvec3 (bitvector 0 0 1 1))
+ (print-header "Checking bitwise operations...")
+
+ ;;; not
+
+ (check (bitvector= (bitvector-not test-bvec1) (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-not (bitvector-not test-bvec1))
+ test-bvec1)
+ => #t)
+
+ ;;; Associative operations
+
+ (check (bitvector= (bitvector-and test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 0 0 0))
+ => #t)
+ (check (bitvector= (bitvector-ior test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 1 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-xor test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-eqv test-bvec1 test-bvec2 test-bvec3)
+ (bitvector 0 1 0 1))
+ => #t)
+
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-and! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 0 0 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-ior! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 1 1 1 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-xor! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 1 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-eqv! test-bvec1* test-bvec2 test-bvec3)
+ test-bvec1*)
+ (bitvector 0 1 0 1))
+ => #t))
+\f
+ ;;; Non-associative binary operations
+
+ (check (bitvector= (bitvector-nand test-bvec1 test-bvec2)
+ (bitvector 0 1 1 1))
+ => #t)
+ (check (bitvector= (bitvector-nor test-bvec1 test-bvec2)
+ (bitvector 0 0 0 1))
+ => #t)
+ (check (bitvector= (bitvector-andc1 test-bvec1 test-bvec2)
+ (bitvector 0 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector-andc2 test-bvec1 test-bvec2)
+ (bitvector 0 0 1 0))
+ => #t)
+ (check (bitvector= (bitvector-orc1 test-bvec1 test-bvec2)
+ (bitvector 1 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-orc2 test-bvec1 test-bvec2)
+ (bitvector 1 0 1 1))
+ => #t)
+
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-nand! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 1 1 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-nor! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 0 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-andc1! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-andc2! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 0 0 1 0))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-orc1! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 1 1 0 1))
+ => #t))
+ (let ((test-bvec1* (bitvector-copy test-bvec1)))
+ (check
+ (bitvector= (begin
+ (bitvector-orc2! test-bvec1* test-bvec2)
+ test-bvec1*)
+ (bitvector 1 0 1 1))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/mutators.scm b/test-suite/tests/srfi-178-test/mutators.scm
new file mode 100644
index 000000000..281a67cdd
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/mutators.scm
@@ -0,0 +1,79 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-mutators)
+ (print-header "Checking mutators...")
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-set! bvec 1 1) bvec)
+ (bitvector 1 1 1 0))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-set! bvec 0 #f) bvec)
+ (bitvector 0 0 1 0))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-swap! bvec 0 1) bvec)
+ (bitvector 0 1 1 0))
+ => #t))
+
+ ;;; reverse!
+
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec) bvec)
+ (bitvector 0 1 0 1))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec 2) bvec)
+ (bitvector 1 0 0 1))
+ => #t))
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse! bvec 1 3) bvec)
+ (bitvector 1 1 0 0))
+ => #t))
+
+ ;;; copy!
+
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 0 (bitvector 1 0)) bvec)
+ (bitvector 1 0 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 1 0) 1) bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 0 1) 0 2) bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+
+ ;;; reverse-copy!
+
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 0 (bitvector 1 0))
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 0 1) 1)
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+ (let ((bvec (bitvector 0 0 0 0)))
+ (check
+ (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 1 1) 0 2)
+ bvec)
+ (bitvector 0 1 0 0))
+ => #t))
+)
diff --git a/test-suite/tests/srfi-178-test/quasi-ints.scm b/test-suite/tests/srfi-178-test/quasi-ints.scm
new file mode 100644
index 000000000..8f59ff1cc
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-ints.scm
@@ -0,0 +1,41 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-quasi-integer-operations)
+ (print-header "Checking quasi-integer operations...")
+
+ (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) 2 0)
+ (bitvector 1 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) -2 #t)
+ (bitvector 1 1 1 0))
+ => #t)
+
+ (check (bitvector-count 1 (make-bitvector 8 1)) => 8)
+ (check (bitvector-count #t (make-bitvector 8 0)) => 0)
+ (check (bitvector-count 1 (bitvector 1 1 0 1 1 0 0 0)) => 4)
+
+ (check (bitvector-count-run 1 (make-bitvector 8 1) 0) => 8)
+ (check (bitvector-count-run #t (make-bitvector 8 0) 4) => 0)
+ (check (bitvector-count-run 1 (bitvector 0 1 1 1) 1) => 3)
+
+ (let ((then-bvec (bitvector 1 0 1 0))
+ (else-bvec (bitvector 0 0 0 1)))
+ (check
+ (bitvector= (bitvector-if (make-bitvector 4 1) then-bvec else-bvec)
+ then-bvec)
+ => #t)
+ (check
+ (bitvector= (bitvector-if (make-bitvector 4 0) then-bvec else-bvec)
+ else-bvec)
+ => #t))
+ (check (bitvector= (bitvector-if (bitvector 1 1 0 0)
+ (bitvector 0 1 1 1)
+ (bitvector 0 0 1 0))
+ (bitvector 0 1 1 0))
+ => #t)
+
+ (check (bitvector-first-bit 0 (make-bitvector 4 0)) => 0)
+ (check (bitvector-first-bit #t (bitvector 0 0 1 0)) => 2)
+ (check (bitvector-first-bit #f (make-bitvector 4 1)) => -1)
+)
diff --git a/test-suite/tests/srfi-178-test/quasi-string.scm b/test-suite/tests/srfi-178-test/quasi-string.scm
new file mode 100644
index 000000000..2da77466a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-string.scm
@@ -0,0 +1,62 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-quasi-string-ops)
+ (print-header "Checking quasi-string operations...")
+
+ ;;; prefix & suffix
+
+ (check (bitvector-prefix-length (bitvector 1 0 0) (bitvector 1 0 1)) => 2)
+ (check (bitvector-prefix-length (bitvector) (bitvector 1 0 1)) => 0)
+ (let ((bvec (bitvector 1 0 1)))
+ (check (= (bitvector-prefix-length bvec bvec) (bitvector-length bvec))
+ => #t)
+ (check (= (bitvector-suffix-length bvec bvec) (bitvector-length bvec))
+ => #t))
+ (check (bitvector-suffix-length (bitvector 1 0 0) (bitvector 0 0 0)) => 2)
+ (check (bitvector-suffix-length (bitvector) (bitvector 1 0 1)) => 0)
+
+ (check (bitvector-prefix? (bitvector 1) (bitvector 1 0)) => #t)
+ (check (bitvector-prefix? (bitvector 0) (bitvector 1 0)) => #f)
+ (check (bitvector-suffix? (bitvector 0) (bitvector 1 0)) => #t)
+ (check (bitvector-suffix? (bitvector 1) (bitvector 1 0)) => #f)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector-prefix? bvec bvec) => #t)
+ (check (bitvector-suffix? bvec bvec) => #t))
+
+ ;;; pad & trim
+
+ (check (bitvector=
+ (bitvector-pad 0 (bitvector 1) 4)
+ (bitvector 0 0 0 1))
+ => #t)
+ (let ((bvec (bitvector 1 0 1 0)))
+ (check (bitvector= (bitvector-pad 0 bvec (bitvector-length bvec))
+ bvec)
+ => #t)
+ (check (bitvector= (bitvector-pad-right 0 bvec (bitvector-length bvec))
+ bvec)
+ => #t))
+ (check (bitvector=
+ (bitvector-pad-right 0 (bitvector 1) 4)
+ (bitvector 1 0 0 0))
+ => #t)
+ (check (bitvector= (bitvector-trim 0 (bitvector 0 0 0 1))
+ (bitvector 1))
+ => #t)
+ (check (bitvector= (bitvector-trim 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 0 0))
+ (bitvector 1))
+ => #t)
+ (check (bitvector= (bitvector-trim-both 1 (bitvector 1 0 1))
+ (bitvector 0))
+ => #t)
+ (check (bitvector= (bitvector-trim-both 0 (bitvector 1 0 1))
+ (bitvector 1 0 1))
+ => #t)
+)
diff --git a/test-suite/tests/srfi-178-test/selectors.scm b/test-suite/tests/srfi-178-test/selectors.scm
new file mode 100644
index 000000000..f37894702
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/selectors.scm
@@ -0,0 +1,13 @@
+;;; SPDX-License-Identifier: MIT
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+
+(define (check-selectors)
+ (print-header "Checking selectors...")
+
+ (check (bitvector-length (bitvector)) => 0)
+ (check (bitvector-length (bitvector 1 0 1 0)) => 4)
+ (check (bitvector-ref/int (bitvector 1 0 1 0) 0) => 1)
+ (check (bitvector-ref/int (bitvector 1 0 1 0) 3) => 0)
+ (check (bitvector-ref/bool (bitvector 1 0 1 0) 0) => #t)
+ (check (bitvector-ref/bool (bitvector 1 0 1 0) 3) => #f))
+
diff --git a/test-suite/tests/srfi-178.test b/test-suite/tests/srfi-178.test
new file mode 100644
index 000000000..4ab6c6708
--- /dev/null
+++ b/test-suite/tests/srfi-178.test
@@ -0,0 +1,147 @@
+;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe
+
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+
+;;; The above copyright notice and this permission notice shall be included
+;;; in all copies or substantial portions of the Software.
+
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+;;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(import (scheme base))
+(import (scheme write))
+(import (srfi 178))
+
+;;; START Guile-specific customizations to use Guile's own test runner.
+(import (srfi 64))
+
+(define report (@@ (test-suite lib) report))
+
+(define-syntax check
+ (syntax-rules (=>)
+ ((check expr => expected)
+ (test-equal expected expr))))
+
+(define (guile-test-runner)
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (let* ((result-alist (test-result-alist runner))
+ (result-kind (assq-ref result-alist 'result-kind))
+ (test-name (list (assq-ref result-alist 'test-name))))
+ (case result-kind
+ ((pass) (report 'pass test-name))
+ ((xpass) (report 'upass test-name))
+ ((skip) (report 'untested test-name))
+ ((fail xfail)
+ (apply report result-kind test-name result-alist))
+ (else #t)))))
+ runner))
+;;; END Guile-specific customizations to use Guile's own test runner.
+
+(cond-expand
+ ((library (srfi 158))
+ (import (only (srfi 158) generator-for-each generator->list)))
+ (else
+ (begin
+ (define (generator-for-each proc g)
+ (let ((v (g)))
+ (unless (eof-object? v)
+ (proc v)
+ (generator-for-each proc g))))
+
+ (define (generator->list g)
+ (let ((v (g)))
+ (if (eof-object? v)
+ '()
+ (cons v (generator->list g))))))))
+
+(define (print-header message)
+ (newline)
+ (display ";;; ")
+ (display message)
+ (newline))
+
+;;;; Utility
+
+(define (proc-or a b) (or a b))
+
+(define (constantly x) (lambda (_) x))
+
+(define bitvector= bitvector=?)
+
+(define (check-bit-conversions)
+ (print-header "Checking bit conversions...")
+
+ (check (bit->integer 0) => 0)
+ (check (bit->integer 1) => 1)
+ (check (bit->integer #f) => 0)
+ (check (bit->integer #t) => 1)
+ (check (bit->boolean 0) => #f)
+ (check (bit->boolean 1) => #t)
+ (check (bit->boolean #f) => #f)
+ (check (bit->boolean #t) => #t))
+
+(define (check-predicates)
+ (print-header "Checking predicates...")
+
+ (check (bitvector? (bitvector)) => #t)
+ (check (bitvector? (make-bitvector 1)) => #t)
+
+ (check (bitvector-empty? (bitvector)) => #t)
+ (check (bitvector-empty? (bitvector 1)) => #f)
+
+ (check (bitvector= (bitvector) (bitvector)) => #t)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 0)) => #t)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 1)) => #f)
+ (check (bitvector= (bitvector 1 0 0) (bitvector 1 0)) => #f)
+ (check (bitvector= (bitvector 1 0 0)
+ (bitvector 1 0 0)
+ (bitvector 1 0 0))
+ => #t)
+ (check (bitvector= (bitvector 1 0 0)
+ (bitvector 1 0 1)
+ (bitvector 1 0 0))
+ => #f))
+
+(include "srfi-178-test/constructors.scm")
+(include "srfi-178-test/iterators.scm")
+(include "srfi-178-test/selectors.scm")
+(include "srfi-178-test/conversions.scm")
+(include "srfi-178-test/mutators.scm")
+(include "srfi-178-test/quasi-string.scm")
+(include "srfi-178-test/gen-accum.scm")
+(include "srfi-178-test/logic-ops.scm")
+(include "srfi-178-test/quasi-ints.scm")
+(include "srfi-178-test/fields.scm")
+
+(define (check-all)
+ ;; Check predicates, bitvector conversions, and selectors first,
+ ;; since they're used extensively in later tests.
+ (check-predicates)
+ (check-bitvector-conversions)
+ (check-selectors)
+ (check-bit-conversions)
+ (check-constructors)
+ (check-iterators)
+ (check-quasi-string-ops)
+ (check-mutators)
+ (check-bitwise-operations)
+ (check-quasi-integer-operations)
+ (check-bit-field-operations))
+
+(test-with-runner (guile-test-runner)
+ (test-begin "SRFI 178")
+ (check-all)
+ (test-end "SRFI 178"))
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH v6 16/16] module: Add SRFI 209.
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (14 preceding siblings ...)
2023-12-03 1:37 ` [PATCH v6 15/16] module: Add SRFI 178 Maxim Cournoyer
@ 2023-12-03 1:37 ` Maxim Cournoyer
15 siblings, 0 replies; 17+ messages in thread
From: Maxim Cournoyer @ 2023-12-03 1:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
Sources retrieved from commit 9d40aaff0b788f3fd611e04a5b6aef4dfd017e8d
from https://github.com/scheme-requests-for-implementation/srfi-209/.
* module/srfi/srfi-209.sld: New file.
* module/srfi/srfi-209/209.scm: Likewise.
* module/Makefile.am (SOURCES): Register srfi-209.sld.
(NOCOMP_SOURCES): Register 209.scm.
* test-suite/tests/srfi-209-test.scm: New file.
* test-suite/tests/srfi-209.test: Likewise.
* test-suite/Makefile.am (SCM_TESTS): Register test.
(EXTRA_DIST): Register test definition.
* doc/ref/srfi-modules.texi (SRFI 209): Document it.
---
Changes in v6:
- Add SRFI 209
NEWS | 1 +
am/bootstrap.am | 2 +
doc/ref/guile.texi | 4 +-
doc/ref/srfi-modules.texi | 893 ++++++++++++++++++++++++++++-
module/srfi/srfi-209.sld | 60 ++
module/srfi/srfi-209/209.scm | 690 ++++++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-209-test.scm | 465 +++++++++++++++
test-suite/tests/srfi-209.test | 50 ++
9 files changed, 2159 insertions(+), 8 deletions(-)
create mode 100644 module/srfi/srfi-209.sld
create mode 100644 module/srfi/srfi-209/209.scm
create mode 100644 test-suite/tests/srfi-209-test.scm
create mode 100644 test-suite/tests/srfi-209.test
diff --git a/NEWS b/NEWS
index b1a21c59b..a269e0776 100644
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,7 @@ the compiler reports it as "possibly unused".
** Add (srfi 151), a bitwise operations library
** Add (srfi 160), an homogeneous numeric vector library
** Add (srfi 178), a bitvector library
+** Add (srfi 209), an enums library
* Bug fixes
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 7ebf4ca67..69f81af4c 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -372,6 +372,7 @@ SOURCES = \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
srfi/srfi-178.sld \
+ srfi/srfi-209.sld \
\
statprof.scm \
\
@@ -503,6 +504,7 @@ NOCOMP_SOURCES = \
srfi/srfi-178/quasi-strs.scm \
srfi/srfi-178/unfolds.scm \
srfi/srfi-178/wrappers.scm \
+ srfi/srfi-209/209.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 22d234b1b..f2a2d08f4 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,8 +24,8 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-Additionally, the documentation of the 125, 126, 128, 151, 160 and 178
-SRFI modules is adapted from their specification text, which is made
+Additionally, the documentation of the 125, 126, 128, 151, 160, 178 and
+209 SRFI modules is adapted from their specification text, which is made
available under the following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 216a4e045..3ca18979f 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, 2018 John Cowan
+@c Copyright (C) 2015-2016, 2018, 2020 John Cowan
@c See the file guile.texi for copying conditions.
@node SRFI Support
@@ -73,9 +73,9 @@ get the relevant SRFI documents from the SRFI home page
* SRFI 160:: Homogeneous numeric vectors.
* SRFI-171:: Transducers.
* SRFI 178:: Bitvectors.
+* SRFI 209:: Enums and Enum Sets.
@end menu
-
@node About SRFI Usage
@subsection About SRFI Usage
@@ -9444,13 +9444,14 @@ returns, and in order to write portable code, the return value should be
ignored.
@item @var{vec}
-An heterogeneous vector; that is, it must satisfy the predicate
+A heterogeneous vector; that is, it must satisfy the predicate
@code{vector?}.
@item @var{bvec}, @var{to}, @var{from}
-A bitvector, i.e., it must satisfy the predicate @code{bitvector?}. In
-@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{to} is the
-destination and @var{from} is the source.
+A bitvector, @abbr{i.e.} it must satisfy the predicate
+@code{bitvector?}. In @code{bitvector-copy!} and
+@code{reverse-bitvector-copy!}, @var{to} is the destination and
+@var{from} is the source.
@item @var{i}, @var{j}, @var{start}, @var{at}
An exact nonnegative integer less than the length of the bitvector. In
@@ -9966,6 +9967,886 @@ and @code{write} procedures and by the program parser, so that programs
can contain references to literal bitvectors. On input, it is an error
if such a literal is not followed by a <delimiter> or the end of input.
+@node SRFI 209
+@subsection SRFI 209: Enums and Enum Sets
+@cindex SRFI 209
+
+Enums are objects that serve to form sets of distinct classes that
+specify different modes of operation for a procedure. Their use fosters
+portable and readable code.
+
+@menu
+* SRFI 209 Rationale::
+* SRFI 209 R6RS compatibility::
+* SRFI 209 Predicates::
+* SRFI 209 Enum type constructor::
+* SRFI 209 Enum accessors::
+* SRFI 209 Enum finders::
+* SRFI 209 Enum types::
+* SRFI 209 Enum objects::
+* SRFI 209 Comparators::
+* SRFI 209 Enum set constructors::
+* SRFI 209 Enum set predicates::
+* SRFI 209 Enum set accessors::
+* SRFI 209 Enum set mutators::
+* SRFI 209 Enum set operations::
+* SRFI 209 Enum set logical operations::
+* SRFI 209 Syntax::
+@end menu
+
+@node SRFI 209 Rationale
+@subsubsection SRFI 209 Rationale
+
+Many procedures in many libraries accept arguments from a finite set
+(usually a fairly small one), or subsets of a finite set to describe one
+or more modes of operation. Offering a mechanism for dealing with such
+values fosters portable and readable code, much as records do for
+compound values, or multiple values for procedures computing several
+results.
+
+This SRFI provides something related to the @emph{enums} of Java version
+5 and later. These are objects of a type disjoint from all others that
+are grouped into @emph{enum types} (called @emph{enum classes} in Java).
+In Java, each enum type declares the names and types of values
+associated with each object, but in this SRFI an enum object has exactly
+one value; this is useful when translating from C to record the numeric
+value, but has other uses as well.
+
+In this SRFI, each enum has four properties: the enum type to which it
+belongs, its name (a symbol), its ordinal (an exact integer), and its
+value (any object). An enum type provides access to all the enums that
+belong to it by name or ordinal.
+
+@subsubheading Alternatives
+
+In Lisp-family languages, it is traditional to use symbols and lists of
+symbols for this purpose. Symbols have at least two disadvantages: they
+are not ``type-safe'', in the sense that a single symbol may be used in
+more than one logically independent universe of flags; and in Scheme
+symbols do not have associated values (although in Common Lisp they do).
+
+R6RS enums ameliorate these disadvantages by providing ``type-safe''
+sets, which can be stored more efficiently than general lists, possibly
+as integers. However, neither enum types nor enum objects are exposed,
+only enum names and enum sets. This means that R6RS cannot have a
+procedure that takes an enum-type and returns the enum of the type whose
+ordinal number is @emph{n}, nor a procedure that takes an existing
+enum-type and creates an enum-set containing specified enums from it.
+Instead, it must use procedures that return a quasi-curried procedure
+for performing these operations on a specified enum-type. The nearest
+equivalent to an enum object in the sense of this SRFI is a singleton
+enum set. To perform an efficient test of enum set membership, it is
+necessary to use such a singleton, and comparing two such sets for
+equality involves @code{=} rather than @code{eqv?}.
+
+In C, enums have names and numeric values, by default consecutive
+values, but often powers of two or something externally dictated.
+However, the name is not accessible at runtime, and enum types are not
+really disjoint from integer types. (In C++, they are statically
+distinct.)
+
+@subsubheading Enum collections
+
+@emph{Enum sets} are used to represent multiple enums that belong to the
+same type. They provide a subset of the operations provided by
+@url{https://srfi.schemers.org/srfi-113/srfi-113.html, SRFI 113} general
+sets.
+
+Specialized mappings from enums to arbitrary values will be described in
+a future SRFI. Meanwhile either general-purpose hash tables from
+@url{https://srfi.schemers.org/srfi-125/srfi-125.html, SRFI 125} or
+elsewhere, or @url{https://srfi.schemers.org/srfi-146/srfi-146.html,
+SRFI 146} mappings, can be used instead.
+
+@node SRFI 209 R6RS compatibility
+@subsubsection SRFI 209 R6RS compatibility
+
+This SRFI provides the same procedures as the @code{(rnrs enums)}
+library. In that library, neither enum types nor enum objects are
+exposed ---only enum-sets and the names of enums. (There are no enum
+values or ordinals.) Some of the R6RS-specific procedures given below
+operate in those terms and are redundant with other procedures. These
+are deprecated, and have been marked with @samp{[from R6RS,
+deprecated]}.
+
+@node SRFI 209 Predicates
+@subsubsection SRFI 209 Predicates
+
+@deffn {Scheme Procedure} enum-type? obj
+
+Returns @code{#t} if @var{obj} is an enum type, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} enum? obj
+
+Returns @code{#t} if @var{obj} is an enum, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} enum-type-contains? enum-type enum
+
+Returns @code{#t} if @var{enum} belongs to @var{enum-type}, and
+@code{#f} otherwise.
+
+@lisp
+(enum-type-contains? color (enum-name->enum color 'red)) @U{21D2} #t
+(enum-type-contains? pizza (enum-name->enum color 'red)) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum=? enum@sub{0} enum@sub{1} enum @dots{}
+
+Returns @code{#t} if all the arguments are the same enum in the sense of
+@code{eq?} (which is equivalent to having the same name and ordinal) and
+@code{#f} otherwise. It is an error to apply @code{enum=?} to enums
+belonging to different enum types.
+
+@lisp
+(enum=? color-red color-blue) @U{21D2} #f
+(enum=? pizza-funghi (enum-name->enum pizza 'funghi)) @U{21D2} #t
+(enum=? color-red (enum-name->enum color 'red) color-blue) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum<? enum@sub{0} enum@sub{1} enum @dots{}
+@deffnx {Scheme Procedure} enum>? enum@sub{0} enum@sub{1} enum @dots{}
+@deffnx {Scheme Procedure} enum<=? enum@sub{0} enum@sub{1} enum @dots{}
+@deffnx {Scheme Procedure} enum>=? enum@sub{0} enum@sub{1} enum @dots{}
+
+These predicates return @code{#t} if their arguments are enums whose
+ordinals are in increasing, decreasing, non-decreasing, and
+non-increasing order respectively, and @code{#f} otherwise. It is an
+error unless all of the arguments belong to the same enum type.
+
+@lisp
+(enum<? (enum-ordinal->enum color 0) (enum-ordinal->enum color 1))
+@U{21D2} #t
+(enum>? (enum-ordinal->enum color 2) (enum-ordinal->enum color 1)) @U{21D2} #t
+(enum>=? (enum-ordinal->enum color 2)
+ (enum-ordinal->enum color 1)
+ (enum-ordinal->enum color 1))
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum type constructor
+@subsubsection SRFI 209 Enum type constructor
+
+@deffn {Scheme Procedure} make-enum-type list
+
+Returns a newly allocated enum type containing a fixed set of newly
+allocated enums. Both enums and enum types are immutable, and it is not
+possible to create an enum except as part of creating an enum type.
+
+The elements of @var{list} are either symbols or two-element lists,
+where each list has a symbol as the first element and any value as the
+second element. Each list element causes a single enum to be generated,
+and the enum's name is specified by the symbol. It is an error unless
+all the symbols are distinct within an enum type. The position of the
+element in @var{list} is the ordinal of the corresponding enum, so
+ordinals within an enum type are also distinct. If a value is given, it
+becomes the value of the enum; otherwise the enum’s value is the same as
+the ordinal.
+
+The following example enum types will be used in examples throughout
+this SRFI, with the identifier @emph{type-name} referring to the enum of
+type @emph{type} with name @emph{name}.
+
+@lisp
+(define color
+ (make-enum-type '(red orange yellow green cyan blue violet)))
+(define us-traffic-light
+ (make-enum-type '(red yellow green)))
+(define pizza
+ (make-enum-type '((margherita "tomato and mozzarella")
+ (funghi "mushrooms")
+ (chicago "deep-dish")
+ (hawaiian "pineapple and ham"))))
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum accessors
+@subsubsection SRFI 209 Enum accessors
+
+@deffn {Scheme Procedure} enum-type enum
+
+Returns the enum type to which @var{enum} belongs.
+@end deffn
+
+@deffn {Scheme Procedure} enum-name enum
+
+Returns the name (symbol) associated with @var{enum}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-ordinal enum
+
+Returns the ordinal (exact integer) associated with @var{enum}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-value enum
+
+Returns the value associated with @var{enum}.
+@end deffn
+
+@node SRFI 209 Enum finders
+@subsubsection SRFI 209 Enum finders
+
+These procedures use an enum type and one of the properties of an enum
+to find the enum object.
+
+@deffn {Scheme Procedure} enum-name->enum enum-type symbol
+
+If there exists an enum belonging to @var{enum-type} named
+@var{symbol}, returns it; otherwise return @code{#f}.
+
+@lisp
+(enum-name (enum-name->enum color 'green)) @U{21D2} green
+(enum-name->enum color 'mushroom) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-ordinal->enum enum-type exact-integer
+
+If there exists an enum belonging to @var{enum-type} whose ordinal is
+@var{exact-integer}, returns it; otherwise return @code{#f}.
+
+@lisp
+(enum-name (enum-ordinal->enum color 3)) @U{21D2} green
+(enum-ordinal->enum color 10) @U{21D2} #f
+@end lisp
+
+Note: There is no way to find an enum by its value, since values need
+not be unique.
+
+The following convenience procedures provide enum-finding followed by access
+to a property.
+@end deffn
+
+@deffn {Scheme Procedure} enum-name->ordinal enum-type symbol
+
+Returns the ordinal of the enum belonging to @var{enum-type} whose name
+is @var{symbol}. It is an error if there is no such enum.
+
+@lisp
+(enum-name->ordinal color 'blue) @U{21D2} 5
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-name->value enum-type symbol
+
+Returns the value of the enum belonging to @var{enum-type} whose name is
+@var{symbol}. It is an error if there is no such enum.
+
+@lisp
+(enum-name->value pizza 'funghi) @U{21D2} "mushrooms"
+(enum-name->value color 'blue) @U{21D2} 5
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-ordinal->name enum-type exact-integer
+
+Returns the name of the enum belonging to @var{enum-type} whose ordinal
+is @var{exact-integer}. It is an error if there is no such enum.
+
+@lisp
+(enum-ordinal->name color 0) @U{21D2} red
+(enum-ordinal->name pizza 3) @U{21D2} hawaiian
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-ordinal->value enum-type exact-integer
+
+Returns the value of the enum belonging to @var{enum-type} whose ordinal
+is @var{exact-integer}. It is an error if there is no such enum.
+
+@lisp
+(enum-ordinal->value pizza 1) @U{21D2} "mushrooms"
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum types
+@subsubsection SRFI 209 Enum types
+
+@deffn {Scheme Procedure} enum-type-size enum-type
+
+Returns an exact integer equal to the number of enums in
+@var{enum-type}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-min enum-type
+
+Returns the enum belonging to @var{enum-type} whose ordinal is 0.
+
+@lisp
+(enum-name (enum-min color)) @U{21D2} red
+(enum-name (enum-min pizza)) @U{21D2} margherita
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-max enum-type
+
+Returns the enum belonging to @var{enum-type} whose ordinal is equal to
+the number of enums in the enum type minus 1.
+
+@lisp
+(enum-name (enum-max color)) @U{21D2} violet
+(enum-name (enum-max pizza)) @U{21D2} hawaiian
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-type-enums enum-type
+
+Returns a list of the enums belonging to @var{enum-type} ordered by
+increasing ordinal.
+
+@lisp
+(map enum-name (enum-type-enums pizza)) @U{21D2} (margherita funghi chicago hawaiian)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-type-names enum-type
+
+Returns a list of the names of the enums belonging to @var{enum-type}
+ordered by increasing ordinal.
+
+@lisp
+(enum-type-names color)
+@U{21D2} (red orange yellow green cyan blue violet)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-type-values enum-type
+
+Returns a list of the values of the enums belonging to @var{enum-type}
+ordered by increasing ordinal.
+
+@lisp
+(enum-type-values pizza)
+@U{21D2} ("tomato and mozzarella" "mushrooms" "deep-dish" "pineapple and ham")
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum objects
+@subsubsection SRFI 209 Enum objects
+
+@deffn {Scheme Procedure} enum-next enum
+
+Returns the enum that belongs to the same enum type as @var{enum} and
+has an ordinal one greater than @var{enum}. Returns @code{#f} if there
+is no such enum.
+
+@lisp
+(enum-name (enum-next color-red)) @U{21D2} orange
+(enum-next (enum-max color)) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-prev enum
+
+Returns the enum that belongs to the same enum type as @var{enum} and
+has an ordinal one less than @var{enum}. Returns @code{#f} if there is
+no such enum.
+
+@lisp
+(enum-name (enum-prev color-orange)) @U{21D2} red
+(enum-prev (enum-min color)) @U{21D2} #f
+@end lisp
+@end deffn
+
+@node SRFI 209 Comparators
+@subsubsection SRFI 209 Comparators
+
+@deffn {Scheme Procedure} make-enum-comparator enum-type
+
+Returns a @url{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI
+128} comparator suitable for comparing enums that belong to
+@var{enum-type}. The comparator contains both an ordering predicate and
+a hash function, and orders enums based on their ordinal values.
+
+@lisp
+(define pizza-comparator (make-enum-comparator pizza))
+(comparator-hashable? pizza-comparator) @U{21D2} #t
+(comparator-test-type pizza-comparator pizza-funghi) @U{21D2} #t
+(<? pizza-comparator pizza-margherita pizza-chicago) @U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set constructors
+@subsubsection SRFI 209 Enum set constructors
+
+@deffn {Scheme Procedure} enum-empty-set enum-type
+
+Returns an empty enum set that can contain enums of the type
+@var{enum-type}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-type->enum-set enum-type
+
+Returns an enum set containing all the enums that belong to
+@var{enum-type}.
+
+@lisp
+(define color-set (enum-type->enum-set color))
+(define pizza-set (enum-type->enum-set pizza))
+(every (lambda (enum)
+ (enum-set-contains? pizza-set enum))
+ (enum-type-enums pizza))
+@U{21D2} #t
+(enum-set-map->list enum-name color-set)
+@U{21D2} (red orange yellow green cyan blue violet)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set enum-type enum @dots{}
+
+Returns an enum set that can contain enums of the type @var{enum-type}
+and containing the @var{enums}. It is an error unless all the
+@var{enums} belong to @var{enum-type}.
+
+@lisp
+(enum-set-contains? (enum-set color color-red color-blue) color-red)
+@U{21D2} #t
+(enum-set-contains? (enum-set color color-red color-blue) color-orange)
+@U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} list->enum-set enum-type list
+
+Returns an enum set with the specified @var{enum-type} that
+contains the members of @var{list}. It is an error
+unless all the members are enums belonging to @var{enum-type}.
+
+@lisp
+(list->enum-set (enum-type-enums pizza))
+ = (enum-type->enum-set pizza)
+(enum-set-contains? (list->enum-set pizza (list pizza-funghi pizza-chicago))
+ pizza-funghi)
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-projection enum-type-or-setenum-set
+
+If @var{enum-type-or-set} is an enum set, its enum type is extracted and
+used; otherwise, the enum type is used directly. Returns an enum set
+containing the enums belonging to the enum type that have the same names
+as the members of @var{enum-set}, whose enum type need not be not the
+same as the enum-type. It is an error if @var{enum-set} contains an
+enum that does not correspond by name to an enum in the enum type of
+@var{enum-type-or-set}.
+
+@lisp
+(enum-set-projection us-traffic-light
+ (enum-set color color-red color-green color-blue))
+ = (enum-set us-traffic-light
+ us-traffic-light-red us-traffic-light-green)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-copy enum-set
+
+Returns a copy of @var{enum-set}.
+@end deffn
+
+@deffn {Scheme Procedure} make-enumeration symbol-list [from R6RS, deprecated]
+
+Creates a newly allocated enum type. The names are the members of
+@var{symbol-list}, and they appear in the enum set in the order given by
+the list. The values are the same as the names. Then an enum set
+containing all the enums of this enum type is newly allocated and
+returned. The enum type can be retrieved with @code{enum-set-type}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-universe enum-set [from R6RS, deprecated]
+
+Retrieves the enum type of @var{enum-set}, and returns a newly allocated
+enum set containing all the enums of the enum type.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-constructor enum-set [from R6RS, deprecated]
+
+Returns a procedure that accepts one argument, a list of symbols. This
+procedure returns a newly allocated enum set containing the enums whose
+names are members of the list of symbols. It is an error if any of the
+symbols is not the name of an enum in the enum type associated with
+@var{enum-set}.
+@end deffn
+
+@node SRFI 209 Enum set predicates
+@subsubsection SRFI 209 Enum set predicates
+
+@deffn {Scheme Procedure} enum-set? obj
+
+Returns @code{#t} if @var{obj} is an enum-set and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-contains? enum-set enum
+
+Returns @code{#t} if @var{enum} is a member of @var{enum-set}. It is an
+error if @var{enum} does not belong to the same enum type as the members
+of @var{enum-set}.
+
+@lisp
+(enum-set-contains? color-set color-blue) @U{21D2} #t
+(enum-set-contains? (enum-set-delete! color-set color-blue) color-blue) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn enum-set-member? symbol enum-set [from R6RS, deprecated]
+
+Returns @code{#t} if @var{symbol} is the name of a member of
+@var{enum-set}. It is an error if @var{symbol} is not the name of an
+enum belonging to the enum type of @var{enum-set}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-empty? enum-set
+
+Returns @code{#t} if @var{enum-set} is empty, and @code{#f} otherwise.
+
+@lisp
+(enum-set-empty? color-set) @U{21D2} #f
+(enum-set-empty? (enum-set-delete-all! color-set (enum-set->enum-list color-set)))
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-disjoint? enum-set@sub{1} enum-set@sub{2}
+
+Returns @code{#t} if @var{enum-set@sub{1}} and @var{enum-set@sub{2}} do
+not have any enum objects in common, and @code{#f} otherwise. It is an
+error if the members of the enum sets do not belong to the same type.
+
+@lisp
+(define reddish
+ (list->enum-set (map (lambda (name)
+ (enum-name->enum color name))
+ '(red orange))))
+(define ~reddish
+ (list->enum-set (map (lambda (name)
+ (enum-name->enum color name))
+ '(yellow green cyan blue violet))))
+(enum-set-disjoint? color-set reddish) @U{21D2} #f
+(enum-set-disjoint? reddish ~reddish) @U{21D2} #t
+@end lisp
+@end deffn
+
+Note that the following three procedures do not obey the trichotomy law,
+and cannot be used to define a comparator.
+
+@deffn {Scheme Procedure} enum-set=? enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set<? enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set>? enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set<=? enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set>=? enum-set-1 enum-set-2
+
+Returns @code{#t} if the members of @var{enum-set-1} are the same as / a
+proper subset of / a proper superset of / a subset of / a superset of
+@var{enum-set-2}. It is an error if the members of the enum sets do not
+belong to the same type.
+
+@lisp
+(enum-set=? color-set (enum-set-copy color-set)) @U{21D2} #t
+(enum-set=? color-set reddish) @U{21D2} #f
+(enum-set<? reddish color-set) @U{21D2} #t
+(enum-set>? reddish color-set) @U{21D2} #f
+(enum-set<=? reddish color-set) @U{21D2} #t
+(enum-set>=? reddish color-set) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-subset? enum-set-1 enum-set-2
+
+Returns @code{#t} if the set of the names of the elements of
+@var{enum-set-1} is a subset of the set of the names of the elements of
+@var{enum-set-2}. Otherwise returns @code{#f}. Note that
+@var{enum-set-1} and @var{enum-set-2} can be of different enum types.
+
+@lisp
+(enum-set-subset? (enum-set color red blue)
+ (enum-set color red green blue)) @U{21D2} #t
+(enum-set-subset? (enum-set us-traffic-light red green)
+ (enum-set color red green blue)) @U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-any? pred enum-set
+@deffnx {Scheme Procedure} enum-set-every? pred enum-set
+
+Returns @code{#t} if any/every application of @var{proc} to the elements
+of @var{enum-set} returns true, and @code{#f} otherwise.
+
+@lisp
+(enum-set-any? (lambda (e) (eqv? 'green (enum-name e)))
+ color-set)
+@U{21D2} #t
+(enum-set-any? (lambda (e) (eqv? 'green (enum-name e)))
+ reddish)
+@U{21D2} #f
+(enum-set-every? (lambda (e) (eq? 'green (enum-name e)))
+ color-set)
+@U{21D2} #f
+(enum-set-every? (lambda (e) (string? (enum-value e)))
+ pizza-set)
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set accessors
+@subsubsection SRFI 209 Enum set accessors
+
+@deffn {Scheme Procedure} enum-set-type enum-set
+
+Returns the enum type associated with @var{enum-set}.
+@end deffn
+
+@deffn enum-set-indexer enum-set [from R6RS, deprecated]
+
+Returns a procedure that accepts one argument, a symbol. When this
+procedure is called, if the symbol is the name of an enum in the enum
+type associated with @var{enum-set}, then the ordinal of that enum is
+returned. Otherwise, @code{#f} is returned.
+@end deffn
+
+@node SRFI 209 Enum set mutators
+@subsubsection SRFI 209 Enum set mutators
+
+These procedures come in pairs. Procedures whose names end in @samp{!}
+are linear-update: that is, they may or may not modify their
+@var{enum-set} argument, and any existing references to it are
+invalidated. Other procedures are functional and return a newly
+allocated modified copy of their @var{enum-set} argument.
+
+@deffn {Scheme Procedure} enum-set-adjoin enum-set enum @dots{}
+@deffnx {Scheme Procedure} enum-set-adjoin! enum-set enum @dots{}
+
+Returns an enum set that contains the members of @var{enum-set} and the
+@var{enums}. It is an error if the members of the result do not all
+belong to the same enum type.
+
+@lisp
+(define reddish+blue
+ (enum-set-adjoin! (enum-set-copy reddish) color-blue))
+(enum-set<? reddish reddish+blue) @U{21D2} #t
+(enum-set-contains? reddish+blue color-blue) @U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-delete enum-set enum @dots{}
+@deffnx {Scheme Procedure} enum-set-delete! enum-set enum @dots{}
+
+Returns an enum set that contains the members of @var{enum-set}
+excluding the @var{enums}.
+
+@lisp
+(define no-blue
+ (enum-set-delete! (enum-set-copy color-set) color-blue))
+(enum-set<? no-blue color-set) @U{21D2} #t
+(enum-set-contains? no-blue color-blue) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-delete-all enum-set list @dots{}
+@deffnx {Scheme Procedure} enum-set-delete-all! enum-set list @dots{}
+
+Returns an enum set that contains the members of @var{enum-set}
+excluding the members of @var{list}.
+
+@lisp
+(define empty-colors
+ (enum-set-delete-all! (enum-set-copy color-set)
+ (enum-set->enum-list color-set)))
+(enum-set<? empty-colors reddish) @U{21D2} #t
+(enum-set-empty? empty-colors) @U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set operations
+@subsubsection SRFI 209 Enum set operations
+
+@deffn {Scheme Procedure} enum-set-size enum-set
+
+Returns the number of elements in @var{enum-set}.
+
+@lisp
+(enum-set-size (enum-set color color-red color-blue)) @U{21D2} 2
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set->enum-list enum-set
+@deffnx {Scheme Procedure} enum-set->list enum-set [from R6RS, deprecated]
+
+Returns a list containing the members of @var{enum-set}, whereas the
+@code{set->enum-list} procedure returns a list containing the names of
+the members of @var{enum-set}. In either case, the list will be in
+increasing order of the enums.
+
+@lisp
+(map enum-name (enum-set->enum-list reddish)) @U{21D2} (red orange)
+(list->enum-set (enum-set->enum-list color-set)) @U{21D2} color-set
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-count pred enum-set
+
+Returns an exact integer, the number of elements of @var{enum-set} that
+satisfy @var{pred}.
+
+@lisp
+(enum-set-count (lambda (e) (> (enum-ordinal e) 3))
+ color-set)
+@U{21D2} 3
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-filter pred enum-set
+@deffnx {Scheme Procedure} enum-set-remove pred enum-set
+
+Returns an enum set containing the enums in @var{enum-set} that satisfy
+/ do not satisfy @var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-map->list proc enum-set
+
+Invokes @var{proc} on each member of @var{enum-set} in increasing
+ordinal order. The results are made into a list and returned.
+
+@lisp
+(enum-set-map->list enum-name
+ (enum-set-filter (lambda (e) (> (enum-ordinal e) 3))
+ color-set))
+@U{21D2} '(cyan blue violet)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-for-each proc enum-set
+
+Invokes @var{proc} on each member of @var{enum-set} in increasing
+ordinal order and discards the rest. The result is an unspecified
+value.
+
+@lisp
+(let ((s ""))
+ (begin
+ (enum-set-for-each (lambda (e)
+ (set! s (string-append s (enum-value e) " ")))
+ (enum-set pizza pizza-margherita pizza-chicago))
+ s))
+@U{21D2} "tomato and mozzarella deep-dish "
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-fold proc nil enum-set
+
+The current state is initialized to @var{nil}, and @var{proc} is invoked
+on each element of @var{enum-set} in increasing ordinal order and the
+current state, setting the current state to the result. The algorithm
+is repeated until all the elements of @var{enum-set} have been
+processed. Then the current state is returned.
+
+@lisp
+(enum-set-fold cons '() color-set)
+ = (reverse (enum-set->enum-list color-set))
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set logical operations
+@subsubsection SRFI 209 Enum set logical operations
+
+These procedures come in pairs. Procedures whose names end in @code{!}
+are linear-update: that is, they may or may not modify their
+@var{enum-set} argument(s), and any existing references to them are
+invalidated. Other procedures are functional and return a newly
+allocated modified copy of their @var{enum-set} argument.
+
+@deffn {Scheme Procedure} enum-set-complement enum-set
+@deffnx {Scheme Procedure} enum-set-complement! enum-set
+
+Returns an enum set that contains the elements of the enum type of
+@var{enum-set} that are not members of @var{enum-set}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-union enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set-union! enum-set-1 enum-set-2
+
+Returns an enum set containing all the elements of either
+@var{enum-set-1} or @var{enum-set-2}. It is an error if all the
+elements of the result do not belong to the same enum type.
+
+@lisp
+(enum-set-map->list enum-name
+ (enum-set-union! (enum-set color color-orange)
+ (enum-set color color-blue)))
+@U{21D2} (orange blue)
+(enum-set=? color-set (enum-set-union! reddish ~reddish)) @U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-intersection enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set-intersection! enum-set-1 enum-set-2
+
+Returns an enum set containing all the elements that appear in both
+@var{enum-set-1} and @var{enum-set-2}. It is an error if all the
+elements of the result do not belong to the same enum type.
+
+@lisp
+(enum-set-empty? (enum-set-intersection! reddish ~reddish))
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-difference enum-set-1enum-set-2
+@deffnx {Scheme Procedure} enum-set-difference! enum-set-1enum-set-2
+
+Returns an enum set containing the elements of @var{enum-set-1} but not
+@var{enum-set-2}. It is an error if all the elements of the result do
+not belong to the same enum type.
+
+@lisp
+(enum-set=? ~reddish (enum-set-difference! color-set reddish))
+@U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-xor enum-set-1 enum-set-2
+@deffnx {Scheme Procedure} enum-set-xor! enum-set-1enum-set-2
+
+Returns an enum set containing all the elements that appear in either
+@var{enum-set-1} or @var{enum-set-2} but not both. It is an error if all
+the elements of the result do not belong to the same enum type.
+
+@lisp
+(enum-set=? color-set (enum-set-xor! reddish ~reddish))
+@U{21D2} #t
+(enum-set-empty? (enum-set-xor! reddish reddish)) @U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Syntax
+@subsubsection SRFI 209 Syntax
+
+@deffn {Scheme Syntax} define-enum type-name name-value dots{} constructor-syntax
+@deffnx {Scheme Syntax} define-enumeration type-name name-value @dots{} constructor-syntax [from R6RS, deprecated]
+
+These macros allocate a newly created enum type and provide two macros
+for constructing its members and sets of its members. They are
+definitions and can appear anywhere any other definition can appear.
+Each <name-value> is either a symbol naming an enum or a two-element
+list specifying the name and value of an enum.
+
+<Type-name> is an identifier that is bound to a macro. When <type-name>
+is invoked as @samp{(<type-name> <symbol>)}, it returns the enum named
+<symbol> in the case of @code{define-enum} or the symbol itself in the
+case of @code{define-enumeration}. If the symbol does not name any enum
+of the enum-type, an error is signaled.
+
+<Constructor-syntax> is an identifier that is bound to a macro that,
+given any finite sequence of the names of enums, possibly with
+duplicates, expands into an expression that evaluates to an enum set of
+those enums. If any of the symbols does not name any enum of the
+enum-type, an error is signaled.
+
+@end deffn
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/module/srfi/srfi-209.sld b/module/srfi/srfi-209.sld
new file mode 100644
index 000000000..725ebb3fa
--- /dev/null
+++ b/module/srfi/srfi-209.sld
@@ -0,0 +1,60 @@
+(define-library (srfi 209)
+ (import (rnrs syntax-case (6))
+ (scheme base)
+ (scheme case-lambda)
+ (srfi 1)
+ (srfi 125)
+ (srfi 128)
+ (srfi 178))
+
+ (cond-expand
+ ((library (srfi 162))
+ (import (srfi 162)))
+ (else
+ (begin
+ (define real-comparator
+ (make-comparator real? = < number-hash)))))
+
+ (export enum-type? enum? enum-type-contains? enum=? enum<? enum>?
+ enum<=? enum>=?
+
+ make-enum-type
+
+ enum-type enum-name enum-ordinal enum-value
+
+ enum-name->enum enum-ordinal->enum enum-name->ordinal
+ enum-name->value enum-ordinal->name enum-ordinal->value
+
+ enum-type-size enum-min enum-max enum-type-enums
+ enum-type-names enum-type-values
+
+ enum-next enum-prev
+
+ enum-type->enum-set enum-set list->enum-set enum-set-projection
+ enum-set-copy enum-empty-set make-enumeration enum-set-universe
+ enum-set-constructor enum-set-type enum-set-indexer
+
+ enum-set? enum-set-contains? enum-set=? enum-set-member?
+ enum-set-empty? enum-set-disjoint? enum-set<? enum-set>?
+ enum-set<=? enum-set>=? enum-set-any? enum-set-every?
+ enum-set-subset?
+
+ enum-set-adjoin! enum-set-delete! enum-set-delete-all!
+ enum-set-adjoin enum-set-delete enum-set-delete-all
+
+ enum-set-size enum-set->list enum-set-map->list enum-set-for-each
+ enum-set-filter enum-set-remove enum-set-count enum-set-fold
+ enum-set->enum-list
+ enum-set-filter! enum-set-remove!
+
+ enum-set-union enum-set-intersection enum-set-difference
+ enum-set-xor enum-set-complement enum-set-union!
+ enum-set-intersection! enum-set-difference! enum-set-xor!
+ enum-set-complement!
+
+ make-enum-comparator
+
+ define-enum define-enumeration
+ )
+
+ (include "srfi-209/209.scm"))
diff --git a/module/srfi/srfi-209/209.scm b/module/srfi/srfi-209/209.scm
new file mode 100644
index 000000000..0429ab2c6
--- /dev/null
+++ b/module/srfi/srfi-209/209.scm
@@ -0,0 +1,690 @@
+;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included
+;;; in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+;;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;; Utility
+
+(define-syntax assert
+ (syntax-rules ()
+ ((assert expr)
+ (unless expr
+ (error "assertion failed" 'expr)))
+ ((assert expr msg)
+ (unless expr
+ (error msg 'expr)))))
+
+(define (exact-natural? obj)
+ (and (exact-integer? obj) (not (negative? obj))))
+
+(define (bitvector-subset? vec1 vec2)
+ (let loop ((i (- (bitvector-length vec1) 1)))
+ (cond ((< i 0) #t)
+ ((and (bitvector-ref/bool vec1 i)
+ (zero? (bitvector-ref/int vec2 i)))
+ #f)
+ (else (loop (- i 1))))))
+
+;;;; Types
+
+(define-record-type <enum-type>
+ (make-raw-enum-type enum-vector name-table comparator)
+ enum-type?
+ (enum-vector enum-type-enum-vector set-enum-type-enum-vector!)
+ (name-table enum-type-name-table set-enum-type-name-table!)
+ (comparator enum-type-comparator set-enum-type-comparator!))
+
+(define-record-type <enum>
+ (make-enum type name ordinal value)
+ enum?
+ (type enum-type)
+ (name enum-name)
+ (ordinal enum-ordinal)
+ (value enum-value))
+
+(define (make-enum-type names+vals)
+ (assert (or (pair? names+vals) (null? names+vals))
+ "argument must be a proper list")
+ (let* ((type (make-raw-enum-type #f #f #f))
+ (enums (generate-enums type names+vals)))
+ (set-enum-type-enum-vector! type (list->vector enums))
+ (set-enum-type-name-table! type (make-name-table enums))
+ (set-enum-type-comparator! type (make-enum-comparator type))
+ type))
+
+(define (generate-enums type names+vals)
+ (map (lambda (elt ord)
+ (cond ((and (pair? elt) (= 2 (length elt)) (symbol? (car elt)))
+ (make-enum type (car elt) ord (cadr elt)))
+ ((symbol? elt) (make-enum type elt ord ord))
+ (else (error "make-enum-type: invalid argument" elt))))
+ names+vals
+ (iota (length names+vals))))
+
+(define symbol-comparator
+ (make-comparator symbol?
+ eqv?
+ (lambda (sym1 sym2)
+ (string<? (symbol->string sym1)
+ (symbol->string sym2)))
+ symbol-hash))
+
+(define (make-name-table enums)
+ (hash-table-unfold null?
+ (lambda (enums)
+ (values (enum-name (car enums)) (car enums)))
+ cdr
+ enums
+ symbol-comparator))
+
+(define (%enum-type=? etype1 etype2)
+ (eqv? etype1 etype2))
+
+(define (make-enum-comparator type)
+ (make-comparator
+ (lambda (obj)
+ (and (enum? obj) (eq? (enum-type obj) type)))
+ eq?
+ (lambda (enum1 enum2)
+ (< (enum-ordinal enum1) (enum-ordinal enum2)))
+ (lambda (enum)
+ (symbol-hash (enum-name enum)))))
+
+;;;; Predicates
+
+(define (enum-type-contains? type enum)
+ (assert (enum-type? type))
+ (assert (enum? enum))
+ ((comparator-type-test-predicate (enum-type-comparator type)) enum))
+
+(define (%enum-type-contains?/no-assert type enum)
+ ((comparator-type-test-predicate (enum-type-comparator type)) enum))
+
+(define (%well-typed-enum? type obj)
+ (and (enum? obj) (%enum-type-contains?/no-assert type obj)))
+
+(define (%compare-enums compare enums)
+ (assert (and (pair? enums) (pair? (cdr enums)))
+ "invalid number of arguments")
+ (assert (enum? (car enums)))
+ (let ((type (enum-type (car enums))))
+ (assert (every (lambda (e) (%well-typed-enum? type e)) (cdr enums))
+ "enums must all belong to the same type")
+ (apply compare (enum-type-comparator type) enums)))
+
+(define (enum=? enum1 enum2 . enums)
+ (assert (enum? enum1))
+ (let* ((type (enum-type enum1))
+ (comp (enum-type-comparator type)))
+ (cond ((null? enums) ; fast path
+ (assert (%well-typed-enum? type enum2)
+ "enums must all belong to the same type")
+ ((comparator-equality-predicate comp) enum1 enum2))
+ (else ; variadic path
+ (assert (every (lambda (e) (%well-typed-enum? type e)) enums)
+ "enums must all belong to the same type")
+ (apply =? comp enum1 enum2 enums)))))
+
+(define (enum<? . enums) (%compare-enums <? enums))
+
+(define (enum>? . enums) (%compare-enums >? enums))
+
+(define (enum<=? . enums) (%compare-enums <=? enums))
+
+(define (enum>=? . enums) (%compare-enums >=? enums))
+
+;;;; Enum finders
+
+;;; Core procedures
+
+(define (enum-name->enum type name)
+ (assert (enum-type? type))
+ (assert (symbol? name))
+ (hash-table-ref/default (enum-type-name-table type) name #f))
+
+(define (enum-ordinal->enum enum-type ordinal)
+ (assert (enum-type? enum-type))
+ (assert (exact-natural? ordinal))
+ (and (< ordinal (enum-type-size enum-type))
+ (vector-ref (enum-type-enum-vector enum-type) ordinal)))
+
+;; Fast version for internal use.
+(define (%enum-ordinal->enum-no-assert enum-type ordinal)
+ (vector-ref (enum-type-enum-vector enum-type) ordinal))
+
+;;; Derived procedures
+
+(define (%enum-project type finder key proc)
+ (assert (enum-type? type))
+ (cond ((finder type key) => proc)
+ (else (error "no enum found" type key))))
+
+(define (enum-name->ordinal type name)
+ (assert (symbol? name))
+ (%enum-project type enum-name->enum name enum-ordinal))
+
+(define (enum-name->value type name)
+ (assert (symbol? name))
+ (%enum-project type enum-name->enum name enum-value))
+
+(define (enum-ordinal->name type ordinal)
+ (assert (exact-natural? ordinal))
+ (%enum-project type %enum-ordinal->enum-no-assert ordinal enum-name))
+
+(define (enum-ordinal->value type ordinal)
+ (assert (exact-natural? ordinal))
+ (%enum-project type %enum-ordinal->enum-no-assert ordinal enum-value))
+
+;;;; Enum type accessors
+
+(define (enum-type-size type)
+ (assert (enum-type? type))
+ (vector-length (enum-type-enum-vector type)))
+
+(define (enum-min type)
+ (assert (enum-type? type))
+ (vector-ref (enum-type-enum-vector type) 0))
+
+(define (enum-max type)
+ (assert (enum-type? type))
+ (let ((vec (enum-type-enum-vector type)))
+ (vector-ref vec (- (vector-length vec) 1))))
+
+(define (enum-type-enums type)
+ (assert (enum-type? type))
+ (vector->list (enum-type-enum-vector type)))
+
+(define (enum-type-names type)
+ (assert (enum-type? type))
+ (let ((vec (enum-type-enum-vector type)))
+ (list-tabulate (vector-length vec)
+ (lambda (n) (enum-name (vector-ref vec n))))))
+
+(define (enum-type-values type)
+ (assert (enum-type? type))
+ (let ((vec (enum-type-enum-vector type)))
+ (list-tabulate (vector-length vec)
+ (lambda (n) (enum-value (vector-ref vec n))))))
+
+;;;; Enum object procedures
+
+(define (enum-next enum)
+ (assert (enum? enum))
+ (enum-ordinal->enum (enum-type enum) (+ (enum-ordinal enum) 1)))
+
+(define (enum-prev enum)
+ (assert (enum? enum))
+ (let ((ord (enum-ordinal enum)))
+ (and (> ord 0)
+ (enum-ordinal->enum (enum-type enum) (- ord 1)))))
+
+;;;; Enum set constructors
+
+(define-record-type <enum-set>
+ (make-enum-set type bitvector)
+ enum-set?
+ (type enum-set-type)
+ (bitvector enum-set-bitvector set-enum-set-bitvector!))
+
+(define (enum-empty-set type)
+ (assert (enum-type? type))
+ (make-enum-set type (make-bitvector (enum-type-size type) #f)))
+
+(define (enum-type->enum-set type)
+ (assert (enum-type? type))
+ (make-enum-set type (make-bitvector (enum-type-size type) #t)))
+
+(define (enum-set type . enums) (list->enum-set type enums))
+
+(define (list->enum-set type enums)
+ (assert (or (pair? enums) (null? enums))
+ "argument must be a proper list")
+ (let ((vec (make-bitvector (enum-type-size type) #f)))
+ (for-each (lambda (e)
+ (assert (%well-typed-enum? type e) "ill-typed enum")
+ (bitvector-set! vec (enum-ordinal e) #t))
+ enums)
+ (make-enum-set type vec)))
+
+;; Returns a set of enums drawn from the enum-type/-set src with
+;; the same names as the enums of eset.
+(define (enum-set-projection src eset)
+ (assert (or (enum-type? src) (enum-set? src))
+ "argument must be an enum type or enum set")
+ (assert (enum-set? eset))
+ (let ((type (if (enum-type? src) src (enum-set-type src))))
+ (list->enum-set
+ type
+ (enum-set-map->list
+ (lambda (enum)
+ (let ((name (enum-name enum)))
+ (or (enum-name->enum type name)
+ (error "enum name not found in type" name type))))
+ eset))))
+
+(define (enum-set-copy eset)
+ (make-enum-set (enum-set-type eset)
+ (bitvector-copy (enum-set-bitvector eset))))
+
+;; [Deprecated]
+(define (make-enumeration names)
+ (enum-type->enum-set (make-enum-type (zip names names))))
+
+;; [Deprecated]
+(define (enum-set-universe eset)
+ (assert (enum-set? eset))
+ (enum-type->enum-set (enum-set-type eset)))
+
+;; [Deprecated] Returns a procedure which takes a list of symbols
+;; and returns an enum set containing the corresponding enums. This
+;; extracts the type of eset, but otherwise ignores this argument.
+(define (enum-set-constructor eset)
+ (assert (enum-set? eset))
+ (let ((type (enum-set-type eset)))
+ (lambda (names)
+ (list->enum-set type
+ (map (lambda (sym)
+ (or (enum-name->enum type sym)
+ (error "invalid enum name" sym)))
+ names)))))
+
+;; [Deprecated] Returns a procedure which takes a symbol and returns
+;; the corresponding enum ordinal or #f. This doesn't make any use
+;; of eset, beyond pulling out its enum type.
+(define (enum-set-indexer eset)
+ (assert (enum-set? eset))
+ (let ((type (enum-set-type eset)))
+ (lambda (name)
+ (cond ((enum-name->enum type name) => enum-ordinal)
+ (else #f)))))
+
+;;;; Enum set predicates
+
+(define (enum-set-contains? eset enum)
+ (assert (enum-set? eset))
+ (assert (%well-typed-enum? (enum-set-type eset) enum)
+ "enum types of arguments must match")
+ (bitvector-ref/bool (enum-set-bitvector eset) (enum-ordinal enum)))
+
+;; FIXME: Avoid double (type, then set) lookup.
+(define (enum-set-member? name eset)
+ (assert (symbol? name))
+ (assert (enum-set? eset))
+ (bitvector-ref/bool (enum-set-bitvector eset)
+ (enum-name->ordinal (enum-set-type eset) name)))
+
+(define (%enum-set-type=? eset1 eset2)
+ (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)))
+
+(define (enum-set-empty? eset)
+ (assert (enum-set? eset))
+ (zero? (bitvector-count #t (enum-set-bitvector eset))))
+
+(define (bit-nand a b)
+ (not (and (= 1 a) (= 1 b))))
+
+(define (enum-set-disjoint? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (let ((vec1 (enum-set-bitvector eset1))
+ (vec2 (enum-set-bitvector eset2)))
+ (let ((len (bitvector-length vec1)))
+ (let loop ((i 0))
+ (or (= i len)
+ (and (bit-nand (bitvector-ref/int vec1 i)
+ (bitvector-ref/int vec2 i))
+ (loop (+ i 1))))))))
+
+(define (enum-set=? eset1 eset2)
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (bitvector=? (enum-set-bitvector eset1) (enum-set-bitvector eset2)))
+
+(define (enum-set<? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (let ((vec1 (enum-set-bitvector eset1))
+ (vec2 (enum-set-bitvector eset2)))
+ (and (bitvector-subset? vec1 vec2)
+ (not (bitvector=? vec1 vec2)))))
+
+(define (enum-set>? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (let ((vec1 (enum-set-bitvector eset1))
+ (vec2 (enum-set-bitvector eset2)))
+ (and (bitvector-subset? vec2 vec1)
+ (not (bitvector=? vec1 vec2)))))
+
+(define (enum-set<=? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (bitvector-subset? (enum-set-bitvector eset1)
+ (enum-set-bitvector eset2)))
+
+(define (enum-set>=? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))
+ "arguments must have the same enum type")
+ (bitvector-subset? (enum-set-bitvector eset2)
+ (enum-set-bitvector eset1)))
+
+;; This uses lists as sets and is thus not very efficient.
+;; An implementation with SRFI 113 or some other set library
+;; might want to optimize this.
+(define (enum-set-subset? eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (lset<= eqv?
+ (enum-set-map->list enum-name eset1)
+ (enum-set-map->list enum-name eset2)))
+
+(define (enum-set-any? pred eset)
+ (assert (procedure? pred))
+ (call-with-current-continuation
+ (lambda (return)
+ (enum-set-fold (lambda (e _) (and (pred e) (return #t)))
+ #f
+ eset))))
+
+(define (enum-set-every? pred eset)
+ (assert (procedure? pred))
+ (call-with-current-continuation
+ (lambda (return)
+ (enum-set-fold (lambda (e _) (or (pred e) (return #f)))
+ #t
+ eset))))
+
+;;;; Enum set mutators
+
+(define (enum-set-adjoin eset . enums)
+ (apply enum-set-adjoin! (enum-set-copy eset) enums))
+
+(define enum-set-adjoin!
+ (case-lambda
+ ((eset enum) ; fast path
+ (assert (enum-set? eset))
+ (assert (%well-typed-enum? (enum-set-type eset) enum)
+ "arguments must have the same enum type")
+ (bitvector-set! (enum-set-bitvector eset) (enum-ordinal enum) #t)
+ eset)
+ ((eset . enums) ; variadic path
+ (assert (enum-set? eset))
+ (let ((type (enum-set-type eset))
+ (vec (enum-set-bitvector eset)))
+ (for-each (lambda (e)
+ (assert (%well-typed-enum? type e)
+ "arguments must have the same enum type")
+ (bitvector-set! vec (enum-ordinal e) #t))
+ enums)
+ eset))))
+
+(define (enum-set-delete eset . enums)
+ (apply enum-set-delete! (enum-set-copy eset) enums))
+
+(define enum-set-delete!
+ (case-lambda
+ ((eset enum) ; fast path
+ (assert (enum-set? eset))
+ (assert (%well-typed-enum? (enum-set-type eset) enum)
+ "arguments must have the same enum type")
+ (bitvector-set! (enum-set-bitvector eset) (enum-ordinal enum) #f)
+ eset)
+ ((eset . enums) ; variadic path
+ (enum-set-delete-all! eset enums))))
+
+(define (enum-set-delete-all eset enums)
+ (enum-set-delete-all! (enum-set-copy eset) enums))
+
+(define (enum-set-delete-all! eset enums)
+ (assert (enum-set? eset))
+ (assert (or (pair? enums) (null? enums))
+ "argument must be a proper list")
+ (unless (null? enums)
+ (let ((type (enum-set-type eset))
+ (vec (enum-set-bitvector eset)))
+ (for-each (lambda (e)
+ (assert (%well-typed-enum? type e)
+ "arguments must have the same enum type")
+ (bitvector-set! vec (enum-ordinal e) #f))
+ enums)))
+ eset)
+
+;;;; Enum set operations
+
+(define (enum-set-size eset)
+ (assert (enum-set? eset))
+ (bitvector-count #t (enum-set-bitvector eset)))
+
+(define (enum-set->enum-list eset)
+ (assert (enum-set? eset))
+ (enum-set-map->list values eset))
+
+(define (enum-set->list eset)
+ (enum-set-map->list enum-name eset))
+
+;; Slightly complicated by the order in which proc is applied.
+(define (enum-set-map->list proc eset)
+ (assert (procedure? proc))
+ (assert (enum-set? eset))
+ (let* ((vec (enum-set-bitvector eset))
+ (len (bitvector-length vec))
+ (type (enum-set-type eset)))
+ (letrec
+ ((build
+ (lambda (i)
+ (cond ((= i len) '())
+ ((bitvector-ref/bool vec i)
+ (cons (proc (%enum-ordinal->enum-no-assert type i))
+ (build (+ i 1))))
+ (else (build (+ i 1)))))))
+ (build 0))))
+
+(define (enum-set-count pred eset)
+ (assert (procedure? pred))
+ (enum-set-fold (lambda (e n) (if (pred e) (+ n 1) n)) 0 eset))
+
+(define (enum-set-filter pred eset)
+ (enum-set-filter! pred (enum-set-copy eset)))
+
+(define (enum-set-filter! pred eset)
+ (assert (procedure? pred))
+ (assert (enum-set? eset))
+ (let* ((type (enum-set-type eset))
+ (vec (enum-set-bitvector eset)))
+ (let loop ((i (- (bitvector-length vec) 1)))
+ (cond ((< i 0) eset)
+ ((and (bitvector-ref/bool vec i)
+ (not (pred (%enum-ordinal->enum-no-assert type i))))
+ (bitvector-set! vec i #f)
+ (loop (- i 1)))
+ (else (loop (- i 1)))))))
+
+(define (enum-set-remove pred eset)
+ (enum-set-remove! pred (enum-set-copy eset)))
+
+(define (enum-set-remove! pred eset)
+ (assert (procedure? pred))
+ (assert (enum-set? eset))
+ (let* ((type (enum-set-type eset))
+ (vec (enum-set-bitvector eset)))
+ (let loop ((i (- (bitvector-length vec) 1)))
+ (cond ((< i 0) eset)
+ ((and (bitvector-ref/bool vec i)
+ (pred (%enum-ordinal->enum-no-assert type i)))
+ (bitvector-set! vec i #f)
+ (loop (- i 1)))
+ (else (loop (- i 1)))))))
+
+(define (enum-set-for-each proc eset)
+ (assert (procedure? proc))
+ (enum-set-fold (lambda (e _) (proc e)) '() eset))
+
+(define (enum-set-fold proc nil eset)
+ (assert (procedure? proc))
+ (assert (enum-set? eset))
+ (let ((type (enum-set-type eset)))
+ (let* ((vec (enum-set-bitvector eset))
+ (len (bitvector-length vec)))
+ (let loop ((i 0) (state nil))
+ (cond ((= i len) state)
+ ((bitvector-ref/bool vec i)
+ (loop (+ i 1)
+ (proc (%enum-ordinal->enum-no-assert type i) state)))
+ (else (loop (+ i 1) state)))))))
+
+;;;; Enum set logical operations
+
+(define (%enum-set-logical-op! bv-proc eset1 eset2)
+ (assert (enum-set? eset1))
+ (assert (enum-set? eset2))
+ (assert (%enum-set-type=? eset1 eset2)
+ "arguments must have the same enum type")
+ (bv-proc (enum-set-bitvector eset1) (enum-set-bitvector eset2))
+ eset1)
+
+(define (enum-set-union eset1 eset2)
+ (%enum-set-logical-op! bitvector-ior! (enum-set-copy eset1) eset2))
+
+(define (enum-set-intersection eset1 eset2)
+ (%enum-set-logical-op! bitvector-and! (enum-set-copy eset1) eset2))
+
+(define (enum-set-difference eset1 eset2)
+ (%enum-set-logical-op! bitvector-andc2! (enum-set-copy eset1) eset2))
+
+(define (enum-set-xor eset1 eset2)
+ (%enum-set-logical-op! bitvector-xor! (enum-set-copy eset1) eset2))
+
+(define (enum-set-union! eset1 eset2)
+ (%enum-set-logical-op! bitvector-ior! eset1 eset2))
+
+(define (enum-set-intersection! eset1 eset2)
+ (%enum-set-logical-op! bitvector-and! eset1 eset2))
+
+(define (enum-set-difference! eset1 eset2)
+ (%enum-set-logical-op! bitvector-andc2! eset1 eset2))
+
+(define (enum-set-xor! eset1 eset2)
+ (%enum-set-logical-op! bitvector-xor! eset1 eset2))
+
+(define (enum-set-complement eset)
+ (enum-set-complement! (enum-set-copy eset)))
+
+(define (enum-set-complement! eset)
+ (assert (enum-set? eset))
+ (bitvector-not! (enum-set-bitvector eset))
+ eset)
+
+;;;; Syntax
+
+;; Defines a new enum-type T, binds type-name to a macro which takes a
+;; symbol to an enum in T, and binds constructor to a macro taking
+;; symbols to an enum set of type T. This is the newer syntax-case
+;; based version found in 'contrib/zipheir/define-enum-sc.scm' that
+;; does a lot of the work at expansion time.
+(define-syntax define-enum
+ (lambda (stx)
+ (define (parse-name-val nv-syn)
+ (syntax-case nv-syn ()
+ (id (identifier? #'id) #'id)
+ ((id _) (identifier? #'id) #'id)
+ (_ (syntax-violation 'define-enum
+ "invalid enum syntax" stx nv-syn))))
+
+ (define (unique-ids? ids)
+ (let unique ((ids ids))
+ (or (null? ids)
+ (let ((id (car ids)) (rest (cdr ids)))
+ (and (not (find (lambda (x) (free-identifier=? x id))
+ rest))
+ (unique rest))))))
+
+ (syntax-case stx ()
+ ((_ type-name (name-val ...) constructor)
+ (and (identifier? #'type-name)
+ (identifier? #'constructor))
+ (with-syntax (((name ...) (map parse-name-val #'(name-val ...)))
+ ((idx ...) (iota (length #'(name-val ...)))))
+ (unless (unique-ids? #'(name ...))
+ (syntax-violation 'define-enum
+ "duplicated enum names" stx #'(quote (name ...))))
+ (syntax
+ (begin
+ (define new-type (make-enum-type '(name-val ...)))
+
+ ;; Helper
+ (define-syntax enum-name-to-ordinal-syn
+ (syntax-rules (name ...)
+ ((_ loc name) idx) ...
+ ((_ loc x)
+ (syntax-violation 'loc "invalid enum name" 'x))))
+
+ (define-syntax type-name
+ (syntax-rules ()
+ ((_ (x . _))
+ (syntax-violation 'type-name "invalid syntax" 'x))
+ ((_ id)
+ (%enum-ordinal->enum-no-assert
+ new-type
+ (enum-name-to-ordinal-syn type-name id)))))
+
+ (... ; escape ellipsis for the following
+ (define-syntax constructor
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ arg ...)
+ (every identifier? #'(arg ...))
+ (let ((vec (make-bitvector (enum-type-size new-type)
+ #f)))
+ ;; Unroll for-each loop
+ (bitvector-set!
+ vec
+ (enum-name-to-ordinal-syn constructor arg)
+ #t) ...
+ (make-enum-set new-type vec))))))))))))))
+
+;; [Deprecated] As define-enum, except that type-name is bound to
+;; a macro that returns its symbol argument if the corresponding
+;; enum is in the new type.
+(define-syntax define-enumeration
+ (syntax-rules ()
+ ((_ type-name (name-val ...) constructor)
+ (begin
+ (define etype (make-enum-type '(name-val ...)))
+ (define-syntax type-name
+ (syntax-rules ()
+ ((_ name)
+ (and (enum-name->enum etype 'name) 'name))))
+ (define-syntax constructor
+ (syntax-rules ()
+ ((_ . names)
+ (list->enum-set etype
+ (map (lambda (s)
+ (enum-name->enum etype s))
+ 'names)))))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 6ee26e869..2b5156923 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -170,6 +170,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-160.test \
tests/srfi-171.test \
tests/srfi-178.test \
+ tests/srfi-209.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
@@ -231,6 +232,7 @@ EXTRA_DIST = \
tests/srfi-178-test/quasi-ints.scm \
tests/srfi-178-test/quasi-string.scm \
tests/srfi-178-test/selectors.scm \
+ tests/srfi-209-test.scm \
ChangeLog-2008
\f
diff --git a/test-suite/tests/srfi-209-test.scm b/test-suite/tests/srfi-209-test.scm
new file mode 100644
index 000000000..1c0c9f8ca
--- /dev/null
+++ b/test-suite/tests/srfi-209-test.scm
@@ -0,0 +1,465 @@
+;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included
+;;; in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+;;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; SRFI 64-flavored test suite for SRFI 209.
+
+;;;; Utility
+
+(define-syntax constantly
+ (syntax-rules ()
+ ((_ obj) (lambda _ obj))))
+
+(define always (constantly #t))
+(define never (constantly #f))
+
+;; Run a procedure on fresh copies of two enum sets.
+(define (fresh-sets proc eset1 eset2)
+ (proc (enum-set-copy eset1) (enum-set-copy eset2)))
+
+;;;; Test types
+
+(define color-names
+ '(red tangerine orange yellow green cyan blue violet))
+
+(define color (make-enum-type color-names))
+
+(define color-red (enum-name->enum color 'red))
+
+(define color-tangerine (enum-name->enum color 'tangerine))
+
+(define color-blue (enum-name->enum color 'blue))
+
+(define color-green (enum-name->enum color 'green))
+
+(define color-set (enum-type->enum-set color))
+
+(define reddish (list->enum-set
+ color
+ (map (lambda (name)
+ (enum-name->enum color name))
+ (take color-names 3))))
+
+(define ~reddish (list->enum-set
+ color
+ (map (lambda (ord)
+ (enum-name->enum color ord))
+ (drop color-names 3))))
+
+(define empty-colors (enum-empty-set color))
+
+(define pizza-descriptions
+ '((margherita "tomato and mozzarella")
+ (funghi "mushrooms")
+ (bianca "ricotta and mozzarella")
+ (chicago "deep-dish")
+ (hawaiian "pineapple and ham")))
+
+(define pizza-names (map car pizza-descriptions))
+
+(define pizza (make-enum-type pizza-descriptions))
+
+(define pizza-chicago (enum-name->enum pizza 'chicago))
+(define pizza-bianca (enum-name->enum pizza 'bianca))
+
+;;;; Finders and enum accessors
+
+;;; Later tests make heavy use of these, so test these first.
+
+(test-group "Finders and accessors"
+ (test-eqv 'red (enum-name (enum-name->enum color 'red)))
+ (test-eqv 0 (enum-ordinal (enum-name->enum color 'red)))
+ (test-eqv #t (eqv? color (enum-type (enum-name->enum color 'red))))
+ (test-eqv 'red (enum-name (enum-ordinal->enum color 0)))
+ (test-eqv 0 (enum-ordinal (enum-ordinal->enum color 0)))
+ (test-eqv #t (eqv? color (enum-type (enum-ordinal->enum color 0))))
+ (test-eqv #t (eqv? (enum-name->enum color 'red) (enum-ordinal->enum color 0)))
+ (test-equal "deep-dish" (enum-value (enum-name->enum pizza 'chicago)))
+
+ (test-eqv 0 (enum-name->ordinal color 'red))
+ (test-eqv 6 (enum-name->ordinal color 'blue))
+ (test-equal "mushrooms" (enum-name->value pizza 'funghi))
+ (test-eqv (enum-name->ordinal color 'blue) (enum-name->value color 'blue))
+ (test-eqv 'red (enum-ordinal->name color 0))
+ (test-eqv 'chicago (enum-ordinal->name pizza 3))
+ (test-equal "mushrooms" (enum-ordinal->value pizza 1))
+ (test-eqv 6 (enum-ordinal->value color 6))
+)
+
+(test-group "Enum type constructors"
+ ;; Mixing name and name+value args.
+ (test-eqv #t (enum-type?
+ (make-enum-type
+ '(vanilla (chocolate 2) strawberry (pistachio 4))))))
+
+;;;; Predicates
+
+(test-group "Predicates"
+ (test-eqv #t (enum? color-red))
+ (test-eqv #f (enum? 'z)) ; Ensure enums aren't just symbols.
+
+ (test-eqv #t (every (lambda (e) (enum-type-contains? color e))
+ (map (lambda (s)
+ (enum-name->enum color s))
+ color-names)))
+ (test-eqv #f (any (lambda (e) (enum-type-contains? color e))
+ (map (lambda (s) (enum-name->enum pizza s)) pizza-names)))
+
+ (test-eqv #t (enum=? color-red (enum-ordinal->enum color 0)))
+ (test-eqv #f (enum=? color-red color-tangerine))
+ (test-eqv #t (enum=? color-red color-red color-red))
+ (test-eqv #f (enum=? color-red color-red color-tangerine))
+
+ (test-eqv #t (enum<? color-red color-tangerine))
+ (test-eqv #f (enum<? color-tangerine color-tangerine))
+ (test-eqv #f (enum<? color-tangerine color-red))
+ (test-eqv #t (enum<? color-red color-green color-blue))
+ (test-eqv #f (enum<? color-red color-blue color-blue))
+ (test-eqv #f (enum>? color-red color-tangerine))
+ (test-eqv #f (enum>? color-tangerine color-tangerine))
+ (test-eqv #t (enum>? color-tangerine color-red))
+ (test-eqv #t (enum>? color-blue color-green color-red))
+ (test-eqv #f (enum>? color-blue color-red color-red))
+ (test-eqv #t (enum<=? color-red color-tangerine))
+ (test-eqv #t (enum<=? color-tangerine color-tangerine))
+ (test-eqv #f (enum<=? color-tangerine color-red))
+ (test-eqv #t (enum<=? color-red color-blue color-blue))
+ (test-eqv #f (enum<=? color-blue color-blue color-red))
+ (test-eqv #f (enum>=? color-red color-tangerine))
+ (test-eqv #t (enum>=? color-tangerine color-tangerine))
+ (test-eqv #t (enum>=? color-tangerine color-red))
+ (test-eqv #t (enum>=? color-blue color-red color-red))
+ (test-eqv #f (enum>=? color-blue color-red color-blue))
+)
+
+;;;; Enum type accessors
+
+(test-group "Enum type accessors"
+ (test-eqv (length color-names) (enum-type-size color))
+ (test-eqv (length pizza-names) (enum-type-size pizza))
+ (test-eqv 'red (enum-name (enum-min color)))
+ (test-eqv 'margherita (enum-name (enum-min pizza)))
+ (test-eqv 'violet (enum-name (enum-max color)))
+ (test-eqv 'hawaiian (enum-name (enum-max pizza)))
+
+ (test-eqv (enum-type-size color) (length (enum-type-enums color)))
+ (test-equal color-names (map enum-name (enum-type-enums color)))
+ (test-equal (iota (enum-type-size color))
+ (map enum-ordinal (enum-type-enums color)))
+ (test-equal (map cadr pizza-descriptions)
+ (map enum-value (enum-type-enums pizza)))
+
+ (test-equal color-names (enum-type-names color))
+ (test-equal pizza-names (enum-type-names pizza))
+ (test-equal (map cadr pizza-descriptions) (enum-type-values pizza))
+ (test-equal (iota (enum-type-size color)) (enum-type-values color))
+)
+
+(test-group "Enum operations"
+ (test-eqv #t (enum=? (enum-next color-red) color-tangerine))
+ (test-eqv #t (enum=? (enum-prev color-tangerine) color-red))
+ (test-eqv #t (enum=? (enum-next pizza-bianca) pizza-chicago))
+ (test-eqv #t (enum=? (enum-prev pizza-chicago) pizza-bianca))
+ (test-eqv #f (enum-next (enum-max color)) )
+ (test-eqv #f (enum-prev (enum-min color)) )
+)
+
+;;;; Enum comparators
+
+(test-group "Enum comparators"
+ (let ((pizza-comparator (make-enum-comparator pizza)))
+ (test-eqv #t (comparator? pizza-comparator))
+ (test-eqv #t (comparator-ordered? pizza-comparator))
+ (test-eqv #t (comparator-hashable? pizza-comparator))
+
+ (test-eqv #t (every (lambda (e) (comparator-test-type pizza-comparator e))
+ (enum-type-enums pizza)))
+ (test-eqv #f (any (lambda (e) (comparator-test-type pizza-comparator e))
+ (enum-type-enums color)))
+
+ (test-eqv #t (=? pizza-comparator
+ pizza-chicago
+ (enum-name->enum pizza 'chicago)))
+
+ (test-eqv #f (=? pizza-comparator pizza-bianca pizza-chicago))
+ (test-eqv #t (<? pizza-comparator pizza-bianca pizza-chicago))
+ (test-eqv #f (<? pizza-comparator pizza-bianca pizza-bianca))
+ (test-eqv #f (<? pizza-comparator pizza-chicago pizza-bianca))
+ (test-eqv #f (>? pizza-comparator pizza-bianca pizza-chicago))
+ (test-eqv #f (>? pizza-comparator pizza-bianca pizza-bianca))
+ (test-eqv #t (>? pizza-comparator pizza-chicago pizza-bianca))
+ (test-eqv #t (<=? pizza-comparator pizza-bianca pizza-chicago))
+ (test-eqv #t (<=? pizza-comparator pizza-bianca pizza-bianca))
+ (test-eqv #f (<=? pizza-comparator pizza-chicago pizza-bianca))
+ (test-eqv #f (>=? pizza-comparator pizza-bianca pizza-chicago))
+ (test-eqv #t (>=? pizza-comparator pizza-bianca pizza-bianca))
+ (test-eqv #t (>=? pizza-comparator pizza-chicago pizza-bianca)))
+)
+
+(test-group "Basic enum set operations"
+ ;; Ensure that an enum set created from an enum type with
+ ;; enum-type->enum-set contains every enum of the original type.
+ (test-eqv #t (let ((pizza-set (enum-type->enum-set pizza)))
+ (every (lambda (enum)
+ (enum-set-contains? pizza-set enum))
+ (enum-type-enums pizza))))
+
+ (test-eqv #t (let ((pizza-set (list->enum-set pizza (enum-type-enums pizza))))
+ (every (lambda (enum)
+ (enum-set-contains? pizza-set enum))
+ (enum-type-enums pizza))))
+
+ (test-eqv #t (let ((pizza-set (apply enum-set pizza (enum-type-enums pizza))))
+ (every (lambda (enum) (enum-set-contains? pizza-set enum))
+ (enum-type-enums pizza))))
+
+ (test-eqv #t (enum-set-contains? (enum-set color color-red color-blue)
+ color-red))
+ (test-eqv #f (enum-set-contains? (enum-set color color-red color-blue)
+ color-tangerine))
+
+ (test-eqv #t (eqv? (enum-set-type color-set) color))
+ (test-eqv #t (eqv? (enum-set-type (enum-type->enum-set pizza)) pizza))
+
+ (test-eqv #t (enum-set-empty? (enum-empty-set pizza)))
+
+ (test-eqv #t (enum-set-empty? empty-colors))
+ (test-eqv #f (enum-set-empty? color-set))
+
+ (test-eqv #t (enum-set=? (enum-set-projection color reddish) reddish))
+ (let* ((color* (make-enum-type color-names))
+ (reddish* (list->enum-set color*
+ (map (lambda (name)
+ (enum-name->enum color* name))
+ (take color-names 3)))))
+ (test-eqv #t (enum-set=? (enum-set-projection color* reddish) reddish*)))
+
+ (test-eqv #f (eqv? color-set (enum-set-copy color-set)))
+)
+
+;;;; Enum set predicates
+
+(test-group "Enum set predicates"
+ (test-eqv #t (enum-set-disjoint? color-set empty-colors))
+ (test-eqv #f (enum-set-disjoint? color-set reddish))
+ (test-eqv #t (enum-set-disjoint? reddish ~reddish))
+
+ ;;; comparisons
+
+ (test-eqv #t (enum-set=? color-set (enum-set-copy color-set)))
+
+ (test-eqv #f (enum-set=? color-set empty-colors))
+ (test-eqv #t (enum-set<? reddish color-set))
+ (test-eqv #f (enum-set<? color-set reddish))
+ (test-eqv #f (enum-set<? color-set color-set))
+ (test-eqv #f (enum-set>? reddish color-set))
+ (test-eqv #t (enum-set>? color-set reddish))
+ (test-eqv #f (enum-set>? color-set color-set))
+ (test-eqv #t (enum-set<=? reddish color-set))
+ (test-eqv #f (enum-set<=? color-set reddish))
+ (test-eqv #t (enum-set<=? color-set color-set))
+ (test-eqv #f (enum-set>=? reddish color-set))
+ (test-eqv #t (enum-set>=? color-set reddish))
+ (test-eqv #t (enum-set>=? color-set color-set))
+
+ ;;; enum-set-subset?
+ (test-eqv #t (enum-set-subset? reddish color-set))
+ (test-eqv #f (enum-set-subset? color-set reddish))
+ (test-eqv #t (enum-set-subset? reddish reddish))
+ (let ((color-set* (make-enumeration '(red green blue))))
+ (test-eqv #t (enum-set-subset? color-set* color-set))
+ (test-eqv #f (enum-set-subset? color-set color-set*)))
+
+ ;;; any & every
+
+ (test-eqv #t (enum-set-any? (lambda (e) (eq? 'green (enum-name e)))
+ color-set))
+ (test-eqv #f (enum-set-any? (lambda (e) (eq? 'mauve (enum-name e)))
+ color-set))
+ (test-eqv #f (enum-set-any? never empty-colors))
+ (test-eqv #f (enum-set-every? (lambda (e) (eq? 'green (enum-name e)))
+ color-set))
+ (test-eqv #t (enum-set-every? (lambda (e) (< (enum-ordinal e) 10))
+ color-set))
+ (test-eqv #t (enum-set-every? never empty-colors))
+)
+
+;;;; Enum set mutators
+
+(test-group "Enum set mutators"
+ (let ((reddish+green (enum-set-adjoin reddish color-green)))
+ (test-eqv #t (enum-set<? reddish reddish+green))
+ (test-eqv #t (enum-set-contains? reddish+green color-green)))
+
+ (let ((reddish+green
+ (enum-set-adjoin! (enum-set-copy reddish) color-green)))
+ (test-eqv #t (enum-set<? reddish reddish+green))
+ (test-eqv #t (enum-set-contains? reddish+green color-green)))
+
+ (let ((reddish* (enum-set-delete reddish color-tangerine)))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish* (enum-set-delete! (enum-set-copy reddish)
+ color-tangerine)))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish* (enum-set-delete-all reddish (list color-tangerine))))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish** (enum-set-delete-all! (enum-set-copy reddish)
+ (list color-tangerine))))
+ (test-eqv #t (enum-set<? reddish** reddish))
+ (test-eqv #f (enum-set-contains? reddish** color-tangerine)))
+
+ (test-eqv #t (enum-set-empty?
+ (enum-set-delete-all! (enum-set-copy color-set)
+ (enum-type-enums color))))
+)
+
+(test-group "Derived enum set operations"
+ (test-eqv (length color-names) (enum-set-size color-set))
+ (test-eqv 0 (enum-set-size empty-colors))
+
+ (test-equal (enum-type-enums color) (enum-set->enum-list color-set))
+ (test-eqv #t (null? (enum-set->enum-list empty-colors)))
+ (test-eqv #t (= (enum-set-size color-set)
+ (length (enum-set->enum-list color-set))))
+
+ (test-equal color-names (enum-set->list color-set))
+ (test-equal (map car pizza-descriptions)
+ (enum-set->list (enum-type->enum-set pizza)))
+ (test-eqv (enum-set-size color-set)
+ (length (enum-set->enum-list color-set)))
+
+ (test-equal color-names (enum-set-map->list enum-name color-set))
+ (test-eqv #t (null? (enum-set-map->list enum-name empty-colors)))
+ (test-equal (enum-set-map->list enum-name color-set)
+ (enum-set->list color-set))
+
+ (test-eqv 1 (enum-set-count (lambda (e) (enum=? e color-blue)) color-set))
+ (test-eqv 0 (enum-set-count (lambda (e) (enum=? e color-blue)) reddish))
+ (test-eqv (length pizza-descriptions)
+ (enum-set-count (lambda (e) (string? (enum-value e)))
+ (enum-type->enum-set pizza)))
+
+ ;;; filter & remove
+
+ (test-eqv #t (enum-set<? (enum-set-filter (lambda (e) (enum=? e color-red))
+ color-set)
+ color-set))
+ (test-equal (filter (lambda (s) (eq? s 'red)) color-names)
+ (enum-set-map->list enum-name
+ (enum-set-filter
+ (lambda (e) (enum=? e color-red))
+ color-set)))
+ (test-eqv #t (enum-set=? (enum-set-filter always color-set) color-set))
+ (test-eqv #t (enum-set-empty? (enum-set-filter never color-set)))
+ (test-eqv #t (enum-set<? (enum-set-remove (lambda (e) (enum=? e color-red))
+ color-set)
+ color-set))
+ (test-equal (remove (lambda (s) (eq? s 'red)) color-names)
+ (enum-set-map->list
+ enum-name
+ (enum-set-remove (lambda (e) (enum=? e color-red))
+ color-set)))
+ (test-eqv #t (enum-set=? (enum-set-remove never color-set) color-set))
+ (test-eqv #t (enum-set-empty? (enum-set-remove always color-set)))
+
+ (test-eqv (length color-names)
+ (let ((n 0))
+ (enum-set-for-each (lambda (_) (set! n (+ n 1)))
+ color-set)
+ n))
+
+ (test-equal (reverse color-names)
+ (enum-set-fold (lambda (enum lis)
+ (cons (enum-name enum) lis))
+ '()
+ color-set))
+
+ (test-eqv #t (enum-set=? color-set (enum-set-universe reddish)))
+
+ (let* ((ds '(red yellow green))
+ (us-traffic-light (make-enumeration ds))
+ (light-type (enum-set-type us-traffic-light)))
+ (test-eqv #t (every (lambda (e) (enum-set-contains? us-traffic-light e))
+ (map (lambda (sym) (enum-name->enum light-type sym))
+ ds)))
+ (test-eqv #t (every (lambda (e) (eqv? (enum-name e) (enum-value e)))
+ (enum-set->enum-list us-traffic-light))))
+
+ (let ((color-con (enum-set-constructor reddish)))
+ (test-eqv #t (eqv? (enum-set-type (color-con '(green))) color))
+ (test-eqv #t (enum-set=? (color-con color-names) color-set)))
+
+ (test-eqv #t (enum-set-member? 'red reddish))
+ (test-eqv #f (enum-set-member? 'blue reddish))
+
+ (let ((idx (enum-set-indexer reddish)))
+ (test-eqv 0 (idx 'red))
+ (test-eqv 4 (idx 'green))
+ (test-eqv #f (idx 'margherita)))
+)
+
+(test-group "Enum set logical operations"
+ (test-eqv #t (enum-set=? color-set (enum-set-union reddish ~reddish)))
+ (test-eqv #t (enum-set-empty? (enum-set-intersection reddish ~reddish)))
+ (test-eqv #t (enum-set=? ~reddish (enum-set-difference color-set reddish)))
+ (test-eqv #t (enum-set=? color-set (enum-set-xor reddish ~reddish)))
+ (test-eqv #t (enum-set-empty? (enum-set-xor reddish reddish)))
+
+ (test-eqv #t (enum-set=? color-set
+ (fresh-sets enum-set-union! reddish ~reddish)))
+ (test-eqv #t (enum-set-empty?
+ (fresh-sets enum-set-intersection! reddish ~reddish)))
+ (test-eqv #t
+ (enum-set=? ~reddish
+ (fresh-sets enum-set-difference! color-set reddish)))
+ (test-eqv #t
+ (enum-set=? color-set
+ (fresh-sets enum-set-xor! reddish ~reddish)))
+ (test-eqv #t (enum-set-empty?
+ (fresh-sets enum-set-xor! reddish reddish)))
+
+ (test-eqv #t (enum-set-empty? (enum-set-complement color-set)))
+ (test-eqv #t (enum-set=? (enum-set-complement reddish) ~reddish))
+ (test-eqv #t (enum-set-empty?
+ (enum-set-complement! (enum-set-copy color-set))))
+ (test-eqv #t (enum-set=?
+ (enum-set-complement! (enum-set-copy reddish)) ~reddish))
+)
+
+(test-group "Syntax"
+ (define-enum hobbit (frodo sam merry pippin) hobbit-set)
+ (define-enumeration wizard (gandalf saruman radagast) wizard-set)
+
+ (test-eqv 'merry (enum-name (hobbit merry)))
+ (test-eqv #t (enum-set? (hobbit-set)))
+ (test-eqv #t (enum-set-empty? (hobbit-set)))
+ (test-eqv #t (enum-set-contains? (hobbit-set merry pippin) (hobbit pippin)))
+
+ (test-eqv 'radagast (wizard radagast))
+ (test-eqv #t (enum-set? (wizard-set)))
+ (test-eqv #t (enum-set-empty? (wizard-set)))
+ (test-eqv #t (enum-set-member? (wizard gandalf) (wizard-set saruman gandalf)))
+)
diff --git a/test-suite/tests/srfi-209.test b/test-suite/tests/srfi-209.test
new file mode 100644
index 000000000..9e8c4e798
--- /dev/null
+++ b/test-suite/tests/srfi-209.test
@@ -0,0 +1,50 @@
+;;;; srfi-209.test --- Test suite for SRFI-209. -*- 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-209)
+ #:use-module (srfi srfi-209)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-128))
+
+;;; Test runner copied from srfi-64.test.
+(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-209-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
--
2.41.0
^ permalink raw reply related [flat|nested] 17+ messages in thread
end of thread, other threads:[~2023-12-03 1:37 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2023-12-03 1:37 [PATCH v6 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 08/16] module: Add SRFI 126 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 09/16] module: Add SRFI 128 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 10/16] module: Add (scheme comparator) Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 11/16] module: Add (scheme sort) Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 12/16] module: Add SRFI 125 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 13/16] module: Add SRFI 151 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 14/16] module: Add SRFI 160 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 15/16] module: Add SRFI 178 Maxim Cournoyer
2023-12-03 1:37 ` [PATCH v6 16/16] module: Add SRFI 209 Maxim Cournoyer
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).