* [PATCH v9 01/18] ice-9: Fix 'include' when used in compilation contexts.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 02/18] Use R7RS 'rename' syntax for exports Maxim Cournoyer
` (16 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 02/18] Use R7RS 'rename' syntax for exports.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 01/18] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 03/18] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
` (15 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 03/18] r7rs-libraries: Add support for 'else' clause in cond-expand.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 01/18] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 02/18] Use R7RS 'rename' syntax for exports Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 04/18] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
` (14 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 04/18] r7rs-libraries: Better support R7RS SRFI library names.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (2 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 03/18] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 05/18] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
` (13 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 05/18] (scheme base): Support non-negative SRFI integer names in cond-expand.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (3 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 04/18] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 06/18] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
` (12 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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.
* LICENSES/LGPL-3.0-or-later.txt: New file.
---
(no changes since v5)
Changes in v5:
- Update NEWS
LICENSES/LGPL-3.0-or-later.txt | 304 +++++++++++++++++++++++++
NEWS | 1 +
module/scheme/base.scm | 5 +-
test-suite/tests/r7rs-cond-expand.test | 24 ++
4 files changed, 333 insertions(+), 1 deletion(-)
create mode 100644 LICENSES/LGPL-3.0-or-later.txt
create mode 100644 test-suite/tests/r7rs-cond-expand.test
diff --git a/LICENSES/LGPL-3.0-or-later.txt b/LICENSES/LGPL-3.0-or-later.txt
new file mode 100644
index 000000000..513d1c01f
--- /dev/null
+++ b/LICENSES/LGPL-3.0-or-later.txt
@@ -0,0 +1,304 @@
+GNU LESSER GENERAL PUBLIC LICENSE
+Version 3, 29 June 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed.
+
+This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below.
+
+0. Additional Definitions.
+
+As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License.
+
+"The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below.
+
+An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library.
+
+A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version".
+
+The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version.
+
+The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work.
+
+1. Exception to Section 3 of the GNU GPL.
+You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL.
+
+2. Conveying Modified Versions.
+If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version:
+
+ a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy.
+
+3. Object Code Incorporating Material from Library Header Files.
+The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license document.
+
+4. Combined Works.
+You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following:
+
+ a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license document.
+
+ c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version.
+
+ e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.)
+
+5. Combined Libraries.
+You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
+
+6. Revised Versions of the GNU Lesser General Public License.
+The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation.
+
+If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library.
+
+GNU GENERAL PUBLIC LICENSE
+Version 3, 29 June 2007
+
+Copyright © 2007 Free Software Foundation, Inc. <http://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed.
+
+Preamble
+
+The GNU General Public License is a free, copyleft license for software and other kinds of works.
+
+The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too.
+
+When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things.
+
+To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others.
+
+For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights.
+
+Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it.
+
+For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions.
+
+Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users.
+
+Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free.
+
+The precise terms and conditions for copying, distribution and modification follow.
+
+TERMS AND CONDITIONS
+
+0. Definitions.
+
+“This License” refers to version 3 of the GNU General Public License.
+
+“Copyright” also means copyright-like laws that apply to other kinds of works, such as semiconductor masks.
+
+“The Program” refers to any copyrightable work licensed under this License. Each licensee is addressed as “you”. “Licensees” and “recipients” may be individuals or organizations.
+
+To “modify” a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a “modified version” of the earlier work or a work “based on” the earlier work.
+
+A “covered work” means either the unmodified Program or a work based on the Program.
+
+To “propagate” a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well.
+
+To “convey” a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying.
+
+An interactive user interface displays “Appropriate Legal Notices” to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion.
+
+1. Source Code.
+The “source code” for a work means the preferred form of the work for making modifications to it. “Object code” means any non-source form of a work.
+
+A “Standard Interface” means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language.
+
+The “System Libraries” of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A “Major Component”, in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it.
+
+The “Corresponding Source” for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work.
+
+The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source.
+
+The Corresponding Source for a work in source code form is that same work.
+
+2. Basic Permissions.
+All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law.
+
+You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you.
+
+Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary.
+
+3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures.
+
+When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures.
+
+4. Conveying Verbatim Copies.
+You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program.
+
+You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee.
+
+5. Conveying Modified Source Versions.
+You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to “keep intact all notices”.
+
+ c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so.
+
+A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an “aggregate” if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate.
+
+6. Conveying Non-Source Forms.
+You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b.
+
+ d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d.
+
+A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work.
+
+A “User Product” is either (1) a “consumer product”, which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, “normally used” refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the o
nly significant mode of use of the product.
+
+“Installation Information” for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made.
+
+If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM).
+
+The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network.
+
+Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying.
+
+7. Additional Terms.
+“Additional permissions” are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions.
+
+When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission.
+
+Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors.
+
+All other non-permissive additional terms are considered “further restrictions” within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying.
+
+If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms.
+
+Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way.
+
+8. Termination.
+You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11).
+
+However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice.
+
+Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10.
+
+9. Acceptance Not Required for Having Copies.
+You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so.
+
+10. Automatic Licensing of Downstream Recipients.
+Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License.
+
+An “entity transaction” is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts.
+
+You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it.
+
+11. Patents.
+A “contributor” is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's “contributor version”.
+
+A contributor's “essential patent claims” are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, “control” includes the right to grant patent sublicenses in a manner consistent with the requirements of this License.
+
+Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version.
+
+In the following three paragraphs, a “patent license” is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To “grant” such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party.
+
+If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. “Knowingly relying” means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one o
r more identifiable patents in that country that you have reason to believe are valid.
+
+If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it.
+
+A patent license is “discriminatory” if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or com
pilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007.
+
+Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law.
+
+12. No Surrender of Others' Freedom.
+If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program.
+
+13. Use with the GNU Affero General Public License.
+Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such.
+
+14. Revised Versions of this License.
+The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License “or any later version” applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program.
+
+Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version.
+
+15. Disclaimer of Warranty.
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+16. Limitation of Liability.
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+17. Interpretation of Sections 15 and 16.
+If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms.
+
+To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the “copyright” line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.
+
+ This program 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 General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an “about box”.
+
+You should also get your employer (if you work as a programmer) or school, if any, to sign a “copyright disclaimer” for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see <http://www.gnu.org/licenses/>.
+
+The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read <http://www.gnu.org/philosophy/why-not-lgpl.html>.
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..82ff72a18
--- /dev/null
+++ b/test-suite/tests/r7rs-cond-expand.test
@@ -0,0 +1,24 @@
+;;; R7RS cond-expand -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 06/18] Share features tested by cond-expand library declarations and expressions.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (4 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 05/18] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 07/18] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
` (11 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 07/18] build: Register '.sld' as an alternative extension to '.scm'.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (5 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 06/18] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 08/18] module: Add SRFI 126 Maxim Cournoyer
` (10 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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] 19+ messages in thread* [PATCH v9 08/18] module: Add SRFI 126.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (6 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 07/18] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 09/18] module: Add SRFI 128 Maxim Cournoyer
` (9 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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.sld: 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.
* LICENSE: Mention extra licenses in use can be found...
* LICENSES: ... in this directory.
---
Changes in v9:
- Use R7RS library
- Add LICENSES/MIT.txt, for REUSE compliance
- Clarify extra licenses used in LICENSE file
Changes in v7:
- Register prerequisites for srfi/srfi-126.scm in am/bootstrap.am
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
LICENSE | 5 +
LICENSES/MIT.txt | 9 +
NEWS | 2 +
am/bootstrap.am | 3 +
doc/ref/guile.texi | 25 +-
doc/ref/srfi-modules.texi | 600 +++++++++++++++++++++++++++++
module/srfi/srfi-126.sld | 44 +++
module/srfi/srfi-126/126.body.scm | 286 ++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-126-test.scm | 271 +++++++++++++
test-suite/tests/srfi-126.test | 37 ++
11 files changed, 1283 insertions(+), 1 deletion(-)
create mode 100644 LICENSES/MIT.txt
create mode 100644 module/srfi/srfi-126.sld
create mode 100644 module/srfi/srfi-126/126.body.scm
create mode 100644 test-suite/tests/srfi-126-test.scm
create mode 100644 test-suite/tests/srfi-126.test
diff --git a/LICENSE b/LICENSE
index 3961579b8..e6713742c 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,2 +1,7 @@
Guile is covered under the terms of the GNU Lesser General Public
License, version 3 or later. See COPYING.LESSER and COPYING.
+
+Some third party libraries integrated into Guile, such as SRFI sample
+implementations, may carry their own license, identified via SPDX
+metadata. All the extra licences in use can be found under the
+LICENSES directory.
diff --git a/LICENSES/MIT.txt b/LICENSES/MIT.txt
new file mode 100644
index 000000000..2071b23b0
--- /dev/null
+++ b/LICENSES/MIT.txt
@@ -0,0 +1,9 @@
+MIT License
+
+Copyright (c) <year> <copyright holders>
+
+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.
diff --git a/NEWS b/NEWS
index e5cc3c7aa..8a0c77eb5 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,8 @@ 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
+
* Bug fixes
** (ice-9 suspendable-ports) incorrect UTF-8 decoding
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 68d4b3334..7f62854cd 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -62,6 +62,8 @@ srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
$(COMPILE) -o "$@" "$<"
+# Register inter-modules dependencies.
+srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
SOURCES = \
@@ -349,6 +351,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-126.sld \
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.sld b/module/srfi/srfi-126.sld
new file mode 100644
index 000000000..34276199f
--- /dev/null
+++ b/module/srfi/srfi-126.sld
@@ -0,0 +1,44 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 126)
+ (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 equal-hash string-hash string-ci-hash symbol-hash)
+ (import
+ (scheme base)
+ (scheme case-lambda)
+ (scheme process-context)
+ (srfi 1)
+ (srfi 27))
+ (cond-expand
+ (guile
+ ;; Guile doesn't have (r6rs ...) prefixed R6RS library modules,
+ ;; and it can use its own R6RS hashtables implementation instead
+ ;; of the bundled Larceny-licensed r6rs/hashtables.sld library,
+ ;; which is non-free due to restricting use to "lawful purposes".
+ (import (rnrs enums (6)))
+ (import (prefix (rnrs hashtables (6)) rnrs-)))
+ (else
+ (import (r6rs enums))
+ (import (prefix (r6rs hashtables) rnrs-))))
+ (begin
+ ;; Smallest allowed in R6RS.
+ (define (greatest-fixnum) (expt 23 2)))
+ (include "srfi-126/126.body.scm"))
diff --git a/module/srfi/srfi-126/126.body.scm b/module/srfi/srfi-126/126.body.scm
new file mode 100644
index 000000000..51dc55790
--- /dev/null
+++ b/module/srfi/srfi-126/126.body.scm
@@ -0,0 +1,286 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define make-eq-hashtable
+ (case-lambda
+ (() (make-eq-hashtable #f #f))
+ ((capacity) (make-eq-hashtable capacity #f))
+ ((capacity weakness)
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (if capacity
+ (rnrs-make-eq-hashtable capacity)
+ (rnrs-make-eq-hashtable)))))
+
+(define make-eqv-hashtable
+ (case-lambda
+ (() (make-eqv-hashtable #f #f))
+ ((capacity) (make-eqv-hashtable capacity #f))
+ ((capacity weakness)
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (if capacity
+ (rnrs-make-eqv-hashtable capacity)
+ (rnrs-make-eqv-hashtable)))))
+
+(define make-hashtable
+ (case-lambda
+ ((hash equiv) (make-hashtable hash equiv #f #f))
+ ((hash equiv capacity) (make-hashtable hash equiv capacity #f))
+ ((hash equiv 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
+ (when weakness
+ (error "No weak or ephemeral hashtables supported."))
+ (let ((hash (if (pair? hash)
+ (car hash)
+ hash)))
+ (if capacity
+ (rnrs-make-hashtable hash equiv capacity)
+ (rnrs-make-hashtable hash equiv))))))))
+
+(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 ((hashtable (make-hashtable hash equiv capacity weakness)))
+ (for-each (lambda (entry)
+ (hashtable-set! hashtable (car entry) (cdr entry)))
+ (reverse alist))
+ hashtable))))
+
+(define-enumeration weakness
+ (weak-key
+ weak-value
+ weak-key-and-value
+ ephemeral-key
+ ephemeral-value
+ ephemeral-key-and-value)
+ weakness-set)
+
+(define hashtable? rnrs-hashtable?)
+
+(define hashtable-size rnrs-hashtable-size)
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define hashtable-ref
+ (case-lambda
+ ((hashtable key)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (error "No such key in hashtable." hashtable key)
+ value)))
+ ((hashtable key default)
+ (rnrs-hashtable-ref hashtable key default))))
+
+(define hashtable-set! rnrs-hashtable-set!)
+
+(define hashtable-delete! rnrs-hashtable-delete!)
+
+(define hashtable-contains? rnrs-hashtable-contains?)
+
+(define (hashtable-lookup hashtable key)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (values #f #f)
+ (values value #t))))
+
+(define hashtable-update!
+ (case-lambda
+ ((hashtable key proc) (hashtable-update! hashtable key proc nil))
+ ((hashtable key proc default)
+ (rnrs-hashtable-update!
+ hashtable key
+ (lambda (value)
+ (if (nil? value)
+ (error "No such key in hashtable." hashtable key)
+ (proc value)))
+ default))))
+
+;;; XXX This could be implemented at the platform level to eliminate the second
+;;; lookup for the key.
+(define (hashtable-intern! hashtable key default-proc)
+ (let ((value (rnrs-hashtable-ref hashtable key nil)))
+ (if (nil? value)
+ (let ((value (default-proc)))
+ (hashtable-set! hashtable key value)
+ value)
+ value)))
+
+(define hashtable-copy
+ (case-lambda
+ ((hashtable) (hashtable-copy hashtable #f #f))
+ ((hashtable mutable) (hashtable-copy hashtable mutable #f))
+ ((hashtable mutable weakness)
+ (when weakness
+ (error "No weak or ephemeral tables supported."))
+ (rnrs-hashtable-copy hashtable mutable))))
+
+(define hashtable-clear!
+ (case-lambda
+ ((hashtable) (rnrs-hashtable-clear! hashtable))
+ ((hashtable capacity)
+ (if capacity
+ (rnrs-hashtable-clear! hashtable capacity)
+ (rnrs-hashtable-clear! hashtable)))))
+
+(define hashtable-empty-copy
+ (case-lambda
+ ((hashtable) (hashtable-empty-copy hashtable #f))
+ ((hashtable capacity)
+ (make-hashtable (hashtable-hash-function hashtable)
+ (hashtable-equivalence-function hashtable)
+ (if (eq? #t capacity)
+ (hashtable-size hashtable)
+ capacity)
+ (hashtable-weakness hashtable)))))
+
+(define hashtable-keys rnrs-hashtable-keys)
+
+(define (hashtable-values hashtable)
+ (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+ values))
+
+(define hashtable-entries rnrs-hashtable-entries)
+
+(define (hashtable-key-list hashtable)
+ (hashtable-map->lset hashtable (lambda (key value) key)))
+
+(define (hashtable-value-list hashtable)
+ (hashtable-map->lset hashtable (lambda (key value) value)))
+
+(define (hashtable-entry-lists hashtable)
+ (let ((keys '())
+ (vals '()))
+ (hashtable-walk hashtable
+ (lambda (key val)
+ (set! keys (cons key keys))
+ (set! vals (cons val vals))))
+ (values keys vals)))
+
+;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!,
+;;; and hashtable-sum should be implemented more efficiently at the platform
+;;; level. In particular, they should not allocate intermediate vectors or
+;;; lists to hold the keys or values that are being operated on.
+
+(define (hashtable-walk hashtable proc)
+ (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+ (vector-for-each proc keys values)))
+
+(define (hashtable-update-all! hashtable proc)
+ (let-values (((keys values) (hashtable-entries hashtable)))
+ (vector-for-each (lambda (key value)
+ (hashtable-set! hashtable key (proc key value)))
+ keys values)))
+
+(define (hashtable-prune! hashtable proc)
+ (let-values (((keys values) (hashtable-entries hashtable)))
+ (vector-for-each (lambda (key value)
+ (when (proc key value)
+ (hashtable-delete! hashtable key)))
+ keys values)))
+
+(define (hashtable-merge! hashtable-dest hashtable-source)
+ (hashtable-walk hashtable-source
+ (lambda (key value)
+ (hashtable-set! hashtable-dest key value)))
+ hashtable-dest)
+
+(define (hashtable-sum hashtable init proc)
+ (let-values (((keys vals) (hashtable-entry-lists hashtable)))
+ (fold proc init keys vals)))
+
+(define (hashtable-map->lset hashtable proc)
+ (hashtable-sum hashtable '()
+ (lambda (key value accumulator)
+ (cons (proc key value) accumulator))))
+
+;;; XXX If available, let-escape-continuation might be more efficient than
+;;; call/cc here.
+(define (hashtable-find hashtable proc)
+ (call/cc
+ (lambda (return)
+ (hashtable-walk hashtable
+ (lambda (key value)
+ (when (proc key value)
+ (return key value #t))))
+ (return #f #f #f))))
+
+(define (hashtable-empty? hashtable)
+ (zero? (hashtable-size hashtable)))
+
+;;; XXX A platform-level implementation could avoid allocating the constant true
+;;; function and the lookup for the key in the delete operation.
+(define (hashtable-pop! hashtable)
+ (if (hashtable-empty? hashtable)
+ (error "Cannot pop from empty hashtable." hashtable)
+ (let-values (((key value found?)
+ (hashtable-find hashtable (lambda (k v) #t))))
+ (hashtable-delete! hashtable key)
+ (values key value))))
+
+(define hashtable-inc!
+ (case-lambda
+ ((hashtable key) (hashtable-inc! hashtable key 1))
+ ((hashtable key number)
+ (hashtable-update! hashtable key (lambda (v) (+ v number)) 0))))
+
+(define hashtable-dec!
+ (case-lambda
+ ((hashtable key) (hashtable-dec! hashtable key 1))
+ ((hashtable key number)
+ (hashtable-update! hashtable key (lambda (v) (- v number)) 0))))
+
+(define hashtable-equivalence-function rnrs-hashtable-equivalence-function)
+
+(define hashtable-hash-function rnrs-hashtable-hash-function)
+
+(define (hashtable-weakness hashtable) #f)
+
+(define hashtable-mutable? rnrs-hashtable-mutable?)
+
+(define *hash-salt*
+ (let ((seed (get-environment-variable "SRFI_126_HASH_SEED")))
+ (if (or (not seed) (string=? seed ""))
+ (random-integer (greatest-fixnum))
+ (modulo
+ (fold (lambda (char result)
+ (+ (char->integer char) result))
+ 0
+ (string->list seed))
+ (greatest-fixnum)))))
+
+(define (hash-salt) *hash-salt*)
+
+(define equal-hash rnrs-equal-hash)
+
+(define string-hash rnrs-string-hash)
+
+(define string-ci-hash rnrs-string-ci-hash)
+
+(define symbol-hash rnrs-symbol-hash)
+
+;; 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..69d8ac62d
--- /dev/null
+++ b/test-suite/tests/srfi-126-test.scm
@@ -0,0 +1,271 @@
+;;; SPDX-FileCopyrightText: 2015 - 2016 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..3a9283205
--- /dev/null
+++ b/test-suite/tests/srfi-126.test
@@ -0,0 +1,37 @@
+;;; srfi-126.test --- Test suite for SRFI-126. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 09/18] module: Add SRFI 128.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (7 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 08/18] module: Add SRFI 126 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 10/18] module: Add (scheme comparator) Maxim Cournoyer
` (8 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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.
---
Changes in v9:
- Add SPDX identifiers for easier license tracking
Changes in v7:
- Register prerequisites for srfi/srfi-128.scm in am/bootstrap.am
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)
NEWS | 1 +
am/bootstrap.am | 5 +
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 553 ++++++++++++++++++++++++++++-
module/srfi/srfi-128.sld | 42 +++
module/srfi/srfi-128/128.body1.scm | 363 +++++++++++++++++++
module/srfi/srfi-128/128.body2.scm | 148 ++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-128-test.scm | 323 +++++++++++++++++
test-suite/tests/srfi-128.test | 35 ++
10 files changed, 1474 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/NEWS b/NEWS
index 8a0c77eb5..31107a76d 100644
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,7 @@ 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
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 7f62854cd..7eda62599 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -64,6 +64,8 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
# Register inter-modules dependencies.
srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
+srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
+
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
SOURCES = \
@@ -352,6 +354,7 @@ SOURCES = \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
srfi/srfi-126.sld \
+ srfi/srfi-128.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -443,6 +446,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..306efbf3b
--- /dev/null
+++ b/module/srfi/srfi-128.sld
@@ -0,0 +1,42 @@
+;;; SPDX-FileCopyrightText: 2015 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..75fb9def4
--- /dev/null
+++ b/module/srfi/srfi-128/128.body1.scm
@@ -0,0 +1,363 @@
+;;; SPDX-License-Identifier: MIT
+;;;
+;;; 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..2e45247c8
--- /dev/null
+++ b/module/srfi/srfi-128/128.body2.scm
@@ -0,0 +1,148 @@
+;;; SPDX-License-Identifier: MIT
+;;;
+;;; 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..a2b00833f
--- /dev/null
+++ b/test-suite/tests/srfi-128-test.scm
@@ -0,0 +1,323 @@
+;;; SPDX-License-Identifier: MIT
+;;;
+;;; 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..47c4ca17a
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,35 @@
+;;; srfi-128.test --- Test suite for SRFI-128. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 10/18] module: Add (scheme comparator).
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (8 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 09/18] module: Add SRFI 128 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 11/18] module: Add (scheme sort) Maxim Cournoyer
` (7 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/scheme/comparator.sld: New R7RS-large library shim for SRFI 128.
* am/bootstrap.am (SOURCES): Register it.
* NEWS: Update NEWS.
---
(no changes since v7)
Changes in v7:
- Register prerequisites for scheme/comparator.go in am/bootstrap.am
Changes in v5:
- Update NEWS
NEWS | 1 +
am/bootstrap.am | 2 ++
module/scheme/comparator.sld | 21 +++++++++++++++++++++
3 files changed, 24 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 7eda62599..a335782ff 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -65,6 +65,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
# Register inter-modules dependencies.
srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
+scheme/comparator.go: srfi/srfi-128.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -281,6 +282,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..2ce55809a
--- /dev/null
+++ b/module/scheme/comparator.sld
@@ -0,0 +1,21 @@
+;;; comparator.sld --- R7RS library exposing SRFI 128.
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 11/18] module: Add (scheme sort).
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (9 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 10/18] module: Add (scheme comparator) Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 12/18] module: Add SRFI 125 Maxim Cournoyer
` (6 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/scheme/sort.sld: New R7RS-large 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 | 9 +++++++++
3 files changed, 11 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 a335782ff..3dd8ec65b 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -294,6 +294,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..c1e77a736
--- /dev/null
+++ b/module/scheme/sort.sld
@@ -0,0 +1,9 @@
+;;; sorting.sld --- R7RS library exposing (rnrs sorting).
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(define-library (scheme sort)
+ (export list-sort vector-sort vector-sort!)
+ (import (rnrs sorting)))
--
2.41.0
^ permalink raw reply related [flat|nested] 19+ messages in thread* [PATCH v9 12/18] module: Add SRFI 125.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (10 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 11/18] module: Add (scheme sort) Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 13/18] module: Add SRFI 151 Maxim Cournoyer
` (5 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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 v7)
Changes in v7:
- Register prerequisites for srfi/srfi-125.go in am/bootstrap.am
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
LICENSES/LicenseRef-Clinger.txt | 10 +
NEWS | 1 +
am/bootstrap.am | 3 +
doc/ref/guile.texi | 2 +-
doc/ref/srfi-modules.texi | 603 +++++++++++++++++++
module/srfi/srfi-125.sld | 87 +++
module/srfi/srfi-125/125.body.scm | 590 +++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-125-test.scm | 891 +++++++++++++++++++++++++++++
test-suite/tests/srfi-125.test | 33 ++
10 files changed, 2221 insertions(+), 1 deletion(-)
create mode 100644 LICENSES/LicenseRef-Clinger.txt
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/LICENSES/LicenseRef-Clinger.txt b/LICENSES/LicenseRef-Clinger.txt
new file mode 100644
index 000000000..758728f35
--- /dev/null
+++ b/LICENSES/LicenseRef-Clinger.txt
@@ -0,0 +1,10 @@
+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.
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 3dd8ec65b..13e0b711d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -66,6 +66,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
scheme/comparator.go: srfi/srfi-128.go
+srfi/srfi-125.go: srfi/srfi-126.go srfi/srfi-128.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -356,6 +357,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-125.sld \
srfi/srfi-126.sld \
srfi/srfi-128.sld \
srfi/srfi-171.scm \
@@ -449,6 +451,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..72b3c9da7
--- /dev/null
+++ b/module/srfi/srfi-125.sld
@@ -0,0 +1,87 @@
+;;; SPDX-FileCopyrightText: 2015 William D Clinger <will@ccs.neu.edu>
+;;;
+;;; SPDX-License-Identifier: LicenseRef-Clinger
+
+(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..1fc30be44
--- /dev/null
+++ b/module/srfi/srfi-125/125.body.scm
@@ -0,0 +1,590 @@
+;;; SPDX-License-Identifier: LicenseRef-Clinger
+;;; 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..8774d3694
--- /dev/null
+++ b/test-suite/tests/srfi-125-test.scm
@@ -0,0 +1,891 @@
+;;; SPDX-License-Identifier: MIT
+;;; 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..69f283460
--- /dev/null
+++ b/test-suite/tests/srfi-125.test
@@ -0,0 +1,33 @@
+;;; srfi-125.test --- Test suite for SRFI-125. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 13/18] module: Add SRFI 151.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (11 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 12/18] module: Add SRFI 125 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 14/18] module: Add SRFI 160 Maxim Cournoyer
` (4 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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 v8)
Changes in v8:
- Refine SPDX metadata
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
LICENSES/LicenseRef-Public-Domain.txt | 2 +
LICENSES/LicenseRef-SLIB.txt | 17 +
NEWS | 1 +
am/bootstrap.am | 4 +
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 815 ++++++++++++++++++++++++-
module/srfi/srfi-151.sld | 38 ++
module/srfi/srfi-151/bitwise-33.scm | 113 ++++
module/srfi/srfi-151/bitwise-60.scm | 73 +++
module/srfi/srfi-151/bitwise-other.scm | 44 ++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-151-test.scm | 363 +++++++++++
test-suite/tests/srfi-151.test | 34 ++
13 files changed, 1508 insertions(+), 4 deletions(-)
create mode 100644 LICENSES/LicenseRef-Public-Domain.txt
create mode 100644 LICENSES/LicenseRef-SLIB.txt
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/LICENSES/LicenseRef-Public-Domain.txt b/LICENSES/LicenseRef-Public-Domain.txt
new file mode 100644
index 000000000..5d67405cb
--- /dev/null
+++ b/LICENSES/LicenseRef-Public-Domain.txt
@@ -0,0 +1,2 @@
+Olin Shivers is the sole author of this code, and he has placed it in
+the public domain.
diff --git a/LICENSES/LicenseRef-SLIB.txt b/LICENSES/LicenseRef-SLIB.txt
new file mode 100644
index 000000000..704b65896
--- /dev/null
+++ b/LICENSES/LicenseRef-SLIB.txt
@@ -0,0 +1,17 @@
+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.
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 13e0b711d..04cee1442 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -360,6 +360,7 @@ SOURCES = \
srfi/srfi-125.sld \
srfi/srfi-126.sld \
srfi/srfi-128.sld \
+ srfi/srfi-151.sld \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
@@ -454,6 +455,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..cdec0045c
--- /dev/null
+++ b/module/srfi/srfi-151.sld
@@ -0,0 +1,38 @@
+;;; SPDX-FileCopyrightText: 2017 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..bd883e73b
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-33.scm
@@ -0,0 +1,113 @@
+;;;; bitwise-33 - Olin Shivers's code from SRFI-33 with modified names
+
+;;;
+;;; SPDX-FileCopyrightText: Olin Shivers
+;;;
+;;; SPDX-License-Identifier: LicenseRef-Public-Domain
+;;;
+;;; 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..021803144
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-60.scm
@@ -0,0 +1,73 @@
+;;;; bitwise-60 - SRFI-60 procedures without SRFI-33 analogues, renamed
+;;;
+;;; SPDX-License-Identifier: LicenseRef-SLIB
+;;;
+;;; 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..9a68a1f7f
--- /dev/null
+++ b/module/srfi/srfi-151/bitwise-other.scm
@@ -0,0 +1,44 @@
+;;;; bitwise-other - functions not from SRFI 33 or SRFI 60
+;;; Copyright John Cowan 2017
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..4cf06e3c8
--- /dev/null
+++ b/test-suite/tests/srfi-151-test.scm
@@ -0,0 +1,363 @@
+;;; SPDX-FileCopyrightText: 2017 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..fb8b494db
--- /dev/null
+++ b/test-suite/tests/srfi-151.test
@@ -0,0 +1,34 @@
+;;; srfi-151.test --- Test suite for SRFI-151. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 14/18] module: Add SRFI 160.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (12 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 13/18] module: Add SRFI 151 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 15/18] module: Add SRFI 178 Maxim Cournoyer
` (3 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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 v8)
Changes in v8:
- Standardize SPDX/REUSE metadata
Changes in v7:
- Register prerequisites for srfi/srfi-160/*.go in am/bootstrap.am
Changes in v5:
- Generate Texinfo menu entries
- Update NEWS
NEWS | 1 +
am/bootstrap.am | 46 ++
doc/ref/guile.texi | 2 +-
doc/ref/srfi-modules.texi | 649 +++++++++++++++++-
module/srfi/srfi-160/base.sld | 68 ++
.../srfi/srfi-160/base/c128-vector2list.scm | 19 +
module/srfi/srfi-160/base/c64-vector2list.scm | 19 +
module/srfi/srfi-160/base/complex.scm | 112 +++
module/srfi/srfi-160/base/f32-vector2list.scm | 19 +
module/srfi/srfi-160/base/f64-vector2list.scm | 19 +
module/srfi/srfi-160/base/r7rec.scm | 12 +
module/srfi/srfi-160/base/s16-vector2list.scm | 19 +
module/srfi/srfi-160/base/s32-vector2list.scm | 19 +
module/srfi/srfi-160/base/s64-vector2list.scm | 19 +
module/srfi/srfi-160/base/s8-vector2list.scm | 19 +
module/srfi/srfi-160/base/u16-vector2list.scm | 19 +
module/srfi/srfi-160/base/u32-vector2list.scm | 19 +
module/srfi/srfi-160/base/u64-vector2list.scm | 19 +
module/srfi/srfi-160/base/u8-vector2list.scm | 19 +
module/srfi/srfi-160/base/valid.scm | 27 +
module/srfi/srfi-160/c128-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/c128.sld | 49 ++
module/srfi/srfi-160/c64-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/c64.sld | 49 ++
module/srfi/srfi-160/f32-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/f32.sld | 49 ++
module/srfi/srfi-160/f64-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/f64.sld | 49 ++
module/srfi/srfi-160/s16-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/s16.sld | 49 ++
module/srfi/srfi-160/s32-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/s32.sld | 49 ++
module/srfi/srfi-160/s64-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/s64.sld | 49 ++
module/srfi/srfi-160/s8-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/s8.sld | 49 ++
module/srfi/srfi-160/u16-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/u16.sld | 49 ++
module/srfi/srfi-160/u32-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/u32.sld | 49 ++
module/srfi/srfi-160/u64-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/u64.sld | 49 ++
module/srfi/srfi-160/u8-impl.scm | 601 ++++++++++++++++
module/srfi/srfi-160/u8.sld | 49 ++
test-suite/Makefile.am | 4 +
test-suite/tests/srfi-160-base-test.scm | 168 +++++
test-suite/tests/srfi-160-base.test | 35 +
test-suite/tests/srfi-160-test.scm | 263 +++++++
test-suite/tests/srfi-160.test | 36 +
49 files changed, 9449 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 04cee1442..d6cdc057a 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -67,6 +67,12 @@ srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
scheme/comparator.go: srfi/srfi-128.go
srfi/srfi-125.go: srfi/srfi-126.go srfi/srfi-128.go
+srfi/srfi-160/base.go: srfi/srfi-151.go srfi/srfi-4.go
+srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \
+ srfi/srfi-160/f64.go srfi/srfi-160/s16.go srfi/srfi-160/s32.go \
+ srfi/srfi-160/s64.go srfi/srfi-160/s8.go srfi/srfi-160/u16.go \
+ srfi/srfi-160/u32.go srfi/srfi-160/u64.go \
+ srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -361,6 +367,19 @@ SOURCES = \
srfi/srfi-126.sld \
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 \
@@ -458,6 +477,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..3f9d69855
--- /dev/null
+++ b/module/srfi/srfi-160/base.sld
@@ -0,0 +1,68 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..32bfe8e20
--- /dev/null
+++ b/module/srfi/srfi-160/base/c128-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..44f7a2901
--- /dev/null
+++ b/module/srfi/srfi-160/base/c64-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..ec2b40fc6
--- /dev/null
+++ b/module/srfi/srfi-160/base/complex.scm
@@ -0,0 +1,112 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..0888175a6
--- /dev/null
+++ b/module/srfi/srfi-160/base/f32-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..676f2bfb8
--- /dev/null
+++ b/module/srfi/srfi-160/base/f64-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..0779113ff
--- /dev/null
+++ b/module/srfi/srfi-160/base/r7rec.scm
@@ -0,0 +1,12 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;; 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..320f32321
--- /dev/null
+++ b/module/srfi/srfi-160/base/s16-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..1b7ef1b6e
--- /dev/null
+++ b/module/srfi/srfi-160/base/s32-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..6485241c1
--- /dev/null
+++ b/module/srfi/srfi-160/base/s64-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..7df41eea7
--- /dev/null
+++ b/module/srfi/srfi-160/base/s8-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..2a725f7d4
--- /dev/null
+++ b/module/srfi/srfi-160/base/u16-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..87427eb32
--- /dev/null
+++ b/module/srfi/srfi-160/base/u32-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..59575eb3e
--- /dev/null
+++ b/module/srfi/srfi-160/base/u64-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..a1ba5ccbc
--- /dev/null
+++ b/module/srfi/srfi-160/base/u8-vector2list.scm
@@ -0,0 +1,19 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..2a77973c2
--- /dev/null
+++ b/module/srfi/srfi-160/base/valid.scm
@@ -0,0 +1,27 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..9db7882e7
--- /dev/null
+++ b/module/srfi/srfi-160/c128-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..e7863354e
--- /dev/null
+++ b/module/srfi/srfi-160/c128.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..5c60d5019
--- /dev/null
+++ b/module/srfi/srfi-160/c64-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..06fa28334
--- /dev/null
+++ b/module/srfi/srfi-160/c64.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..3ed3eda5b
--- /dev/null
+++ b/module/srfi/srfi-160/f32-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..5c8c8adbe
--- /dev/null
+++ b/module/srfi/srfi-160/f32.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..9e1809f7e
--- /dev/null
+++ b/module/srfi/srfi-160/f64-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..fbaf3a985
--- /dev/null
+++ b/module/srfi/srfi-160/f64.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..8e195c41e
--- /dev/null
+++ b/module/srfi/srfi-160/s16-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..1d21983f0
--- /dev/null
+++ b/module/srfi/srfi-160/s16.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..1fc7f17bf
--- /dev/null
+++ b/module/srfi/srfi-160/s32-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..a034b0093
--- /dev/null
+++ b/module/srfi/srfi-160/s32.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..aabe8a8b5
--- /dev/null
+++ b/module/srfi/srfi-160/s64-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..623cfe261
--- /dev/null
+++ b/module/srfi/srfi-160/s64.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..9569dbe8c
--- /dev/null
+++ b/module/srfi/srfi-160/s8-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..26cc23e7a
--- /dev/null
+++ b/module/srfi/srfi-160/s8.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..0c017fe9b
--- /dev/null
+++ b/module/srfi/srfi-160/u16-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..eaaaa19f3
--- /dev/null
+++ b/module/srfi/srfi-160/u16.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..0ad064ae8
--- /dev/null
+++ b/module/srfi/srfi-160/u32-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..47d4d5dcf
--- /dev/null
+++ b/module/srfi/srfi-160/u32.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..48f1f3d93
--- /dev/null
+++ b/module/srfi/srfi-160/u64-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..1c03c3194
--- /dev/null
+++ b/module/srfi/srfi-160/u64.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..00705c98a
--- /dev/null
+++ b/module/srfi/srfi-160/u8-impl.scm
@@ -0,0 +1,601 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..8945cef96
--- /dev/null
+++ b/module/srfi/srfi-160/u8.sld
@@ -0,0 +1,49 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..619432e80
--- /dev/null
+++ b/test-suite/tests/srfi-160-base-test.scm
@@ -0,0 +1,168 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..9f1d763a9
--- /dev/null
+++ b/test-suite/tests/srfi-160-base.test
@@ -0,0 +1,35 @@
+;;; srfi-160.test --- Test suite for SRFI-160 base library. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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..130a34b16
--- /dev/null
+++ b/test-suite/tests/srfi-160-test.scm
@@ -0,0 +1,263 @@
+;;; SPDX-FileCopyrightText: 2018 John Cowan <cowan@ccil.org>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;; 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..317a2f47b
--- /dev/null
+++ b/test-suite/tests/srfi-160.test
@@ -0,0 +1,36 @@
+;;; srfi-160.test --- Test suite for SRFI-160 libraries. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 15/18] module: Add SRFI 178.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (13 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 14/18] module: Add SRFI 160 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 16/18] module: Add SRFI 209 Maxim Cournoyer
` (2 subsequent siblings)
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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 v7)
Changes in v7:
- Register prerequisites for srfi/srfi-160/*.go in am/bootstrap.am
NEWS | 1 +
am/bootstrap.am | 12 +
doc/ref/guile.texi | 4 +-
doc/ref/srfi-modules.texi | 604 ++++++++++++++++++
module/srfi/srfi-178.sld | 106 +++
module/srfi/srfi-178/convert.scm | 84 +++
module/srfi/srfi-178/fields.scm | 89 +++
module/srfi/srfi-178/gen-acc.scm | 26 +
module/srfi/srfi-178/logic-ops.scm | 106 +++
module/srfi/srfi-178/macros.scm | 27 +
module/srfi/srfi-178/map2list.scm | 28 +
module/srfi/srfi-178/quasi-ints.scm | 55 ++
module/srfi/srfi-178/quasi-strs.scm | 89 +++
module/srfi/srfi-178/unfolds.scm | 45 ++
module/srfi/srfi-178/wrappers.scm | 286 +++++++++
test-suite/Makefile.am | 11 +
.../tests/srfi-178-test/constructors.scm | 89 +++
.../tests/srfi-178-test/conversions.scm | 109 ++++
test-suite/tests/srfi-178-test/fields.scm | 99 +++
test-suite/tests/srfi-178-test/gen-accum.scm | 73 +++
test-suite/tests/srfi-178-test/iterators.scm | 151 +++++
test-suite/tests/srfi-178-test/logic-ops.scm | 126 ++++
test-suite/tests/srfi-178-test/mutators.scm | 80 +++
test-suite/tests/srfi-178-test/quasi-ints.scm | 42 ++
.../tests/srfi-178-test/quasi-string.scm | 63 ++
test-suite/tests/srfi-178-test/selectors.scm | 14 +
test-suite/tests/srfi-178.test | 149 +++++
27 files changed, 2566 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 d6cdc057a..1ee18dd8b 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -73,6 +73,7 @@ srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \
srfi/srfi-160/s64.go srfi/srfi-160/s8.go srfi/srfi-160/u16.go \
srfi/srfi-160/u32.go srfi/srfi-160/u64.go \
srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go
+srfi/srfi-178.go: srfi/srfi-151.go srfi/srfi-160/u8.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -383,6 +384,7 @@ SOURCES = \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
+ srfi/srfi-178.sld \
\
statprof.scm \
\
@@ -504,6 +506,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..2abebabb8
--- /dev/null
+++ b/module/srfi/srfi-178.sld
@@ -0,0 +1,106 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..7f09f8e24
--- /dev/null
+++ b/module/srfi/srfi-178/convert.scm
@@ -0,0 +1,84 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..99dc791f9
--- /dev/null
+++ b/module/srfi/srfi-178/fields.scm
@@ -0,0 +1,89 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..f45ac0e1a
--- /dev/null
+++ b/module/srfi/srfi-178/gen-acc.scm
@@ -0,0 +1,26 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..438a9a9c1
--- /dev/null
+++ b/module/srfi/srfi-178/logic-ops.scm
@@ -0,0 +1,106 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..5a7e0ae61
--- /dev/null
+++ b/module/srfi/srfi-178/macros.scm
@@ -0,0 +1,27 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;;; 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..ac4d6c1de
--- /dev/null
+++ b/module/srfi/srfi-178/map2list.scm
@@ -0,0 +1,28 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..676a1b629
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-ints.scm
@@ -0,0 +1,55 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..7b175957c
--- /dev/null
+++ b/module/srfi/srfi-178/quasi-strs.scm
@@ -0,0 +1,89 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..582bb3230
--- /dev/null
+++ b/module/srfi/srfi-178/unfolds.scm
@@ -0,0 +1,45 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..935534a3d
--- /dev/null
+++ b/module/srfi/srfi-178/wrappers.scm
@@ -0,0 +1,286 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;;; 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..897766c19
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/constructors.scm
@@ -0,0 +1,89 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..0a2ac2eb6
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/conversions.scm
@@ -0,0 +1,109 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..63433868e
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/fields.scm
@@ -0,0 +1,99 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..df8b28dc9
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/gen-accum.scm
@@ -0,0 +1,73 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..1f39559ee
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/iterators.scm
@@ -0,0 +1,151 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..d04aca96e
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/logic-ops.scm
@@ -0,0 +1,126 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..9a58276b0
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/mutators.scm
@@ -0,0 +1,80 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..2c0fbecaf
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-ints.scm
@@ -0,0 +1,42 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..b3e78f1a5
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/quasi-string.scm
@@ -0,0 +1,63 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..8067cb68a
--- /dev/null
+++ b/test-suite/tests/srfi-178-test/selectors.scm
@@ -0,0 +1,14 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..c76cedd1b
--- /dev/null
+++ b/test-suite/tests/srfi-178.test
@@ -0,0 +1,149 @@
+;;; SPDX-License-Identifier: MIT
+
+;;; 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] 19+ messages in thread* [PATCH v9 16/18] module: Add SRFI 209.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (14 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 15/18] module: Add SRFI 178 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 17/18] module: Add SRFI 48 Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 18/18] module: Upgrade SRFI 64 to modern R7RS library implementation Maxim Cournoyer
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4: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.
---
(no changes since v8)
Changes in v8:
- Incorporate recent fix from Wolfgang (commit 6092dfb)
Changes in v7:
- Register prerequisites for srfi/srfi-209.go in am/bootstrap.am
Changes in v6:
- Add SRFI 209
NEWS | 1 +
am/bootstrap.am | 4 +
doc/ref/guile.texi | 4 +-
doc/ref/srfi-modules.texi | 893 ++++++++++++++++++++++++++++-
module/srfi/srfi-209.sld | 64 +++
module/srfi/srfi-209/209.scm | 693 ++++++++++++++++++++++
test-suite/Makefile.am | 2 +
test-suite/tests/srfi-209-test.scm | 467 +++++++++++++++
test-suite/tests/srfi-209.test | 38 ++
9 files changed, 2158 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 1ee18dd8b..343fe6dcd 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -74,6 +74,8 @@ srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \
srfi/srfi-160/u32.go srfi/srfi-160/u64.go \
srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go
srfi/srfi-178.go: srfi/srfi-151.go srfi/srfi-160/u8.go
+srfi/srfi-209.go: srfi/srfi-1.go srfi/srfi-125.go srfi/srfi-128.go \
+ srfi/srfi-178.go
# All sources. We can compile these in any order; the order below is
# designed to hopefully result in the lowest total compile time.
@@ -385,6 +387,7 @@ SOURCES = \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
srfi/srfi-178.sld \
+ srfi/srfi-209.sld \
\
statprof.scm \
\
@@ -516,6 +519,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..95c8550cd
--- /dev/null
+++ b/module/srfi/srfi-209.sld
@@ -0,0 +1,64 @@
+;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe <wcm@sigwinch.xyz>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(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..ea826da74
--- /dev/null
+++ b/module/srfi/srfi-209/209.scm
@@ -0,0 +1,693 @@
+;;; SPDX-License-Identifier: MIT
+;;;
+;;; 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 ...))
+ (syntax
+ (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..03dd915b8
--- /dev/null
+++ b/test-suite/tests/srfi-209-test.scm
@@ -0,0 +1,467 @@
+;;; SPDX-License-Identifier: MIT
+;;;
+;;; 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..7858dc8d4
--- /dev/null
+++ b/test-suite/tests/srfi-209.test
@@ -0,0 +1,38 @@
+;;; srfi-209.test --- Test suite for SRFI-209. -*- scheme -*-
+;;;
+;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc.
+;;;
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+
+(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] 19+ messages in thread* [PATCH v9 17/18] module: Add SRFI 48.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (15 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 16/18] module: Add SRFI 209 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
2023-12-13 4:37 ` [PATCH v9 18/18] module: Upgrade SRFI 64 to modern R7RS library implementation Maxim Cournoyer
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
* module/srfi/srfi-48.sld: New file.
* module/srfi/srfi-48/48.body.scm: Likewise.
* am/bootstrap.am (srfi/srfi-48.go): New target.
(SOURCES): Register srfi/srfi-48.sld.
(NOCOMP_SOURCES): Register srfi/srfi-48/48.upstream.scm.
* test-suite/tests/srfi-48.test: New test.
* test-suite/Makefile.am (SCM_TESTS): Register it.
---
(no changes since v1)
NEWS | 1 +
am/bootstrap.am | 5 +-
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 264 ++++++++++++++++++
module/srfi/srfi-48.sld | 14 +
module/srfi/srfi-48/48.upstream.scm | 409 ++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-48.test | 320 ++++++++++++++++++++++
8 files changed, 1016 insertions(+), 4 deletions(-)
create mode 100644 module/srfi/srfi-48.sld
create mode 100644 module/srfi/srfi-48/48.upstream.scm
create mode 100644 test-suite/tests/srfi-48.test
diff --git a/NEWS b/NEWS
index a269e0776..1c4dd7b56 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,7 @@ 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 48), a string format library
** Add (srfi 126), a hash tables library
** Add (srfi 128), a comparators library
** Add (scheme comparator)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 343fe6dcd..67460b32d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -54,8 +54,10 @@ COMPILE = $(AM_V_GUILEC) \
.el.go:
$(COMPILE) --from=elisp -o "$@" "$<"
+# Rebuild modules when their included sources have changes.
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
+srfi/srfi-48.go: srfi/srfi-48/48.upstream.scm
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
# Keep this rule in sync with that in `am/guilec'.
@@ -358,6 +360,7 @@ SOURCES = \
srfi/srfi-43.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
+ srfi/srfi-48.sld \
srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \
@@ -474,7 +477,7 @@ NOCOMP_SOURCES = \
ice-9/quasisyntax.scm \
scheme/features.scm \
srfi/srfi-42/ec.scm \
- srfi/srfi-64/testing.scm \
+ srfi/srfi-48/48.upstream.scm \
srfi/srfi-67/compare.scm \
srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f2a2d08f4..9be1b7540 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, 128, 151, 160, 178 and
-209 SRFI modules is adapted from their specification text, which is made
-available under the following Expat license:
+Additionally, the documentation of the 48, 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
copy of this software and associated documentation files (the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 3ca18979f..650d7f27f 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) 2003 Kenneth A Dickey
@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer
@c Copyright (C) 2015-2016, 2018, 2020 John Cowan
@c See the file guile.texi for copying conditions.
@@ -53,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-43:: Vector Library.
* SRFI-45:: Primitives for expressing iterative lazy algorithms
* SRFI-46:: Basic syntax-rules Extensions.
+* SRFI 48:: Intermediate Format Strings.
* SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits.
* SRFI-61:: A more general `cond' clause
@@ -5108,6 +5110,268 @@ SRFI-46/R7RS. Tail patterns have been supported since at least Guile
2.0, and custom ellipsis identifiers have been supported since Guile
2.0.10. @xref{Syntax Rules}.
+@node SRFI 48
+@subsection SRFI 48: Intermediate Format Strings
+@cindex SRFI 48
+
+@menu
+* SRFI 48 Abstract::
+* SRFI 48 Rationale::
+* SRFI 48 Specification::
+@end menu
+
+@node SRFI 48 Abstract
+@subsubsection SRFI 48 Abstract
+
+This document specifies Format Strings, a method of interpreting a
+Scheme string which contains a number of format directives that are
+replaced with other string data according to the semantics of each
+directive. This SRFI extends SRFI 28 in being more generally useful but
+is less general than advanced format strings in that it does not allow,
+aside from ~F, for controlled positioning of text within fields.
+
+@node SRFI 48 Rationale
+@subsubsection SRFI 48 Rationale
+
+Inheriting from MacLisp, nearly all Lisp and Scheme implementations
+support some form of FORMAT function with support for various numbers of
+format directives. By agreeing to the options here, we raise the bar
+for portable code.
+
+The reference implementation is R5RS compliant and easy to port. In not
+requiring advanced features (aside from @samp{~W} and @samp{~F}) small
+implementations are possible. E.g.@: the reference code does not use
+side effects (assignment) and is less than a third the source size of
+the latest SLIB implementation of FORMAT (less than a tenth if @samp{~F}
+support is elided).
+
+The optional @var{port} argument allows for compatibility with older
+code written for, e.g.@: scheme48, MIT Scheme, T, et cetera, which
+required a port argument. It is also useful in cases where a synoptic
+implementation of Scheme and CommonLisp is maintained.
+
+@node SRFI 48 Specification
+@subsubsection SRFI 48 Specification
+
+@deffn format [port] format-string [obj @dots{}]
+
+Accepts a format template (a Scheme String), and processes it, replacing
+any format directives in order with one or more characters, the
+characters themselves dependent on the semantics of the format directive
+encountered. Each directive may consume one @var{obj}. It is an error
+if fewer or more @var{obj} values are provided than format directives
+that require them.
+
+When @var{port} is specified it must be either an output port or a
+boolean. If an output port is specified, the formatted output is output
+into that port. If the @var{port} argument is @code{#t}, output is to
+the @code{current-output-port}. If @var{port} is @code{#f} or no port
+is specified, the output is returned as a string. If @var{port} is
+specified and is @code{#t} or an output port, the result of the format
+function is unspecified.
+
+It is unspecified which encoding is used (e.g.@: ASCII, EBCDIC,
+UNICODE). A given implementation must specify which encoding is used.
+The implementation may or may not allow the encoding to be selected or
+changed.
+
+It is an error if a format directive consumes an @var{obj} argument and
+that argument does not confirm to a required type as noted in the table
+below.
+
+It is permissible, but highly discouraged, to implement
+@code{pretty-print} as @samp{(define pretty-print write)}.
+
+A format directive is a two character sequence in the string where the
+first character is a tilde '~'. Directive characters are
+case-independent, i.e.@: upper and lower case characters are interpreted
+the same. Each directive code's meaning is described in the following
+table:
+
+@multitable @columnfractions .125 .20 .55 .125
+@headitem Directive @tab Mnemonic @tab Action @tab Consumes?
+@item ~a @tab Any @tab (display obj) for humans @tab yes
+@item ~s @tab Slashified @tab (write obj) for parsers @tab yes
+
+@item ~w @tab WriteCircular
+@tab (write-with-shared-structure obj) like ~s, but handles recursive structures
+@tab yes
+
+@item ~d @tab Decimal
+@tab the obj is a number which is output in decimal radix @tab yes
+
+@item ~x @tab heXadecimal
+@tab the obj is a number which is output in hexdecimal radix @tab yes
+
+@item ~o @tab Octal
+@tab the obj is a number which is output in octal radix @tab yes
+
+@item ~b @tab Binary
+@tab the obj is a number which is output in binary radix @tab yes
+
+@item ~c @tab Character
+@tab the single charater obj is output by write-char @tab yes
+
+@item ~y @tab Yuppify
+@tab the list obj is pretty-printed to the output @tab yes
+
+@item ~? @tab Indirection
+@tab the obj is another format-string and the following obj is a list
+of arguments; format is called recursively @tab yes
+
+@item ~K @tab Indirection
+@tab the same as ~? for backward compatibility with
+some existing implementations @tab yes
+
+@item ~[w[,d]]F @tab Fixed
+@tab ~w,dF outputs a number with width w and d digits after the decimal;
+~wF outputs a string or number with width w. @tab yes
+
+@item ~~ @tab Tilde @tab output a tilde @tab no
+@item ~t @tab Tab @tab output a tab character @tab no
+@item ~% @tab Newline @tab output a newline character @tab no
+
+@item ~& @tab Freshline
+@tab output a newline character if it is known that the previous
+output was not a newline @tab no
+
+@item ~_ @tab Space @tab a single space character is output @tab no
+
+@item ~h @tab Help
+@tab outputs one line of call synopsis, one line of comment, and one line of
+synopsis for each format directive, starting with the directive (e.g. "~t")
+@tab no
+@end multitable
+
+The @samp{~F}, fixed format, directive requires some elucidation.
+
+@samp{~wF} is useful for strings or numbers. Where the string (or
+@code{number->string} of the number) has fewer characters than the
+integer width @samp{w}, the string is padded on the left with space
+characters.
+
+@samp{~w,dF} is typically used only on numbers. For strings, the
+@samp{d} specifier is ignored. For numbers, the integer @samp{d}
+specifies the number of decimal digits after the decimal place. Both
+@samp{w} and @samp{d} must be zero or positive.
+
+If @samp{d} is specified, the number is processed as if added to 0.0,
+i.e.@: it is converted to an inexact value.
+
+@lisp
+(format "~8,2F" 1/3) => " 0.33"
+@end lisp
+
+If no @samp{d} is specified, the number is @emph{not} coerced to
+inexact.
+
+@lisp
+(format "~6F" 32) => " 32"
+@end lisp
+
+Digits are padded to the right with zeros.
+
+@lisp
+(format "~8,2F" 32) => " 32.00"
+@end lisp
+
+If the number is too large to fit in the width specified, a string
+longer than the width is returned.
+
+@lisp
+(format "~1,2F" 4321) => "4321.00"
+@end lisp
+
+If the number is complex, @samp{d} is applied to both real and imaginal
+parts.
+
+@lisp
+(format "~1,2F" (sqrt -3.9)) => "0.00+1.97i"
+@end lisp
+
+For very large or very small numbers, the point where exponential
+notation is used is implementation defined.
+
+@lisp
+(format "~8F" 32e5) => " 3.2e6" or "3200000.0"
+@end lisp
+
+@subsubheading Examples
+
+@lisp
+(format "~h")
+; =>
+"(format [<port>] <format-string> [<arg>@dots{}]) -- <port> is #t, #f or an output-port
+OPTION [MNEMONIC] DESCRIPTION -- This implementation Assumes ASCII Text Encoding
+~H [Help] output this text
+~A [Any] (display arg) for humans
+~S [Slashified] (write arg) for parsers
+~~ [tilde] output a tilde
+~T [Tab] output a tab character
+~% [Newline] output a newline character
+~& [Freshline] output a newline character if the previous output was not a newline
+~D [Decimal] the arg is a number which is output in decimal radix
+~X [heXadecimal] the arg is a number which is output in hexdecimal radix
+~O [Octal] the arg is a number which is output in octal radix
+~B [Binary] the arg is a number which is output in binary radix
+~w,dF [Fixed] the arg is a string or number which has width w and d digits after the decimal
+~C [Character] charater arg is output by write-char
+~_ [Space] a single space character is output
+~Y [Yuppify] the list arg is pretty-printed to the output
+~? [Indirection] recursive format: next arg is a format-string and the following arg a list of arguments
+~K [Indirection] same as ~?
+"
+(format "Hello, ~a" "World!")
+; => "Hello, World!"
+(format "Error, list is too short: ~s" '(one "two" 3))
+; => "Error, list is too short: (one \"two\" 3)"
+(format "test me")
+; => "test me"
+(format "~a ~s ~a ~s" 'this 'is "a" "test")
+; => "this is a \"test\""
+(format #t "#d~d #x~x #o~o #b~b~%" 32 32 32 32)
+;; Prints: #d32 #x20 #o40 #b100000
+; => <unspecified>
+(format "~a ~? ~a" 'a "~s" '(new) 'test)
+; =>"a new test"
+(format #f "~&1~&~&2~&~&~&3~%")
+; =>
+"
+1
+2
+3
+"
+(format #f "~a ~? ~a ~%" 3 " ~s ~s " '(2 2) 3)
+; =>
+"3 2 2 3
+"
+(format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c))
+; => "#1=(a b c . #1#)"
+(format "~8,2F" 32)
+; => " 32.00"
+(format "~8,3F" (sqrt -3.8))
+; => "0.000+1.949i"
+(format "~8,2F" 3.4567e11)
+; => " 3.45e11"
+(format "~6,3F" 1/3)
+; => " 0.333"
+(format "~4F" 12)
+; => " 12"
+(format "~8,3F" 123.3456)
+; => " 123.346"
+ (format "~6,3F" 123.3456)
+; => "123.346"
+ (format "~2,3F" 123.3456)
+; => "123.346"
+(format "~8,3F" "foo")
+; => " foo"
+(format "~a~a~&" (list->string (list #\newline)) "")
+; =>
+"
+"
+@end lisp
+@end deffn
+
@node SRFI-55
@subsection SRFI-55 - Requiring Features
@cindex SRFI-55
diff --git a/module/srfi/srfi-48.sld b/module/srfi/srfi-48.sld
new file mode 100644
index 000000000..f488ca088
--- /dev/null
+++ b/module/srfi/srfi-48.sld
@@ -0,0 +1,14 @@
+;;;; SPDX-FileCopyrightText: 2014 Taylan Kammer <taylan.kammer@gmail.com>
+;;;;
+;;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 48)
+ (export format)
+ (import (rename (scheme base)
+ (exact inexact->exact)
+ (inexact exact->inexact))
+ (scheme char)
+ (scheme complex)
+ (rename (scheme write)
+ (write-shared write-with-shared-structure)))
+ (include "srfi-48/48.upstream.scm"))
diff --git a/module/srfi/srfi-48/48.upstream.scm b/module/srfi/srfi-48/48.upstream.scm
new file mode 100644
index 000000000..960d1a6b4
--- /dev/null
+++ b/module/srfi/srfi-48/48.upstream.scm
@@ -0,0 +1,409 @@
+;;; SPDX-FileCopyrightText: 2003 Kenneth A Dickey <ken.dickey@allvantage.com>
+;;; SPDX-FileCopyrightText: 2017 Hamayama <hamay1010@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;; IMPLEMENTATION DEPENDENT options
+
+(define ascii-tab (integer->char 9)) ;; NB: assumes ASCII encoding
+(define dont-print (if (eq? #t #f) 1))
+;;(define DONT-PRINT (string->symbol ""))
+;;(define DONT-PRINT (void))
+;;(define DONT-PRINT #!void)
+(define pretty-print write) ; ugly but permitted
+;; (require 'srfi-38) ;; write-with-shared-structure
+
+;; Following three procedures are used by format ~F .
+;; 'inexact-number->string' determines whether output is fixed-point
+;; notation or exponential notation. In the current definition,
+;; the notation depends on the implementation of 'number->string'.
+;; 'exact-number->string' is expected to output only numeric characters
+;; (not including such as '#', 'e', '.', '/') if the input is an positive
+;; integer or zero.
+;; 'real-number->string' is used when the digits of ~F is not specified.
+(define (inexact-number->string x) (number->string (exact->inexact x)))
+(define (exact-number->string x) (number->string (inexact->exact x)))
+(define (real-number->string x) (number->string x))
+
+;; FORMAT
+(define (format . args)
+ (cond
+ ((null? args)
+ (error "FORMAT: required format-string argument is missing")
+ )
+ ((string? (car args))
+ (apply format (cons #f args)))
+ ((< (length args) 2)
+ (error (format #f "FORMAT: too few arguments ~s" (cons 'format args)))
+ )
+ (else
+ (let ( (output-port (car args))
+ (format-string (cadr args))
+ (args (cddr args))
+ )
+ (letrec ( (port
+ (cond ((output-port? output-port) output-port)
+ ((eq? output-port #t) (current-output-port))
+ ((eq? output-port #f) (open-output-string))
+ (else (error
+ (format #f "FORMAT: bad output-port argument: ~s"
+ output-port)))
+ ) )
+ (return-value
+ (if (eq? output-port #f) ;; if format into a string
+ (lambda () (get-output-string port)) ;; then return the string
+ (lambda () dont-print)) ;; else do something harmless
+ )
+ )
+
+ (define (string-index str c)
+ (let ( (len (string-length str)) )
+ (let loop ( (i 0) )
+ (cond ((= i len) #f)
+ ((eqv? c (string-ref str i)) i)
+ (else (loop (+ i 1)))))))
+
+ (define (string-grow str len char)
+ (let ( (off (- len (string-length str))) )
+ (if (positive? off)
+ (string-append (make-string off char) str)
+ str)))
+
+ (define (compose-with-digits digits pre-str frac-str exp-str)
+ (let ( (frac-len (string-length frac-str)) )
+ (cond
+ ((< frac-len digits) ;; grow frac part, pad with zeros
+ (string-append pre-str "."
+ frac-str (make-string (- digits frac-len) #\0)
+ exp-str)
+ )
+ ((= frac-len digits) ;; frac-part is exactly the right size
+ (string-append pre-str "."
+ frac-str
+ exp-str)
+ )
+ (else ;; must round to shrink it
+ (let* ( (minus-flag (and (> (string-length pre-str) 0)
+ (char=? (string-ref pre-str 0) #\-)))
+ (pre-str* (if minus-flag
+ (substring pre-str 1 (string-length pre-str))
+ pre-str))
+ (first-part (substring frac-str 0 digits))
+ (last-part (substring frac-str digits frac-len))
+ (temp-str
+ (string-grow
+ (exact-number->string
+ (round (string->number
+ (string-append pre-str* first-part "." last-part))))
+ digits
+ #\0))
+ (temp-len (string-length temp-str))
+ (new-pre (substring temp-str 0 (- temp-len digits)))
+ (new-frac (substring temp-str (- temp-len digits) temp-len))
+ )
+ (string-append
+ (if minus-flag "-" "")
+ (if (string=? new-pre "")
+ ;; check if the system displays integer part of numbers
+ ;; whose absolute value is 0 < x < 1.
+ (if (and (string=? pre-str* "")
+ (> digits 0)
+ (not (= (string->number new-frac) 0)))
+ "" "0")
+ new-pre)
+ "."
+ new-frac
+ exp-str)))
+ ) ) )
+
+ (define (format-fixed number-or-string width digits) ; returns a string
+ (cond
+ ((string? number-or-string)
+ (string-grow number-or-string width #\space)
+ )
+ ((number? number-or-string)
+ (let ( (real (real-part number-or-string))
+ (imag (imag-part number-or-string))
+ )
+ (cond
+ ((not (zero? imag))
+ (string-grow
+ (string-append (format-fixed real 0 digits)
+ (if (negative? imag) "" "+")
+ (format-fixed imag 0 digits)
+ "i")
+ width
+ #\space)
+ )
+ (digits
+ (let* ( (num-str (inexact-number->string real))
+ (dot-index (string-index num-str #\.))
+ (exp-index (string-index num-str #\e))
+ (length (string-length num-str))
+ (pre-string
+ (if dot-index
+ (substring num-str 0 dot-index)
+ (if exp-index
+ (substring num-str 0 exp-index)
+ num-str))
+ )
+ (exp-string
+ (if exp-index
+ (substring num-str exp-index length)
+ "")
+ )
+ (frac-string
+ (if dot-index
+ (if exp-index
+ (substring num-str (+ dot-index 1) exp-index)
+ (substring num-str (+ dot-index 1) length))
+ "")
+ )
+ )
+ ;; check +inf.0, -inf.0, +nan.0, -nan.0
+ (if (string-index num-str #\n)
+ (string-grow num-str width #\space)
+ (string-grow
+ (compose-with-digits digits
+ pre-string
+ frac-string
+ exp-string)
+ width
+ #\space))
+ ))
+ (else ;; no digits
+ (string-grow (real-number->string real) width #\space)))
+ ))
+ (else
+ (error
+ (format "FORMAT: ~F requires a number or a string, got ~s" number-or-string)))
+ ))
+
+ (define documentation-string
+"(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port
+OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Encoding
+~H [Help] output this text
+~A [Any] (display arg) for humans
+~S [Slashified] (write arg) for parsers
+~W [WriteCircular] like ~s but outputs circular and recursive data structures
+~~ [tilde] output a tilde
+~T [Tab] output a tab character
+~% [Newline] output a newline character
+~& [Freshline] output a newline character if the previous output was not a newline
+~D [Decimal] the arg is a number which is output in decimal radix
+~X [heXadecimal] the arg is a number which is output in hexdecimal radix
+~O [Octal] the arg is a number which is output in octal radix
+~B [Binary] the arg is a number which is output in binary radix
+~w,dF [Fixed] the arg is a string or number which has width w and d digits after the decimal
+~C [Character] charater arg is output by write-char
+~_ [Space] a single space character is output
+~Y [Yuppify] the list arg is pretty-printed to the output
+~? [Indirection] recursive format: next 2 args are format-string and list of arguments
+~K [Indirection] same as ~?
+"
+ )
+
+ (define (require-an-arg args)
+ (if (null? args)
+ (error "FORMAT: too few arguments" ))
+ )
+
+ (define (format-help format-strg arglist)
+
+ (letrec (
+ (length-of-format-string (string-length format-strg))
+
+ (anychar-dispatch
+ (lambda (pos arglist last-was-newline)
+ (if (>= pos length-of-format-string)
+ arglist ; return unused args
+ (let ( (char (string-ref format-strg pos)) )
+ (cond
+ ((eqv? char #\~)
+ (tilde-dispatch (+ pos 1) arglist last-was-newline))
+ (else
+ (write-char char port)
+ (anychar-dispatch (+ pos 1) arglist #f)
+ ))
+ ))
+ )) ; end anychar-dispatch
+
+ (has-newline?
+ (lambda (whatever last-was-newline)
+ (or (eqv? whatever #\newline)
+ (and (string? whatever)
+ (let ( (len (string-length whatever)) )
+ (if (zero? len)
+ last-was-newline
+ (eqv? #\newline (string-ref whatever (- len 1)))))))
+ )) ; end has-newline?
+
+ (tilde-dispatch
+ (lambda (pos arglist last-was-newline)
+ (cond
+ ((>= pos length-of-format-string)
+ (write-char #\~ port) ; tilde at end of string is just output
+ arglist ; return unused args
+ )
+ (else
+ (case (char-upcase (string-ref format-strg pos))
+ ((#\A) ; Any -- for humans
+ (require-an-arg arglist)
+ (let ( (whatever (car arglist)) )
+ (display whatever port)
+ (anychar-dispatch (+ pos 1)
+ (cdr arglist)
+ (has-newline? whatever last-was-newline))
+ ))
+ ((#\S) ; Slashified -- for parsers
+ (require-an-arg arglist)
+ (let ( (whatever (car arglist)) )
+ (write whatever port)
+ (anychar-dispatch (+ pos 1)
+ (cdr arglist)
+ (has-newline? whatever last-was-newline))
+ ))
+ ((#\W)
+ (require-an-arg arglist)
+ (let ( (whatever (car arglist)) )
+ (write-with-shared-structure whatever port) ;; srfi-38
+ (anychar-dispatch (+ pos 1)
+ (cdr arglist)
+ (has-newline? whatever last-was-newline))
+ ))
+ ((#\D) ; Decimal
+ (require-an-arg arglist)
+ (display (number->string (car arglist) 10) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\X) ; HeXadecimal
+ (require-an-arg arglist)
+ (display (number->string (car arglist) 16) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\O) ; Octal
+ (require-an-arg arglist)
+ (display (number->string (car arglist) 8) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\B) ; Binary
+ (require-an-arg arglist)
+ (display (number->string (car arglist) 2) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\C) ; Character
+ (require-an-arg arglist)
+ (write-char (car arglist) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) (eqv? (car arglist) #\newline))
+ )
+ ((#\~) ; Tilde
+ (write-char #\~ port)
+ (anychar-dispatch (+ pos 1) arglist #f)
+ )
+ ((#\%) ; Newline
+ (newline port)
+ (anychar-dispatch (+ pos 1) arglist #t)
+ )
+ ((#\&) ; Freshline
+ (if (not last-was-newline) ;; (unless last-was-newline ..
+ (newline port))
+ (anychar-dispatch (+ pos 1) arglist #t)
+ )
+ ((#\_) ; Space
+ (write-char #\space port)
+ (anychar-dispatch (+ pos 1) arglist #f)
+ )
+ ((#\T) ; Tab -- IMPLEMENTATION DEPENDENT ENCODING
+ (write-char ascii-tab port)
+ (anychar-dispatch (+ pos 1) arglist #f)
+ )
+ ((#\Y) ; Pretty-print
+ (pretty-print (car arglist) port) ;; IMPLEMENTATION DEPENDENT
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\F)
+ (require-an-arg arglist)
+ (display (format-fixed (car arglist) 0 #f) port)
+ (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+ )
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ;; gather "~w[,d]F" w and d digits
+ (let loop ( (index (+ pos 1))
+ (w-digits (list (string-ref format-strg pos)))
+ (d-digits '())
+ (in-width? #t)
+ )
+ (if (>= index length-of-format-string)
+ (error
+ (format "FORMAT: improper numeric format directive in ~s" format-strg))
+ (let ( (next-char (string-ref format-strg index)) )
+ (cond
+ ((char-numeric? next-char)
+ (if in-width?
+ (loop (+ index 1)
+ (cons next-char w-digits)
+ d-digits
+ in-width?)
+ (loop (+ index 1)
+ w-digits
+ (cons next-char d-digits)
+ in-width?))
+ )
+ ((char=? (char-upcase next-char) #\F)
+ (let ( (width (string->number (list->string (reverse w-digits))))
+ (digits (if (zero? (length d-digits))
+ #f
+ (string->number (list->string (reverse d-digits)))))
+ )
+ (display (format-fixed (car arglist) width digits) port)
+ (anychar-dispatch (+ index 1) (cdr arglist) #f))
+ )
+ ((char=? next-char #\,)
+ (if in-width?
+ (loop (+ index 1)
+ w-digits
+ d-digits
+ #f)
+ (error
+ (format "FORMAT: too many commas in directive ~s" format-strg)))
+ )
+ (else
+ (error (format "FORMAT: ~~w.dF directive ill-formed in ~s" format-strg))))))
+ ))
+ ((#\? #\K) ; indirection -- take next arg as format string
+ (cond ; and following arg as list of format args
+ ((< (length arglist) 2)
+ (error
+ (format "FORMAT: less arguments than specified for ~~?: ~s" arglist))
+ )
+ ((not (string? (car arglist)))
+ (error
+ (format "FORMAT: ~~? requires a string: ~s" (car arglist)))
+ )
+ (else
+ (format-help (car arglist) (cadr arglist))
+ (anychar-dispatch (+ pos 1) (cddr arglist) #f)
+ )))
+ ((#\H) ; Help
+ (display documentation-string port)
+ (anychar-dispatch (+ pos 1) arglist #t)
+ )
+ (else
+ (error (format "FORMAT: unknown tilde escape: ~s"
+ (string-ref format-strg pos))))
+ )))
+ )) ; end tilde-dispatch
+ ) ; end letrec
+
+ ; format-help main
+ (anychar-dispatch 0 arglist #f)
+ )) ; end format-help
+
+ ; format main
+ (let ( (unused-args (format-help format-string args)) )
+ (if (not (null? unused-args))
+ (error
+ (format "FORMAT: unused arguments ~s" unused-args)))
+ (return-value))
+
+ )) ; end letrec, if
+))) ; end format
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 2b5156923..612f6935c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -153,6 +153,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-42.test \
tests/srfi-43.test \
tests/srfi-45.test \
+ tests/srfi-48.test \
tests/srfi-60.test \
tests/srfi-64.test \
tests/srfi-67.test \
diff --git a/test-suite/tests/srfi-48.test b/test-suite/tests/srfi-48.test
new file mode 100644
index 000000000..9d97a863d
--- /dev/null
+++ b/test-suite/tests/srfi-48.test
@@ -0,0 +1,320 @@
+;;; SPDX-FileCopyrightText: 2017 Hamayama <hamay1010@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;
+;; srfi-48 format test for Gauche, Sagittarius, Guile, Chez Scheme
+;;
+
+;;; START Guile-specific modifications.
+(use-modules (srfi srfi-48)
+ (test-suite lib))
+
+(define-syntax-rule (test-start name)
+ #t)
+
+(define-syntax-rule (test-end)
+ #t)
+
+(define-syntax-rule (test-section name)
+ #t)
+
+(define-syntax expect
+ (syntax-rules ()
+ ((_ expected result)
+ (pass-if (equal? expected result)))
+ ((_ expected result check)
+ (pass-if (check expected result)))))
+;;; END Guile-specific modifications.
+
+(cond-expand
+ (gauche)
+ (else
+ (define (x->number x)
+ (cond
+ ((number? x) x)
+ ((string? x) (string->number x))
+ (else (error "x->number error"))))
+ ))
+
+(define (nearly=? a b)
+ (let* ((a1 (x->number a))
+ (b1 (x->number b))
+ (e1 (abs (- a1 b1))))
+ ;(format #t "(a1 = ~s, b1 = ~s, e1 = ~s)~%" a1 b1 e1)
+ (< e1 1.0e-10)))
+
+(define pi 3.141592653589793)
+
+(test-start "srfi-48 format test")
+
+(test-section "original")
+(expect (format "test ~s" 'me) (format #f "test ~a" "me"))
+(expect " 0.333" (format "~6,3F" 1/3)) ;;; " .333" OK
+(expect " 12" (format "~4F" 12))
+(expect " 12.346" (format "~8,3F" 12.3456))
+(expect "123.346" (format "~6,3F" 123.3456))
+(expect "123.346" (format "~4,3F" 123.3456))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+(expect " 32.00" (format "~6,2F" 32))
+(expect " 32" (format "~6F" 32))
+;(expect " 32." (format "~6F" 32.)) ;; " 32.0" OK
+(expect " 32.0" (format "~6F" 32.))
+;; NB: (not (and (exact? 32.) (integer? 32.)))
+(expect " 3.2e46" (format "~8F" 32e45))
+(expect " 3.2e-44" (format "~8F" 32e-45))
+(expect " 3.2e21" (format "~8F" 32e20))
+;;(expect " 3.2e6" (format "~8F" 32e5)) ;; ok. converted in input to 3200000.0
+;(expect " 3200." (format "~8F" 32e2)) ;; " 3200.0" OK
+(expect " 3200.0" (format "~8F" 32e2))
+(expect " 3.20e11" (format "~8,2F" 32e10))
+(expect " 1.2345" (format "~12F" 1.2345))
+(expect " 1.23" (format "~12,2F" 1.2345))
+(expect " 1.234" (format "~12,3F" 1.2345))
+(expect " 0.000+1.949i" (format "~20,3F" (sqrt -3.8)))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+(expect " 3.46e11" (format "~8,2F" 3.4567e11))
+; (expect "#1=(a b c . #1#)"
+; (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c)))
+(expect "
+"
+ (format "~A~A~&" (list->string (list #\newline)) ""))
+(expect "a new test"
+ (format "~a ~? ~a" 'a "~s" '(new) 'test))
+(expect "a new test, yes!"
+ (format "~a ~?, ~a!" 'a "~s ~a" '(new test) 'yes))
+(expect " 3.46e20" (format "~8,2F" 3.4567e20))
+(expect " 3.46e21" (format "~8,2F" 3.4567e21))
+(expect " 3.46e22" (format "~8,2F" 3.4567e22))
+(expect " 3.46e23" (format "~8,2F" 3.4567e23))
+(expect " 3.e24" (format "~8,0F" 3.4567e24))
+(expect " 3.5e24" (format "~8,1F" 3.4567e24))
+(expect " 3.46e24" (format "~8,2F" 3.4567e24))
+(expect "3.457e24" (format "~8,3F" 3.4567e24))
+(expect " 4.e24" (format "~8,0F" 3.5567e24))
+(expect " 3.6e24" (format "~8,1F" 3.5567e24))
+(expect " 3.56e24" (format "~8,2F" 3.5567e24))
+(expect " -3.e-4" (format "~10,0F" -3e-4))
+(expect " -3.0e-4" (format "~10,1F" -3e-4))
+(expect " -3.00e-4" (format "~10,2F" -3e-4))
+(expect " -3.000e-4" (format "~10,3F" -3e-4))
+(expect "-3.0000e-4" (format "~10,4F" -3e-4))
+(expect "-3.00000e-4" (format "~10,5F" -3e-4))
+(expect " 1.020" (format "~10,3F" 1.02))
+(expect " 1.025" (format "~10,3F" 1.025))
+(expect " 1.026" (format "~10,3F" 1.0256))
+(expect " 1.002" (format "~10,3F" 1.002))
+(expect " 1.002" (format "~10,3F" 1.0025))
+(expect " 1.003" (format "~10,3F" 1.00256))
+
+
+(test-section "examples")
+(expect " 0.33" (format "~8,2F" 1/3))
+(expect " 32" (format "~6F" 32))
+(expect " 32.00" (format "~8,2F" 32))
+(expect "4321.00" (format "~1,2F" 4321))
+(expect "0.00+1.97i" (format "~1,2F" (sqrt -3.9)))
+(expect "3200000.0" (format "~8F" 32e5))
+;(expect " 3.2e6" (format "~8F" 32e5))
+(expect "<string>" (format "~h") (lambda (e r) (string? r)))
+(expect "Hello, World!" (format "Hello, ~a" "World!"))
+(expect "Error, list is too short: (one \"two\" 3)" (format "Error, list is too short: ~s" '(one "two" 3)))
+(expect "test me" (format "test me"))
+(expect "this is a \"test\"" (format "~a ~s ~a ~s" 'this 'is "a" "test"))
+(expect (if #f #f) (format #t "#d~d #x~x #o~o #b~b~%" 32 32 32 32))
+(expect "a new test" (format "~a ~? ~a" 'a "~s" '(new) 'test))
+(expect "\n1\n2\n3\n" (format #f "~&1~&~&2~&~&~&3~%"))
+(expect "3 2 2 3 \n" (format #f "~a ~? ~a ~%" 3 " ~s ~s " '(2 2) 3))
+;; incorrect mutation of literal list in example
+;(expect "#1=(a b c . #1#)" (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c)))
+(cond-expand
+ (chezscheme)
+ (guile
+ (expect "#1=(a b c . #1#)" (format "~w" (let ( (c (list 'a 'b 'c)) ) (set-cdr! (cddr c) c) c)))
+ )
+ (else
+ (expect "#0=(a b c . #0#)" (format "~w" (let ( (c (list 'a 'b 'c)) ) (set-cdr! (cddr c) c) c)))
+ ))
+(expect " 32.00" (format "~8,2F" 32))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+;(expect " 3.45e11" (format "~8,2F" 3.4567e11))
+(expect " 3.46e11" (format "~8,2F" 3.4567e11))
+(expect " 0.333" (format "~6,3F" 1/3))
+(expect " 12" (format "~4F" 12))
+(expect " 123.346" (format "~8,3F" 123.3456))
+(expect "123.346" (format "~6,3F" 123.3456))
+(expect "123.346" (format "~2,3F" 123.3456))
+(expect " foo" (format "~8,3F" "foo"))
+(expect "\n" (format "~a~a~&" (list->string (list #\newline)) ""))
+
+
+(test-section "~F normal")
+(expect "0" (format "~F" 0))
+(expect "1" (format "~F" 1))
+(expect "123" (format "~F" 123))
+(expect "0.456" (format "~F" 0.456))
+(expect "123.456" (format "~F" 123.456))
+(expect "-1" (format "~F" -1))
+(expect "-123" (format "~F" -123))
+(expect "-0.456" (format "~F" -0.456))
+(expect "-123.456" (format "~F" -123.456))
+
+
+(test-section "~F width")
+(expect "123" (format "~0F" 123))
+(expect "123" (format "~1F" 123))
+(expect "123" (format "~2F" 123))
+(expect "123" (format "~3F" 123))
+(expect " 123" (format "~4F" 123))
+(expect " 123" (format "~5F" 123))
+(expect "-123" (format "~3F" -123))
+(expect "-123" (format "~4F" -123))
+(expect " -123" (format "~5F" -123))
+(expect " -123" (format "~6F" -123))
+
+
+(test-section "~F digits")
+(expect "123." (format "~1,0F" 123))
+(expect "123.0" (format "~1,1F" 123))
+(expect "123.00" (format "~1,2F" 123))
+(expect "0.12" (format "~1,2F" 0.123))
+(expect "0.123" (format "~1,3F" 0.123))
+(expect "0.1230" (format "~1,4F" 0.123))
+(expect "-123." (format "~1,0F" -123))
+(expect "-123.0" (format "~1,1F" -123))
+(expect "-123.00" (format "~1,2F" -123))
+(expect "-0.12" (format "~1,2F" -0.123))
+(expect "-0.123" (format "~1,3F" -0.123))
+(expect "-0.1230" (format "~1,4F" -0.123))
+
+
+(test-section "~F rounding (banker's rounding)")
+(expect "123." (format "~1,0F" 123.456))
+(expect "123.5" (format "~1,1F" 123.456))
+(expect "123.46" (format "~1,2F" 123.456))
+(expect "-123." (format "~1,0F" -123.456))
+(expect "-123.5" (format "~1,1F" -123.456))
+(expect "-123.46" (format "~1,2F" -123.456))
+(expect "123.0" (format "~1,1F" 123.05))
+(expect "123.2" (format "~1,1F" 123.15))
+(expect "124.0" (format "~1,1F" 123.95))
+(expect "-123.0" (format "~1,1F" -123.05))
+(expect "-123.2" (format "~1,1F" -123.15))
+(expect "-124.0" (format "~1,1F" -123.95))
+(expect "1000.00" (format "~1,2F" 999.995))
+(expect "-1000.00" (format "~1,2F" -999.995))
+(expect "1." (format "~1,0F" 1.49))
+(expect "2." (format "~1,0F" 1.5))
+(expect "2." (format "~1,0F" 1.51))
+(expect "2." (format "~1,0F" 2.49))
+(expect "2." (format "~1,0F" 2.5))
+(expect "3." (format "~1,0F" 2.51))
+
+
+(test-section "~F misc")
+(expect "+inf.0" (format "~F" +inf.0))
+(expect "-inf.0" (format "~F" -inf.0))
+(expect "+nan.0" (format "~F" +nan.0))
+(expect "0.0" (format "~F" 0.0))
+(expect "-0.0" (format "~F" -0.0))
+(expect "+inf.0" (format "~1F" +inf.0))
+(expect "-inf.0" (format "~1F" -inf.0))
+(expect "+nan.0" (format "~1F" +nan.0))
+(expect "0.0" (format "~1F" 0.0))
+(expect "-0.0" (format "~1F" -0.0))
+(expect "+inf.0" (format "~1,0F" +inf.0))
+(expect "-inf.0" (format "~1,0F" -inf.0))
+(expect "+nan.0" (format "~1,0F" +nan.0))
+(expect "0." (format "~1,0F" 0.0))
+(expect "-0." (format "~1,0F" -0.0))
+(expect "+inf.0" (format "~1,1F" +inf.0))
+(expect "-inf.0" (format "~1,1F" -inf.0))
+(expect "+nan.0" (format "~1,1F" +nan.0))
+(expect "0.0" (format "~1,1F" 0.0))
+(expect "-0.0" (format "~1,1F" -0.0))
+(expect "31.41592653589793" (format "~F" (* pi 10)))
+(expect "0.33333" (format "~1,5F" 1/3))
+(expect "-0.33333" (format "~1,5F" -1/3))
+(expect "0.142857142857" (format "~1,12F" 1/7))
+(expect "299999999.999999999" (format "~F" 299999999999999999/1000000000) nearly=?)
+(expect "1.797693e308" (format "~F" 1.797693e308))
+(expect "1.797693e308" (format "~1F" 1.797693e308))
+(expect "2.e308" (format "~1,0F" 1.797693e308))
+(expect "1.8e308" (format "~1,1F" 1.797693e308))
+(expect "-1.797693e308" (format "~F" -1.797693e308))
+(expect "-1.797693e308" (format "~1F" -1.797693e308))
+(expect "-2.e308" (format "~1,0F" -1.797693e308))
+(expect "-1.8e308" (format "~1,1F" -1.797693e308))
+(expect "2.225074e-308" (format "~F" 2.225074e-308))
+(expect "5.02" (format "~1,2F" 5.015))
+(expect "6.00" (format "~1,2F" 5.999))
+(expect "123." (format "~1,0F" 123.00))
+(expect "0.1" (format "~F" .1))
+(expect "1" (format "~1f" 1)) ; lower case f
+(expect "1.e100" (format "~1,0F" 1e100))
+(expect "1." (format "~1,0F" 1))
+(expect "0." (format "~1,0F" .1))
+(expect "0.0" (format "~1,1F" .01))
+
+
+(cond-expand
+ (guile)
+ (else
+ (test-section "~F error")
+ (expect "<error>" (guard (e (else "<error>")) (format "~-1F" 1)))
+ (expect "<error>" (guard (e (else "<error>")) (format "~1,-1F" 1)))
+ ))
+
+
+(test-section "from mailing list 2004-05-27")
+(expect "1.230e20" (format "~0,3F" 1.23e20))
+(expect "1.230e-20" (format "~0,3F" 1.23e-20))
+
+
+(test-section "from mailing list 2004-06-11")
+(expect "3.457e15" (format "~8,3F" 3.4569e15))
+(expect " 3.457" (format "~8,3F" 3.4569))
+(expect " 3.46e15" (format "~8,2F" 3.456e15))
+(expect " 3.46" (format "~8,2F" 3.456))
+
+
+(test-section "from mailing list 2005-06-03")
+(expect " -3.e-4" (format "~10,0F" -3e-4))
+(expect " -3.0e-4" (format "~10,1F" -3e-4))
+(expect " -3.00e-4" (format "~10,2F" -3e-4))
+(expect " -3.000e-4" (format "~10,3F" -3e-4))
+(expect "-3.0000e-4" (format "~10,4F" -3e-4))
+(expect " 3.0000e-5" (format "~10,4F" 3e-5))
+
+
+(test-section "from mailing list 2005-06-07")
+(expect " 1.020" (format "~10,3F" 1.02))
+(expect " 1.025" (format "~10,3F" 1.025))
+(expect " 1.026" (format "~10,3F" 1.0256))
+(expect " 1.002" (format "~10,3F" 1.002))
+(expect " 1.002" (format "~10,3F" 1.0025))
+(expect " 1.003" (format "~10,3F" 1.00256))
+
+
+(test-section "from mailing list 2005-06-07")
+(expect "1.000012" (format "~8,6F" 1.00001234))
+
+
+(test-section "from mailing list 2005-07-02")
+(expect "abc\ndef\nghi\n" (format "abc~%~&def~&ghi~%"))
+(expect "\ndef\nghi\n" (format "~&def~&ghi~%"))
+
+
+(test-section "from mailing list 2017-10-11")
+(expect " 1.00" (format "~7,2F" .997554209949891))
+(expect " 1.00" (format "~7,2F" .99755))
+(expect " 1.00" (format "~7,2F" .9975))
+(expect " 1.00" (format "~7,2F" .997))
+(expect " 0.99" (format "~7,2F" .99))
+
+
+(test-section "from mailing list 2017-10-13")
+(expect " 18.00" (format "~7,2F" 18.0000000000008))
+(expect " -15." (format "~8,0F" -14.99995999999362))
+
+(test-end)
--
2.41.0
^ permalink raw reply related [flat|nested] 19+ messages in thread* [PATCH v9 18/18] module: Upgrade SRFI 64 to modern R7RS library implementation.
2023-12-13 4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
` (16 preceding siblings ...)
2023-12-13 4:37 ` [PATCH v9 17/18] module: Add SRFI 48 Maxim Cournoyer
@ 2023-12-13 4:37 ` Maxim Cournoyer
17 siblings, 0 replies; 19+ messages in thread
From: Maxim Cournoyer @ 2023-12-13 4:37 UTC (permalink / raw)
To: guile-devel; +Cc: Maxim Cournoyer
This upgrades our SRFI 64 copy to use the alternative R7RS
implementation from Taylan Kammer, which improves readability by
leveraging modern Scheme features and fixes a few bugs such as bug#66776
(test-error doesn't match error types).
* am/bootstrap.am (srfi/srfi-64.go): Update target.
(srfi/srfi-64/test-runner.go)
(srfi/srfi-64/test-runner-simple.go, srfi/srfi-64/source-info.go)
(srfi/srfi-64/execution.go): New targets.
* am/bootstrap.am (SOURCES): Register new libary files.
(NOCOMP_SOURCES): Register new included source files.
* module/srfi/srfi-64.scm: Replace with...
* module/srfi/srfi-64.sld: ... this.
* module/srfi/srfi-64/execution.body.scm
* module/srfi/srfi-64/execution.exports.sld
* module/srfi/srfi-64/execution.sld
* module/srfi/srfi-64/source-info.body.scm
* module/srfi/srfi-64/source-info.sld
* module/srfi/srfi-64/test-runner-simple.body.scm
* module/srfi/srfi-64/test-runner-simple.exports.sld
* module/srfi/srfi-64/test-runner-simple.sld
* module/srfi/srfi-64/test-runner.body.scm
* module/srfi/srfi-64/test-runner.exports.sld
* module/srfi/srfi-64/test-runner.sld: New files.
* module/srfi/srfi-64/testing.scm: Delete file.
* test-suite/tests/srfi-64-test.scm: Add license SPDX metadata.
Fixes: https://bugs.gnu.org/66776
---
(no changes since v1)
NEWS | 28 +
am/bootstrap.am | 22 +-
module/srfi/srfi-64.scm | 56 -
module/srfi/srfi-64.sld | 63 +
module/srfi/srfi-64/execution.body.scm | 426 +++++++
module/srfi/srfi-64/execution.exports.sld | 18 +
module/srfi/srfi-64/execution.sld | 23 +
module/srfi/srfi-64/source-info.body.scm | 90 ++
module/srfi/srfi-64/source-info.sld | 14 +
.../srfi/srfi-64/test-runner-simple.body.scm | 170 +++
.../srfi-64/test-runner-simple.exports.sld | 12 +
module/srfi/srfi-64/test-runner-simple.sld | 13 +
module/srfi/srfi-64/test-runner.body.scm | 167 +++
module/srfi/srfi-64/test-runner.exports.sld | 54 +
module/srfi/srfi-64/test-runner.sld | 11 +
module/srfi/srfi-64/testing.scm | 1044 -----------------
test-suite/tests/srfi-64-test.scm | 4 +
17 files changed, 1113 insertions(+), 1102 deletions(-)
delete mode 100644 module/srfi/srfi-64.scm
create mode 100644 module/srfi/srfi-64.sld
create mode 100644 module/srfi/srfi-64/execution.body.scm
create mode 100644 module/srfi/srfi-64/execution.exports.sld
create mode 100644 module/srfi/srfi-64/execution.sld
create mode 100644 module/srfi/srfi-64/source-info.body.scm
create mode 100644 module/srfi/srfi-64/source-info.sld
create mode 100644 module/srfi/srfi-64/test-runner-simple.body.scm
create mode 100644 module/srfi/srfi-64/test-runner-simple.exports.sld
create mode 100644 module/srfi/srfi-64/test-runner-simple.sld
create mode 100644 module/srfi/srfi-64/test-runner.body.scm
create mode 100644 module/srfi/srfi-64/test-runner.exports.sld
create mode 100644 module/srfi/srfi-64/test-runner.sld
delete mode 100644 module/srfi/srfi-64/testing.scm
diff --git a/NEWS b/NEWS
index 1c4dd7b56..1f63a9771 100644
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,7 @@ used at macro-expansion time, such as (srfi srfi-26). In those cases,
the compiler reports it as "possibly unused".
** Add (srfi 48), a string format library
+** New (srfi 64) library implementation
** Add (srfi 126), a hash tables library
** Add (srfi 128), a comparators library
** Add (scheme comparator)
@@ -68,6 +69,33 @@ other operations, given the internal use of those functions.
(<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
+** SRFI 64 `test-error' doesn't match error types
+ (https://bugs.gnu.org/66776)
+
+~test-error~ used to pass as long as *any* error was reported. It now
+properly check the error type or a predicate, and these following test
+examples properly fail:
+
+#+begin_src scheme
+(use-modules (ice-9 exceptions) (srfi srfi-64))
+
+(define-exception-type &my-exception
+ &exception ;parent
+ make-my-exception ;constructor
+ my-exception?) ;predicate
+
+(test-begin "test-error exception types")
+
+(test-error "&my-exception raised, exception type"
+ &my-exception
+ (raise-exception (make-error)))
+
+(test-error "&my-exception raised, predicate"
+ my-exception?
+ (raise-exception (make-error)))
+
+(test-end)
+#+end_src
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 67460b32d..058ea7898 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -58,13 +58,20 @@ COMPILE = $(AM_V_GUILEC) \
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
srfi/srfi-48.go: srfi/srfi-48/48.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
$(COMPILE) -o "$@" "$<"
# Register inter-modules dependencies.
+srfi/srfi-64.go: srfi/srfi-64/test-runner.go \
+ srfi/srfi-64/test-runner-simple.go srfi/srfi-64/execution.go
+srfi/srfi-64/test-runner.go: srfi/srfi-1.go
+srfi/srfi-64/test-runner-simple.go: srfi/srfi-48.go srfi/srfi-64/test-runner.go
+srfi/srfi-64/source-info.go: srfi/srfi-64/test-runner.go
+srfi/srfi-64/execution.go: srfi/srfi-1.go srfi/srfi-35.go srfi/srfi-48.go \
+ srfi/srfi-64/source-info.go srfi/srfi-64/test-runner.go \
+ srfi/srfi-64/test-runner-simple.go
srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go
srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go
scheme/comparator.go: srfi/srfi-128.go
@@ -362,7 +369,11 @@ SOURCES = \
srfi/srfi-45.scm \
srfi/srfi-48.sld \
srfi/srfi-60.scm \
- srfi/srfi-64.scm \
+ srfi/srfi-64.sld \
+ srfi/srfi-64/execution.sld \
+ srfi/srfi-64/source-info.sld \
+ srfi/srfi-64/test-runner-simple.sld \
+ srfi/srfi-64/test-runner.sld \
srfi/srfi-67.scm \
srfi/srfi-69.scm \
srfi/srfi-71.scm \
@@ -478,6 +489,13 @@ NOCOMP_SOURCES = \
scheme/features.scm \
srfi/srfi-42/ec.scm \
srfi/srfi-48/48.upstream.scm \
+ srfi/srfi-64/execution.body.scm \
+ srfi/srfi-64/execution.exports.sld \
+ srfi/srfi-64/source-info.body.scm \
+ srfi/srfi-64/test-runner-simple.body.scm \
+ srfi/srfi-64/test-runner-simple.exports.sld \
+ srfi/srfi-64/test-runner.body.scm \
+ srfi/srfi-64/test-runner.exports.sld \
srfi/srfi-67/compare.scm \
srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
deleted file mode 100644
index 925726f5c..000000000
--- a/module/srfi/srfi-64.scm
+++ /dev/null
@@ -1,56 +0,0 @@
-;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
-
-;; Copyright (C) 2014 Free Software Foundation, Inc.
-;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 3 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-(define-module (srfi srfi-64)
- #:export
- (test-begin
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
- #:declarative? #f) ; #f needed for test-log-to-file
-
-(cond-expand-provide (current-module) '(srfi-64))
-
-(include-from-path "srfi/srfi-64/testing.scm")
diff --git a/module/srfi/srfi-64.sld b/module/srfi/srfi-64.sld
new file mode 100644
index 000000000..116e7d158
--- /dev/null
+++ b/module/srfi/srfi-64.sld
@@ -0,0 +1,63 @@
+;;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;;
+;;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 64)
+ (import
+ (srfi 64 test-runner)
+ (srfi 64 test-runner-simple)
+ (srfi 64 execution))
+ (export
+ ;; Execution
+ test-begin test-end test-group test-group-with-cleanup
+
+ test-skip test-expect-fail
+ test-match-name test-match-nth
+ test-match-all test-match-any
+
+ test-assert test-eqv test-eq test-equal test-approximate
+ test-error test-read-eval-string
+
+ test-apply test-with-runner
+
+ test-exit
+
+ ;; Test runner
+ test-runner-null test-runner? test-runner-reset
+
+ test-result-alist test-result-alist!
+ test-result-ref test-result-set!
+ test-result-remove test-result-clear
+
+ test-runner-pass-count
+ test-runner-fail-count
+ test-runner-xpass-count
+ test-runner-xfail-count
+ test-runner-skip-count
+
+ test-runner-test-name
+
+ test-runner-group-path
+ test-runner-group-stack
+
+ test-runner-aux-value test-runner-aux-value!
+
+ test-result-kind test-passed?
+
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+
+ test-runner-factory test-runner-create
+ test-runner-current test-runner-get
+
+ ;; Simple test runner
+ test-runner-simple
+ test-on-group-begin-simple test-on-group-end-simple test-on-final-simple
+ test-on-test-begin-simple test-on-test-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ ))
diff --git a/module/srfi/srfi-64/execution.body.scm b/module/srfi/srfi-64/execution.body.scm
new file mode 100644
index 000000000..fe44e4202
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,426 @@
+;;; SPDX-License-Identifier: MIT
+
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+\f
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+ (when (not (test-runner-current))
+ (let ((runner (test-runner-simple))
+ (log-file (string-append suite-name ".srfi64.log")))
+ (%test-runner-log-file! runner log-file)
+ (test-runner-current runner))))
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (maybe-install-default-runner name)
+ (let ((r (test-runner-current)))
+ (let ((skip-list (%test-runner-skip-list r))
+ (skip-save (%test-runner-skip-save r))
+ (fail-list (%test-runner-fail-list r))
+ (fail-save (%test-runner-fail-save r))
+ (total-count (%test-runner-total-count r))
+ (count-list (%test-runner-count-list r))
+ (group-stack (test-runner-group-stack r)))
+ ((test-runner-on-group-begin r) r name count)
+ (%test-runner-skip-save! r (cons skip-list skip-save))
+ (%test-runner-fail-save! r (cons fail-list fail-save))
+ (%test-runner-count-list! r (cons (cons total-count count)
+ count-list))
+ (test-runner-group-stack! r (cons name group-stack)))))))
+
+(define test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((name)
+ (let* ((r (test-runner-get))
+ (groups (test-runner-group-stack r)))
+ (test-result-clear r)
+ (when (null? groups)
+ (error "test-end not in a group"))
+ (when (and name (not (equal? name (car groups))))
+ ((test-runner-on-bad-end-name r) r name (car groups)))
+ (let* ((count-list (%test-runner-count-list r))
+ (expected-count (cdar count-list))
+ (saved-count (caar count-list))
+ (group-count (- (%test-runner-total-count r) saved-count)))
+ (when (and expected-count
+ (not (= expected-count group-count)))
+ ((test-runner-on-bad-count r) r group-count expected-count))
+ ((test-runner-on-group-end r) r)
+ (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+ (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+ (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+ (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+ (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+ (%test-runner-count-list! r (cdr count-list))
+ (when (null? (test-runner-group-stack r))
+ ((test-runner-on-final r) r)))))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ <name> <body> . <body>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (maybe-install-default-runner name)
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (lambda () (test-end name)))))))
+
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ ((_ <name> <body> <body>* ... <cleanup>)
+ (test-group <name>
+ (dynamic-wind (lambda () #f)
+ (lambda () <body> <body>* ...)
+ (lambda () <cleanup>))))))
+
+\f
+;;; Skipping, expected-failing, matching
+
+(define (test-skip . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-skip-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-skip-list runner)))))
+
+(define (test-skip? runner)
+ (let ((run-list (%test-runner-run-list runner))
+ (skip-list (%test-runner-skip-list runner)))
+ (or (and run-list (not (any-pred run-list runner)))
+ (any-pred skip-list runner))))
+
+(define (test-expect-fail . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-fail-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-fail-list runner)))))
+
+(define (test-match-any . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (any-pred preds runner))))
+
+(define (test-match-all . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (every-pred preds runner))))
+
+(define (make-pred spec)
+ (cond
+ ((procedure? spec)
+ spec)
+ ((integer? spec)
+ (test-match-nth 1 spec))
+ ((string? spec)
+ (test-match-name spec))
+ (else
+ (error "not a valid test specifier" spec))))
+
+(define test-match-nth
+ (case-lambda
+ ((n) (test-match-nth n 1))
+ ((n count)
+ (let ((i 0))
+ (lambda (runner)
+ (set! i (+ i 1))
+ (and (>= i n) (< i (+ n count))))))))
+
+(define (test-match-name name)
+ (lambda (runner)
+ (equal? name (test-runner-test-name runner))))
+
+;;; Beware: all predicates must be called because they might have side-effects;
+;;; no early returning or and/or short-circuiting of procedure calls allowed.
+
+(define (any-pred preds object)
+ (let loop ((matched? #f)
+ (preds preds))
+ (if (null? preds)
+ matched?
+ (let ((result ((car preds) object)))
+ (loop (or matched? result)
+ (cdr preds))))))
+
+(define (every-pred preds object)
+ (let loop ((failed? #f)
+ (preds preds))
+ (if (null? preds)
+ (not failed?)
+ (let ((result ((car preds) object)))
+ (loop (or failed? (not result))
+ (cdr preds))))))
+\f
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (let ((skip? (test-skip? runner)))
+ (if skip?
+ (test-result-set! runner 'result-kind 'skip)
+ (let ((fail-list (%test-runner-fail-list runner)))
+ (when (any-pred fail-list runner)
+ ;; For later inspection only.
+ (test-result-set! runner 'result-kind 'xfail))))
+ ((test-runner-on-test-begin runner) runner)
+ (not skip?)))
+
+(define (test-postlude runner)
+ (let ((result-kind (test-result-kind runner)))
+ (case result-kind
+ ((pass)
+ (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner))))
+ ((fail)
+ (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner))))
+ ((xpass)
+ (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner))))
+ ((xfail)
+ (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner))))
+ ((skip)
+ (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner)))))
+ (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner)))
+ ((test-runner-on-test-end runner) runner)))
+
+(define (set-result-kind! runner pass?)
+ (test-result-set! runner 'result-kind
+ (if (eq? (test-result-kind runner) 'xfail)
+ (if pass? 'xpass 'xfail)
+ (if pass? 'pass 'fail))))
+
+;;; We need to use some trickery to get the source info right. The important
+;;; thing is to pass a syntax object that is a pair to `source-info', and make
+;;; sure this syntax object comes from user code and not from ourselves.
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-assert/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-assert/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-assert/source-info <source-info> #f <expr>))
+ ((_ <source-info> <name> <expr>)
+ (%test-assert <source-info> <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) runner)))
+ (test-result-set! runner 'actual-value val)
+ (set-result-kind! runner val)))
+ (test-postlude runner)))
+
+(define-syntax test-compare
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-compare/source-info
+ (syntax-rules ()
+ ((_ <source-info> <compare> <expected> <expr>)
+ (test-compare/source-info <source-info> <compare> #f <expected> <expr>))
+ ((_ <source-info> <compare> <name> <expected> <expr>)
+ (%test-compare <source-info> <compare> <name> <expected> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (test-result-set! runner 'actual-value val)
+ (compare expected val))
+ runner)))
+ (set-result-kind! runner pass?)))
+ (test-postlude runner)))
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) equal? . <rest>))))
+
+(define-syntax test-eqv
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) eqv? . <rest>))))
+
+(define-syntax test-eq
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) eq? . <rest>))))
+
+(define (approx= margin)
+ (lambda (value expected)
+ (let ((rval (real-part value))
+ (ival (imag-part value))
+ (rexp (real-part expected))
+ (iexp (imag-part expected)))
+ (and (>= rval (- rexp margin))
+ (>= ival (- iexp margin))
+ (<= rval (+ rexp margin))
+ (<= ival (+ iexp margin))))))
+
+(define-syntax test-approximate
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-approximate/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-approximate/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expected> <expr> <error-margin>)
+ (test-approximate/source-info
+ <source-info> #f <expected> <expr> <error-margin>))
+ ((_ <source-info> <name> <expected> <expr> <error-margin>)
+ (test-compare/source-info
+ <source-info> (approx= <error-margin>) <name> <expected> <expr>))))
+
+(define (error-matches? error type)
+ (cond
+ ((eq? type #t)
+ #t)
+ ((condition-type? type)
+ (and (condition? error) (condition-has-type? error type)))
+ ((procedure? type)
+ (type error))
+ (else
+ (let ((runner (test-runner-get)))
+ ((%test-runner-on-bad-error-type runner) runner type error))
+ #f)))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-error/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-error/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-error/source-info <source-info> #f #t <expr>))
+ ((_ <source-info> <error-type> <expr>)
+ (test-error/source-info <source-info> #f <error-type> <expr>))
+ ((_ <source-info> <name> <error-type> <expr>)
+ (%test-error <source-info> <name> <error-type> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-error error-type)
+ (let ((pass? (guard (error (else (test-result-set!
+ runner 'actual-error error)
+ (error-matches? error error-type)))
+ (let ((val (thunk)))
+ (test-result-set! runner 'actual-value val))
+ #f)))
+ (set-result-kind! runner pass?)))
+ (test-postlude runner)))
+
+(define (default-module)
+ (cond-expand
+ (guile (current-module))
+ (else #f)))
+
+(define test-read-eval-string
+ (case-lambda
+ ((string)
+ (test-read-eval-string string (default-module)))
+ ((string env)
+ (let* ((port (open-input-string string))
+ (form (read port)))
+ (if (eof-object? (read-char port))
+ (eval form env)
+ (error "(not at eof)"))))))
+
+\f
+;;; Test runner control flow
+
+(define-syntax test-with-runner
+ (syntax-rules ()
+ ((_ <runner> <body> . <body>*)
+ (let ((saved-runner (test-runner-current)))
+ (dynamic-wind
+ (lambda () (test-runner-current <runner>))
+ (lambda () <body> . <body>*)
+ (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+ (let ((runner (if (test-runner? first)
+ first
+ (or (test-runner-current) (test-runner-create))))
+ (run-list (if (test-runner? first)
+ (drop-right rest 1)
+ (cons first (drop-right rest 1))))
+ (proc (last rest)))
+ (test-with-runner runner
+ (let ((saved-run-list (%test-runner-run-list runner)))
+ (%test-runner-run-list! runner run-list)
+ (proc)
+ (%test-runner-run-list! runner saved-run-list)))))
+
+\f
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+ (let ((runner (test-runner-current)))
+ (if (and (zero? (test-runner-xpass-count runner))
+ (zero? (test-runner-fail-count runner)))
+ (exit 0)
+ (exit 1))))
+
+;;; execution.scm ends here
diff --git a/module/srfi/srfi-64/execution.exports.sld b/module/srfi/srfi-64/execution.exports.sld
new file mode 100644
index 000000000..c5f5ef84e
--- /dev/null
+++ b/module/srfi/srfi-64/execution.exports.sld
@@ -0,0 +1,18 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(export
+ test-begin test-end test-group test-group-with-cleanup
+
+ test-skip test-expect-fail
+ test-match-name test-match-nth
+ test-match-all test-match-any
+
+ test-assert test-eqv test-eq test-equal test-approximate
+ test-error test-read-eval-string
+
+ test-apply test-with-runner
+
+ test-exit
+ )
diff --git a/module/srfi/srfi-64/execution.sld b/module/srfi/srfi-64/execution.sld
new file mode 100644
index 000000000..dd9fcc5fb
--- /dev/null
+++ b/module/srfi/srfi-64/execution.sld
@@ -0,0 +1,23 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 64 execution)
+ (import
+ (scheme base)
+ (scheme case-lambda)
+ (scheme complex)
+ (scheme eval)
+ (scheme process-context)
+ (scheme read)
+ (srfi 1)
+ (srfi 35)
+ (srfi 48)
+ (srfi 64 source-info)
+ (srfi 64 test-runner)
+ (srfi 64 test-runner-simple))
+ (cond-expand
+ (guile
+ (import (only (guile) current-module))))
+ (include-library-declarations "execution.exports.sld")
+ (include "execution.body.scm"))
diff --git a/module/srfi/srfi-64/source-info.body.scm b/module/srfi/srfi-64/source-info.body.scm
new file mode 100644
index 000000000..22795630f
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,90 @@
+;;; SPDX-License-Identifier: MIT
+
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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.
+
+;;; In some systems, a macro use like (source-info ...), that resides in a
+;;; syntax-rules macro body, first gets inserted into the place where the
+;;; syntax-rules macro was used, and then the transformer of 'source-info' is
+;;; called with a syntax object that has the source location information of that
+;;; position. That works fine when the user calls e.g. (test-assert ...), whose
+;;; body contains (source-info ...); the user gets the source location of the
+;;; (test-assert ...) call as intended, and not the source location of the real
+;;; (source-info ...) call.
+
+;;; In other systems, *first* the (source-info ...) is processed to get its real
+;;; position, which is within the body of a syntax-rules macro like test-assert,
+;;; so no matter where the user calls (test-assert ...), they get source
+;;; location information of where we defined test-assert with the call to
+;;; (source-info ...) in its body. That's arguably more correct behavior,
+;;; although in this case it makes our job a bit harder; we need to get the
+;;; source location from an argument to 'source-info' instead.
+
+(define (canonical-syntax form arg)
+ (cond-expand
+ (kawa arg)
+ (guile-2 form)
+ (else #f)))
+
+(cond-expand
+ ((or kawa guile-2)
+ (define-syntax source-info
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <x>)
+ (let* ((stx (canonical-syntax stx (syntax <x>)))
+ (file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line)))))))))
+ (else
+ (define-syntax source-info
+ (syntax-rules ()
+ ((_ <x>)
+ #f)))))
+
+(define (syntax-source-file stx)
+ (cond-expand
+ (kawa
+ (syntax-source stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'filename))))
+ (else
+ #f)))
+
+(define (syntax-source-line stx)
+ (cond-expand
+ (kawa
+ (syntax-line stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'line))))
+ (else
+ #f)))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; source-info.body.scm ends here
diff --git a/module/srfi/srfi-64/source-info.sld b/module/srfi/srfi-64/source-info.sld
new file mode 100644
index 000000000..d12bbc6df
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.sld
@@ -0,0 +1,14 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 64 source-info)
+ (import
+ (rnrs syntax-case (6))
+ (scheme base)
+ (srfi 64 test-runner))
+ (cond-expand
+ (guile
+ (import (only (guile) assq-ref syntax-source))))
+ (export source-info set-source-info!)
+ (include "source-info.body.scm"))
diff --git a/module/srfi/srfi-64/test-runner-simple.body.scm b/module/srfi/srfi-64/test-runner-simple.body.scm
new file mode 100644
index 000000000..f077e78ed
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,170 @@
+;;; SPDX-License-Identifier: MIT
+
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Helpers
+
+(define (string-join strings delimiter)
+ (if (null? strings)
+ ""
+ (let loop ((result (car strings))
+ (rest (cdr strings)))
+ (if (null? rest)
+ result
+ (loop (string-append result delimiter (car rest))
+ (cdr rest))))))
+
+(define (truncate-string string length)
+ (define (newline->space c) (if (char=? #\newline c) #\space c))
+ (let* ((string (string-map newline->space string))
+ (fill "...")
+ (fill-len (string-length fill))
+ (string-len (string-length string)))
+ (if (<= string-len (+ length fill-len))
+ string
+ (let-values (((q r) (floor/ length 4)))
+ ;; Left part gets 3/4 plus the remainder.
+ (let ((left-end (+ (* q 3) r))
+ (right-start (- string-len q)))
+ (string-append (substring string 0 left-end)
+ fill
+ (substring string right-start string-len)))))))
+
+(define (print runner format-string . args)
+ (apply format #t format-string args)
+ (let ((port (%test-runner-log-port runner)))
+ (when port
+ (apply format port format-string args))))
+
+;;; Main
+
+(define (test-runner-simple)
+ (let ((runner (test-runner-null)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-on-group-begin-simple)
+ (test-runner-on-group-end! runner test-on-group-end-simple)
+ (test-runner-on-final! runner test-on-final-simple)
+ (test-runner-on-test-begin! runner test-on-test-begin-simple)
+ (test-runner-on-test-end! runner test-on-test-end-simple)
+ (test-runner-on-bad-count! runner test-on-bad-count-simple)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ (%test-runner-on-bad-error-type! runner on-bad-error-type)
+ runner))
+
+(when (not (test-runner-factory))
+ (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+ (when (null? (test-runner-group-stack runner))
+ (maybe-start-logging runner)
+ (print runner "Test suite begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+ (let ((name (car (test-runner-group-stack runner))))
+ (when (= 1 (length (test-runner-group-stack runner)))
+ (print runner "Test suite end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (print runner "Passes: ~a\n" (test-runner-pass-count runner))
+ (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (print runner "Failures: ~a\n" (test-runner-fail-count runner))
+ (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner))
+ (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ ;; The possible race-condition here doesn't bother us.
+ (when (file-exists? log-file)
+ (delete-file log-file))
+ (%test-runner-log-port! runner (open-output-file log-file))
+ (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ (print runner "Wrote log file: ~a~%" log-file)
+ (close-output-port (%test-runner-log-port runner)))))
+
+(define (test-on-test-begin-simple runner)
+ (values))
+
+(define (test-on-test-end-simple runner)
+ (let* ((result-kind (test-result-kind runner))
+ (result-kind-name (case result-kind
+ ((pass) "PASS") ((fail) "FAIL")
+ ((xpass) "XPASS") ((xfail) "XFAIL")
+ ((skip) "SKIP")))
+ (name (let ((name (test-runner-test-name runner)))
+ (if (string=? "" name)
+ (truncate-string
+ (format #f "~a" (test-result-ref runner 'source-form))
+ 30)
+ name)))
+ (label (string-join (append (test-runner-group-path runner)
+ (list name))
+ ": ")))
+ (print runner "[~a] ~a~%" result-kind-name label)
+ (when (memq result-kind '(fail xpass))
+ (let ((nil (cons #f #f)))
+ (define (found? value)
+ (not (eq? nil value)))
+ (define (maybe-print value message)
+ (when (found? value)
+ (print runner message value)))
+ (let ((file (test-result-ref runner 'source-file "(unknown file)"))
+ (line (test-result-ref runner 'source-line "(unknown line)"))
+ (expression (test-result-ref runner 'source-form))
+ (expected-value (test-result-ref runner 'expected-value nil))
+ (actual-value (test-result-ref runner 'actual-value nil))
+ (expected-error (test-result-ref runner 'expected-error nil))
+ (actual-error (test-result-ref runner 'actual-error nil)))
+ (print runner "~a:~a: ~s~%" file line expression)
+ (maybe-print expected-value "Expected value: ~s~%")
+ (maybe-print expected-error "Expected error: ~a~%")
+ (when (or (found? expected-value) (found? expected-error))
+ (maybe-print actual-value "Returned value: ~s~%"))
+ (maybe-print actual-error "Raised error: ~a~%")
+ (newline))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (print runner
+ "*** Discrepancy indicates testsuite error or exceptions. ***~%"))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"."
+ end-name begin-name)))
+
+(define (on-bad-error-type runner type error)
+ (print runner "WARNING: unknown error type predicate: ~a~%" type)
+ (print runner " error was: ~a~%" error))
+
+;;; test-runner-simple.scm ends here
diff --git a/module/srfi/srfi-64/test-runner-simple.exports.sld b/module/srfi/srfi-64/test-runner-simple.exports.sld
new file mode 100644
index 000000000..fc2ecf99b
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.exports.sld
@@ -0,0 +1,12 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(export
+ test-runner-simple
+ ;; The following are exported so you can leverage their existing functionality
+ ;; when making more complex test runners.
+ test-on-group-begin-simple test-on-group-end-simple test-on-final-simple
+ test-on-test-begin-simple test-on-test-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ )
diff --git a/module/srfi/srfi-64/test-runner-simple.sld b/module/srfi/srfi-64/test-runner-simple.sld
new file mode 100644
index 000000000..ccd7a6745
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.sld
@@ -0,0 +1,13 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 64 test-runner-simple)
+ (import
+ (scheme base)
+ (scheme file)
+ (scheme write)
+ (srfi 48)
+ (srfi 64 test-runner))
+ (include-library-declarations "test-runner-simple.exports.sld")
+ (include "test-runner-simple.body.scm"))
diff --git a/module/srfi/srfi-64/test-runner.body.scm b/module/srfi/srfi-64/test-runner.body.scm
new file mode 100644
index 000000000..0491ccc53
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,167 @@
+;;; SPDX-License-Identifier: MIT
+
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+\f
+;;; The data type
+
+(define-record-type <test-runner>
+ (make-test-runner) test-runner?
+
+ (result-alist test-result-alist test-result-alist!)
+
+ (pass-count test-runner-pass-count test-runner-pass-count!)
+ (fail-count test-runner-fail-count test-runner-fail-count!)
+ (xpass-count test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count test-runner-skip-count test-runner-skip-count!)
+ (total-count %test-runner-total-count %test-runner-total-count!)
+
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list %test-runner-count-list %test-runner-count-list!)
+
+ ;; Normally #f, except when in a test-apply.
+ (run-list %test-runner-run-list %test-runner-run-list!)
+
+ (skip-list %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list %test-runner-fail-list %test-runner-fail-list!)
+
+ (skip-save %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save %test-runner-fail-save %test-runner-fail-save!)
+
+ (group-stack test-runner-group-stack test-runner-group-stack!)
+
+ ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and
+ ;; test-end forms in the execution library. They're called at the
+ ;; beginning/end of each individual test, whereas the test-begin and test-end
+ ;; forms demarcate test groups.
+
+ (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+ (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end test-runner-on-test-end test-runner-on-test-end!)
+ (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+ (on-final test-runner-on-final test-runner-on-final!)
+ (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!)
+ (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+
+ (on-bad-error-type %test-runner-on-bad-error-type
+ %test-runner-on-bad-error-type!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!)
+
+ (log-file %test-runner-log-file %test-runner-log-file!)
+ (log-port %test-runner-log-port %test-runner-log-port!))
+
+(define (test-runner-group-path runner)
+ (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-reset runner)
+ (test-result-alist! runner '())
+ (test-runner-pass-count! runner 0)
+ (test-runner-fail-count! runner 0)
+ (test-runner-xpass-count! runner 0)
+ (test-runner-xfail-count! runner 0)
+ (test-runner-skip-count! runner 0)
+ (%test-runner-total-count! runner 0)
+ (%test-runner-count-list! runner '())
+ (%test-runner-run-list! runner #f)
+ (%test-runner-skip-list! runner '())
+ (%test-runner-fail-list! runner '())
+ (%test-runner-skip-save! runner '())
+ (%test-runner-fail-save! runner '())
+ (test-runner-group-stack! runner '()))
+
+(define (test-runner-null)
+ (define (test-null-callback . args) #f)
+ (let ((runner (make-test-runner)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-null-callback)
+ (test-runner-on-group-end! runner test-null-callback)
+ (test-runner-on-final! runner test-null-callback)
+ (test-runner-on-test-begin! runner test-null-callback)
+ (test-runner-on-test-end! runner test-null-callback)
+ (test-runner-on-bad-count! runner test-null-callback)
+ (test-runner-on-bad-end-name! runner test-null-callback)
+ (%test-runner-on-bad-error-type! runner test-null-callback)
+ (%test-runner-log-file! runner #f)
+ (%test-runner-log-port! runner #f)
+ runner))
+
+\f
+;;; State
+
+(define test-result-ref
+ (case-lambda
+ ((runner key)
+ (test-result-ref runner key #f))
+ ((runner key default)
+ (let ((entry (assq key (test-result-alist runner))))
+ (if entry (cdr entry) default)))))
+
+(define (test-result-set! runner key value)
+ (let* ((alist (test-result-alist runner))
+ (entry (assq key alist)))
+ (if entry
+ (set-cdr! entry value)
+ (test-result-alist! runner (cons (cons key value) alist)))))
+
+(define (test-result-remove runner key)
+ (test-result-alist! runner (remove (lambda (entry)
+ (eq? key (car entry)))
+ (test-result-alist runner))))
+
+(define (test-result-clear runner)
+ (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+ (or (test-result-ref runner 'name) ""))
+
+(define test-result-kind
+ (case-lambda
+ (() (test-result-kind (test-runner-get)))
+ ((runner) (test-result-ref runner 'result-kind))))
+
+(define test-passed?
+ (case-lambda
+ (() (test-passed? (test-runner-get)))
+ ((runner) (memq (test-result-kind runner) '(pass xpass)))))
+
+\f
+;;; Factory and current instance
+
+(define test-runner-factory (make-parameter #f))
+
+(define (test-runner-create) ((test-runner-factory)))
+
+(define test-runner-current (make-parameter #f))
+
+(define (test-runner-get)
+ (or (test-runner-current)
+ (error "test-runner not initialized - test-begin missing?")))
+
+;;; test-runner.scm ends here
diff --git a/module/srfi/srfi-64/test-runner.exports.sld b/module/srfi/srfi-64/test-runner.exports.sld
new file mode 100644
index 000000000..aebd804ad
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.exports.sld
@@ -0,0 +1,54 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(export
+ ;; The data type
+ test-runner-null test-runner? test-runner-reset
+
+ test-result-alist test-result-alist!
+
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ %test-runner-total-count %test-runner-total-count!
+
+ %test-runner-count-list %test-runner-count-list!
+
+ %test-runner-run-list %test-runner-run-list!
+
+ %test-runner-skip-list %test-runner-skip-list!
+ %test-runner-fail-list %test-runner-fail-list!
+
+ %test-runner-skip-save %test-runner-skip-save!
+ %test-runner-fail-save %test-runner-fail-save!
+
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-group-path
+
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+
+ %test-runner-on-bad-error-type %test-runner-on-bad-error-type!
+
+ test-runner-aux-value test-runner-aux-value!
+
+ %test-runner-log-file %test-runner-log-file!
+ %test-runner-log-port %test-runner-log-port!
+
+ ;; State
+ test-result-ref test-result-set!
+ test-result-remove test-result-clear
+ test-runner-test-name test-result-kind test-passed?
+
+ ;; Factory and current instance
+ test-runner-factory test-runner-create
+ test-runner-current test-runner-get
+ )
diff --git a/module/srfi/srfi-64/test-runner.sld b/module/srfi/srfi-64/test-runner.sld
new file mode 100644
index 000000000..b55373c5a
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.sld
@@ -0,0 +1,11 @@
+;;; SPDX-FileCopyrightText: 2015 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 64 test-runner)
+ (import
+ (scheme base)
+ (scheme case-lambda)
+ (srfi 1))
+ (include-library-declarations "test-runner.exports.sld")
+ (include "test-runner.body.scm"))
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
deleted file mode 100644
index cdaab140f..000000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1044 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;; Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
-;;
-;; 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.
-
-(cond-expand
- (chicken
- (require-extension syntax-case))
- (guile-2
- (use-modules (srfi srfi-9)
- ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
- ;; with either Guile's native exceptions or R6RS exceptions.
- ;;(srfi srfi-34) (srfi srfi-35)
- (srfi srfi-39)))
- (guile
- (use-modules (ice-9 syncase) (srfi srfi-9)
- ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
- (srfi srfi-39)))
- (sisc
- (require-extension (srfi 9 34 35 39)))
- (kawa
- (module-compile-options warn-undefined-variable: #t
- warn-invoke-unknown-method: #t)
- (provide 'srfi-64)
- (provide 'testing)
- (require 'srfi-34)
- (require 'srfi-35))
- (else ()
- ))
-
-(cond-expand
- (kawa
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export test-begin . other-names)
- (module-export %test-begin . other-names)))))
- (else
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index setter getter) ...)
- (define-record-type test-runner
- (alloc)
- runner?
- (name setter getter) ...)))))
- (else
- (define %test-runner-cookie (list "test-runner"))
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index getter setter) ...)
- (begin
- (define (runner? obj)
- (and (vector? obj)
- (> (vector-length obj) 1)
- (eq (vector-ref obj 0) %test-runner-cookie)))
- (define (alloc)
- (let ((runner (make-vector 23)))
- (vector-set! runner 0 %test-runner-cookie)
- runner))
- (begin
- (define (getter runner)
- (vector-ref runner index)) ...)
- (begin
- (define (setter runner value)
- (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
- (test-result-alist! runner '())
- (test-runner-pass-count! runner 0)
- (test-runner-fail-count! runner 0)
- (test-runner-xpass-count! runner 0)
- (test-runner-xfail-count! runner 0)
- (test-runner-skip-count! runner 0)
- (%test-runner-total-count! runner 0)
- (%test-runner-count-list! runner '())
- (%test-runner-run-list! runner #t)
- (%test-runner-skip-list! runner '())
- (%test-runner-fail-list! runner '())
- (%test-runner-skip-save! runner '())
- (%test-runner-fail-save! runner '())
- (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
- (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner (lambda (runner name count) #f))
- (test-runner-on-group-end! runner %test-null-callback)
- (test-runner-on-final! runner %test-null-callback)
- (test-runner-on-test-begin! runner %test-null-callback)
- (test-runner-on-test-end! runner %test-null-callback)
- (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
- (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
- runner))
-
-;; Not part of the specification. FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner test-on-group-begin-simple)
- (test-runner-on-group-end! runner test-on-group-end-simple)
- (test-runner-on-final! runner test-on-final-simple)
- (test-runner-on-test-begin! runner test-on-test-begin-simple)
- (test-runner-on-test-end! runner test-on-test-end-simple)
- (test-runner-on-bad-count! runner test-on-bad-count-simple)
- (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
- runner))
-
-(cond-expand
- (srfi-39
- (define test-runner-current (make-parameter #f))
- (define test-runner-factory (make-parameter test-runner-simple)))
- (else
- (define %test-runner-current #f)
- (define-syntax test-runner-current
- (syntax-rules ()
- ((test-runner-current)
- %test-runner-current)
- ((test-runner-current runner)
- (set! %test-runner-current runner))))
- (define %test-runner-factory test-runner-simple)
- (define-syntax test-runner-factory
- (syntax-rules ()
- ((test-runner-factory)
- %test-runner-factory)
- ((test-runner-factory runner)
- (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
- (let ((r (test-runner-current)))
- (if (not r)
- (cond-expand
- (srfi-23 (error "test-runner not initialized - test-begin missing?"))
- (else #t)))
- r))
-
-(define (%test-specifier-matches spec runner)
- (spec runner))
-
-(define (test-runner-create)
- ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
- (let ((result #f))
- (let loop ((l list))
- (cond ((null? l) result)
- (else
- (if (%test-specifier-matches (car l) runner)
- (set! result #t))
- (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
- (let ((run (%test-runner-run-list runner)))
- (cond ((or
- (not (or (eqv? run #t)
- (%test-any-specifier-matches run runner)))
- (%test-any-specifier-matches
- (%test-runner-skip-list runner)
- runner))
- (test-result-set! runner 'result-kind 'skip)
- #f)
- ((%test-any-specifier-matches
- (%test-runner-fail-list runner)
- runner)
- (test-result-set! runner 'result-kind 'xfail)
- 'xfail)
- (else #t))))
-
-(define (%test-begin suite-name count)
- (if (not (test-runner-current))
- (let ((r (test-runner-create)))
- (test-runner-current r)
- (test-runner-on-final! r
- (let ((old-final (test-runner-on-final r)))
- (lambda (r) (old-final r) (test-runner-current #f))))))
- (let ((runner (test-runner-current)))
- ((test-runner-on-group-begin runner) runner suite-name count)
- (%test-runner-skip-save! runner
- (cons (%test-runner-skip-list runner)
- (%test-runner-skip-save runner)))
- (%test-runner-fail-save! runner
- (cons (%test-runner-fail-list runner)
- (%test-runner-fail-save runner)))
- (%test-runner-count-list! runner
- (cons (cons (%test-runner-total-count runner)
- count)
- (%test-runner-count-list runner)))
- (test-runner-group-stack! runner (cons suite-name
- (test-runner-group-stack runner)))))
-(cond-expand
- (kawa
- ;; Kawa has test-begin built in, implemented as:
- ;; (begin
- ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
- ;; (%test-begin suite-name [count]))
- ;; This puts test-begin but only test-begin in the default environment.,
- ;; which makes normal test suites loadable without non-portable commands.
- )
- (else
- (define-syntax test-begin
- (syntax-rules ()
- ((test-begin suite-name)
- (%test-begin suite-name #f))
- ((test-begin suite-name count)
- (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
- (if (null? (test-runner-group-stack runner))
- (begin
- (display "%%%% Starting test ")
- (display suite-name)
- (if test-log-to-file
- (let* ((log-file-name
- (if (string? test-log-to-file) test-log-to-file
- (string-append suite-name ".log")))
- (log-file
- (cond-expand (mzscheme
- (open-output-file log-file-name 'truncate/replace))
- (else (open-output-file log-file-name)))))
- (display "%%%% Starting test " log-file)
- (display suite-name log-file)
- (newline log-file)
- (test-runner-aux-value! runner log-file)
- (display " (Writing full log to \"")
- (display log-file-name)
- (display "\")")))
- (newline)))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group begin: " log)
- (display suite-name log)
- (newline log))))
- #f)
-
-(define (test-on-group-end-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group end: " log)
- (display (car (test-runner-group-stack runner)) log)
- (newline log))))
- #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
- (display "*** Total number of tests was " port)
- (display count port)
- (display " but should be " port)
- (display expected-count port)
- (display ". ***" port)
- (newline port)
- (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
- (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
- (%test-on-bad-count-write runner count expected-count (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
- (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
- " does not match test-begin " end-name)))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
-
-
-(define (%test-final-report1 value label port)
- (if (> value 0)
- (begin
- (display label port)
- (display value port)
- (newline port))))
-
-(define (%test-final-report-simple runner port)
- (%test-final-report1 (test-runner-pass-count runner)
- "# of expected passes " port)
- (%test-final-report1 (test-runner-xfail-count runner)
- "# of expected failures " port)
- (%test-final-report1 (test-runner-xpass-count runner)
- "# of unexpected successes " port)
- (%test-final-report1 (test-runner-fail-count runner)
- "# of unexpected failures " port)
- (%test-final-report1 (test-runner-skip-count runner)
- "# of skipped tests " port))
-
-(define (test-on-final-simple runner)
- (%test-final-report-simple runner (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
- (let* ((line-info (test-result-alist runner))
- (source-file (assq 'source-file line-info))
- (source-line (assq 'source-line line-info))
- (file (if source-file (cdr source-file) "")))
- (if source-line
- (string-append file ":"
- (number->string (cdr source-line)) ": ")
- "")))
-
-(define (%test-end suite-name line-info)
- (let* ((r (test-runner-get))
- (groups (test-runner-group-stack r))
- (line (%test-format-line r)))
- (test-result-alist! r line-info)
- (if (null? groups)
- (let ((msg (string-append line "test-end not in a group")))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
- (if (and suite-name (not (equal? suite-name (car groups))))
- ((test-runner-on-bad-end-name r) r suite-name (car groups)))
- (let* ((count-list (%test-runner-count-list r))
- (expected-count (cdar count-list))
- (saved-count (caar count-list))
- (group-count (- (%test-runner-total-count r) saved-count)))
- (if (and expected-count
- (not (= expected-count group-count)))
- ((test-runner-on-bad-count r) r group-count expected-count))
- ((test-runner-on-group-end r) r)
- (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
- (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
- (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
- (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
- (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
- (%test-runner-count-list! r (cdr count-list))
- (if (null? (test-runner-group-stack r))
- ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
- (syntax-rules ()
- ((test-group suite-name . body)
- (let ((r (test-runner-current)))
- ;; Ideally should also set line-number, if available.
- (test-result-alist! r (list (cons 'test-name suite-name)))
- (if (%test-should-execute r)
- (dynamic-wind
- (lambda () (test-begin suite-name))
- (lambda () . body)
- (lambda () (test-end suite-name))))))))
-
-(define-syntax test-group-with-cleanup
- (syntax-rules ()
- ((test-group-with-cleanup suite-name form cleanup-form)
- (test-group suite-name
- (dynamic-wind
- (lambda () #f)
- (lambda () form)
- (lambda () cleanup-form))))
- ((test-group-with-cleanup suite-name cleanup-form)
- (test-group-with-cleanup suite-name #f cleanup-form))
- ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
- (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (source-form (assq 'source-form results))
- (test-name (assq 'test-name results)))
- (display "Test begin:" log)
- (newline log)
- (if test-name (%test-write-result1 test-name log))
- (if source-file (%test-write-result1 source-file log))
- (if source-line (%test-write-result1 source-line log))
- (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
- (syntax-rules ()
- ((test-result-ref runner pname)
- (test-result-ref runner pname #f))
- ((test-result-ref runner pname default)
- (let ((p (assq pname (test-result-alist runner))))
- (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
- (let ((log (test-runner-aux-value runner))
- (kind (test-result-ref runner 'result-kind)))
- (if (memq kind '(fail xpass))
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (test-name (assq 'test-name results)))
- (if (or source-file source-line)
- (begin
- (if source-file (display (cdr source-file)))
- (display ":")
- (if source-line (display (cdr source-line)))
- (display ": ")))
- (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
- (if test-name
- (begin
- (display " ")
- (display (cdr test-name))))
- (newline)))
- (if (output-port? log)
- (begin
- (display "Test end:" log)
- (newline log)
- (let loop ((list (test-result-alist runner)))
- (if (pair? list)
- (let ((pair (car list)))
- ;; Write out properties not written out by on-test-begin.
- (if (not (memq (car pair)
- '(test-name source-file source-line source-form)))
- (%test-write-result1 pair log))
- (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
- (display " " port)
- (display (car pair) port)
- (display ": " port)
- (write (cdr pair) port)
- (newline port))
-
-(define (test-result-set! runner pname value)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (set-cdr! p value)
- (test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
- (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (test-result-alist! runner
- (let loop ((r alist))
- (if (eq? r p) (cdr r)
- (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
- (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
- (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
- (let* ((r (test-runner-get))
- (result-kind (test-result-kind r)))
- (case result-kind
- ((pass)
- (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
- ((fail)
- (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
- ((xpass)
- (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
- ((xfail)
- (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
- (else
- (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
- (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
- ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (catch #t
- (lambda () test-expression)
- (lambda (key . args)
- (test-result-set! (test-runner-current) 'actual-error
- (cons key args))
- #f))))))
- (kawa
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (try-catch test-expression
- (ex <java.lang.Throwable>
- (test-result-set! (test-runner-current) 'actual-error ex)
- #f))))))
- (srfi-34
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (guard (err (else #f)) test-expression)))))
- (chicken
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (condition-case test-expression (ex () #f))))))
- (else
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- test-expression)))))
-
-(cond-expand
- ((or kawa mzscheme)
- (cond-expand
- (mzscheme
- (define-for-syntax (%test-syntax-file form)
- (let ((source (syntax-source form)))
- (cond ((string? source) file)
- ((path? source) (path->string source))
- (else #f)))))
- (kawa
- (define (%test-syntax-file form)
- (syntax-source form))))
- (define (%test-source-line2 form)
- (let* ((line (syntax-line form))
- (file (%test-syntax-file form))
- (line-pair (if line (list (cons 'source-line line)) '())))
- (cons (cons 'source-form (syntax-object->datum form))
- (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
- (define (%test-source-line2 form)
- (let* ((src-props (syntax-source form))
- (file (and src-props (assq-ref src-props 'filename)))
- (line (and src-props (assq-ref src-props 'line)))
- (file-alist (if file
- `((source-file . ,file))
- '()))
- (line-alist (if line
- `((source-line . ,(+ line 1)))
- '())))
- (datum->syntax (syntax here)
- `((source-form . ,(syntax->datum form))
- ,@file-alist
- ,@line-alist)))))
- (else
- (define (%test-source-line2 form)
- '())))
-
-(define (%test-on-test-begin r)
- (%test-should-execute r)
- ((test-runner-on-test-begin r) r)
- (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
- (test-result-set! r 'result-kind
- (if (eq? (test-result-ref r 'result-kind) 'xfail)
- (if result 'xpass 'xfail)
- (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
- (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
- (syntax-rules ()
- ((%test-comp2body r comp expected expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ((exp expected))
- (test-result-set! r 'expected-value exp)
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r (comp exp res)))))
- (%test-report-result)))))
-
-(define (%test-approximate= error)
- (lambda (value expected)
- (let ((rval (real-part value))
- (ival (imag-part value))
- (rexp (real-part expected))
- (iexp (imag-part expected)))
- (and (>= rval (- rexp error))
- (>= ival (- iexp error))
- (<= rval (+ rexp error))
- (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
- (syntax-rules ()
- ((%test-comp1body r expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ()
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r res))))
- (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
- ;; Should be made to work for any Scheme with syntax-case
- ;; However, I haven't gotten the quoting working. FIXME.
- (define-syntax test-end
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac suite-name) line)
- (syntax
- (%test-end suite-name line)))
- (((mac) line)
- (syntax
- (%test-end #f line))))))
- (define-syntax test-assert
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp1body r expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp1body r expr)))))))
- (define (%test-comp2 comp x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
- (((mac tname expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r comp expected expr))))
- (((mac expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r comp expected expr))))))
- (define-syntax test-eqv
- (lambda (x) (%test-comp2 (syntax eqv?) x)))
- (define-syntax test-eq
- (lambda (x) (%test-comp2 (syntax eq?) x)))
- (define-syntax test-equal
- (lambda (x) (%test-comp2 (syntax equal?) x)))
- (define-syntax test-approximate ;; FIXME - needed for non-Kawa
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expected expr error) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r (%test-approximate= error) expected expr))))
- (((mac expected expr error) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
- (define-syntax test-end
- (syntax-rules ()
- ((test-end)
- (%test-end #f '()))
- ((test-end suite-name)
- (%test-end suite-name '()))))
- (define-syntax test-assert
- (syntax-rules ()
- ((test-assert tname test-expression)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r '((test-name . tname)))
- (%test-comp1body r test-expression)))
- ((test-assert test-expression)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp1body r test-expression)))))
- (define-syntax %test-comp2
- (syntax-rules ()
- ((%test-comp2 comp tname expected expr)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (list (cons 'test-name tname)))
- (%test-comp2body r comp expected expr)))
- ((%test-comp2 comp expected expr)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp2body r comp expected expr)))))
- (define-syntax test-equal
- (syntax-rules ()
- ((test-equal . rest)
- (%test-comp2 equal? . rest))))
- (define-syntax test-eqv
- (syntax-rules ()
- ((test-eqv . rest)
- (%test-comp2 eqv? . rest))))
- (define-syntax test-eq
- (syntax-rules ()
- ((test-eq . rest)
- (%test-comp2 eq? . rest))))
- (define-syntax test-approximate
- (syntax-rules ()
- ((test-approximate tname expected expr error)
- (%test-comp2 (%test-approximate= error) tname expected expr))
- ((test-approximate expected expr error)
- (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (cond ((%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (catch #t
- (lambda ()
- (test-result-set! r 'actual-value expr)
- #f)
- (lambda (key . args)
- ;; TODO: decide how to specify expected
- ;; error types for Guile.
- (test-result-set! r 'actual-error
- (cons key args))
- #t)))
- (%test-report-result))))))))
- (mzscheme
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)))))))
- (chicken
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r #t expr)
- (cond ((%test-on-test-begin r)
- (test-result-set! r 'expected-error #t)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- #t)))
- (%test-report-result))))
- ((%test-error r etype expr)
- (if (%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- (cond ((and (instance? et <gnu.bytecode.ClassType>)
- (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
- (instance? ex et))
- (else #t)))))
- (%test-report-result)))))))
- ((and srfi-34 srfi-35)
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex ((condition-type? etype)
- (and (condition? ex) (condition-has-type? ex etype)))
- ((procedure? etype)
- (etype ex))
- ((equal? etype #t)
- #t)
- (else #t))
- expr #f))))))
- (srfi-34
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (begin
- ((test-runner-on-test-begin r) r)
- (test-result-set! r 'result-kind 'skip)
- (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
- (define-syntax test-error
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname etype expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-error r etype expr))))
- (((mac etype expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r etype expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r #t expr))))))))
- (else
- (define-syntax test-error
- (syntax-rules ()
- ((test-error name etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r `((test-name . ,name)))
- (%test-error r etype expr)))
- ((test-error etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r etype expr)))
- ((test-error expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
- (if (test-runner? first)
- (test-with-runner first (apply test-apply rest))
- (let ((r (test-runner-current)))
- (if r
- (let ((run-list (%test-runner-run-list r)))
- (cond ((null? rest)
- (%test-runner-run-list! r (reverse run-list))
- (first)) ;; actually apply procedure thunk
- (else
- (%test-runner-run-list!
- r
- (if (eq? run-list #t) (list first) (cons first run-list)))
- (apply test-apply rest)
- (%test-runner-run-list! r run-list))))
- (let ((r (test-runner-create)))
- (test-with-runner r (apply test-apply first rest))
- ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
- (syntax-rules ()
- ((test-with-runner runner form ...)
- (let ((saved-runner (test-runner-current)))
- (dynamic-wind
- (lambda () (test-runner-current runner))
- (lambda () form ...)
- (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
- (let ((i 0))
- (lambda (runner)
- (set! i (+ i 1))
- (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
- (syntax-rules ()
- ((test-match-nth n)
- (test-match-nth n 1))
- ((test-match-nth n count)
- (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
- (lambda (runner)
- (let ((result #t))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if (not ((car l) runner))
- (set! result #f))
- (loop (cdr l))))))))
-
-(define-syntax test-match-all
- (syntax-rules ()
- ((test-match-all pred ...)
- (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
- (lambda (runner)
- (let ((result #f))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if ((car l) runner)
- (set! result #t))
- (loop (cdr l))))))))
-
-(define-syntax test-match-any
- (syntax-rules ()
- ((test-match-any pred ...)
- (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
- (cond ((procedure? specifier) specifier)
- ((integer? specifier) (test-match-nth 1 specifier))
- ((string? specifier) (test-match-name specifier))
- (else
- (error "not a valid test specifier"))))
-
-(define-syntax test-skip
- (syntax-rules ()
- ((test-skip pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-skip-list! runner
- (cons (test-match-all (%test-as-specifier pred) ...)
- (%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
- (syntax-rules ()
- ((test-expect-fail pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-fail-list! runner
- (cons (test-match-all (%test-as-specifier pred) ...)
- (%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
- (lambda (runner)
- (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
- (let* ((port (open-input-string string))
- (form (read port)))
- (if (eof-object? (read-char port))
- (cond-expand
- (guile (eval form (current-module)))
- (else (eval form)))
- (cond-expand
- (srfi-23 (error "(not at eof)"))
- (else "error")))))
-
diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..654fe6be0 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -1,3 +1,7 @@
+;;; SPDX-FileCopyrightText: 2005 - 2006 Per Bothner
+;;;
+;;; SPDX-License-Identifier: MIT
+
;;;
;;; This is a test suite written in the notation of
;;; SRFI-64, A Scheme API for test suites
--
2.41.0
^ permalink raw reply related [flat|nested] 19+ messages in thread