unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [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).