New Upstream Release - chibi-scheme
Ready changes
Summary
Merged new upstream version: 0.10 (was: 0.9.1).
Resulting package
Built on 2023-02-25T17:28 (took 10m25s)
The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:
apt install -t fresh-releases chibi-scheme-commonapt install -t fresh-releases chibi-scheme-dbgsymapt install -t fresh-releases chibi-scheme-docapt install -t fresh-releases chibi-scheme-imagesapt install -t fresh-releases chibi-schemeapt install -t fresh-releases libchibi-scheme-devapt install -t fresh-releases libchibi-scheme-ffi-dbgsymapt install -t fresh-releases libchibi-scheme-ffiapt install -t fresh-releases libchibi-scheme0-dbgsymapt install -t fresh-releases libchibi-scheme0
Diff
diff --git a/Makefile b/Makefile
index 04336e11..81460195 100644
--- a/Makefile
+++ b/Makefile
@@ -46,7 +46,7 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
-MODULE_DOCS := app ast base64 bytevector config crypto/md5 crypto/rsa \
+MODULE_DOCS := app assert ast base64 bytevector config crypto/md5 crypto/rsa \
crypto/sha2 diff disasm doc edit-distance equiv filesystem generic \
heap-stats io iset/base iset/constructors iset/iterators json loop \
match math/prime memoize mime modules net net/http-server net/servlet \
@@ -80,7 +80,7 @@ js/chibi.js: chibi-scheme-emscripten chibi-scheme-static.bc js/pre.js js/post.js
emcc -O0 chibi-scheme-static.bc -o $@ -s ALLOW_MEMORY_GROWTH=1 -s MODULARIZE=1 -s EXPORT_NAME=\"Chibi\" -s EXPORTED_FUNCTIONS=@js/exported_functions.json `find lib -type f \( -name "*.scm" -or -name "*.sld" \) -printf " --preload-file %p"` -s 'EXTRA_EXPORTED_RUNTIME_METHODS=["ccall", "cwrap"]' --pre-js js/pre.js --post-js js/post.js
chibi-scheme-static.bc:
- emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc
+ emmake $(MAKE) PLATFORM=emscripten CHIBI_DEPENDENCIES= CHIBI=./chibi-scheme-emscripten PREFIX= CFLAGS=-O2 SEXP_USE_DL=0 EXE=.bc SO=.bc STATICFLAGS=-shared CPPFLAGS="-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1 -DSEXP_USE_ALIGNED_BYTECODE=1 -DSEXP_USE_STATIC_LIBS=1 -DSEXP_USE_STATIC_LIBS_NO_INCLUDE=0" clibs.c chibi-scheme-static.bc VERBOSE=1
chibi-scheme-emscripten: VERSION
$(MAKE) distclean
@@ -304,7 +304,7 @@ install-base: all
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
- $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146
+ $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(MODDIR)/srfi/113 $(DESTDIR)$(MODDIR)/srfi/117 $(DESTDIR)$(MODDIR)/srfi/121 $(DESTDIR)$(MODDIR)/srfi/125 $(DESTDIR)$(MODDIR)/srfi/128 $(DESTDIR)$(MODDIR)/srfi/129 $(DESTDIR)$(MODDIR)/srfi/132 $(DESTDIR)$(MODDIR)/srfi/133 $(DESTDIR)$(MODDIR)/srfi/135 $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(MODDIR)/srfi/179
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
@@ -355,6 +355,8 @@ install-base: all
$(INSTALL) -m0644 lib/srfi/166/*.scm $(DESTDIR)$(MODDIR)/srfi/166/
$(INSTALL) -m0644 lib/srfi/146/*.sld $(DESTDIR)$(MODDIR)/srfi/146/
$(INSTALL) -m0644 lib/srfi/146/*.scm $(DESTDIR)$(MODDIR)/srfi/146/
+ $(INSTALL) -m0644 lib/srfi/179/*.sld $(DESTDIR)$(MODDIR)/srfi/179/
+ $(INSTALL) -m0644 lib/srfi/179/*.scm $(DESTDIR)$(MODDIR)/srfi/179/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
@@ -461,8 +463,11 @@ uninstall:
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/143 $(DESTDIR)$(BINMODDIR)/srfi/143
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/151 $(DESTDIR)$(BINMODDIR)/srfi/151
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144
+ -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/146 $(DESTDIR)$(BINMODDIR)/srfi/146
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/159 $(DESTDIR)$(BINMODDIR)/srfi/159
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/160 $(DESTDIR)$(BINMODDIR)/srfi/160
+ -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/166 $(DESTDIR)$(BINMODDIR)/srfi/166
+ -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/179 $(DESTDIR)$(BINMODDIR)/srfi/179
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
@@ -494,9 +499,11 @@ snowballs:
$(SNOW_CHIBI) package --license public-domain lib/chibi/match.sld
$(SNOW_CHIBI) package -r lib/chibi/char-set.sld
$(SNOW_CHIBI) package -r lib/chibi/iset.sld lib/chibi/iset/optimize.sld
- $(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-166/srfi-166.html lib/srfi/166.sld lib/chibi/show/shared.sld
- $(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html lib/srfi/115.sld
+ $(SNOW_CHIBI) package --doc https://srfi.schemers.org/srfi-115/srfi-115.html --test-library lib/srfi/115.sld
+ $(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-166/srfi-166.html --test-library lib/srfi/166/test.sld lib/srfi/166.sld lib/chibi/show/shared.sld
+ $(SNOW_CHIBI) package -r --doc https://srfi.schemers.org/srfi-179/srfi-179.html --test-library lib/srfi/179/test.sld lib/srfi/179.sld
$(SNOW_CHIBI) package lib/chibi/app.sld
+ $(SNOW_CHIBI) package lib/chibi/assert.sld
$(SNOW_CHIBI) package lib/chibi/base64.sld
$(SNOW_CHIBI) package lib/chibi/binary-record.sld
$(SNOW_CHIBI) package lib/chibi/bytevector.sld
diff --git a/README.md b/README.md
index 5d9dbef2..af30efc5 100644
--- a/README.md
+++ b/README.md
@@ -52,5 +52,7 @@ By default files are installed in **/usr/local**.
If you want to try out chibi-scheme without installing, be sure to set
`LD_LIBRARY_PATH` so it can find the shared libraries.
+To make the emscripten build run `make js`.
+
For more detailed documentation, run `make doc` and see the generated
*doc/chibi.html*.
diff --git a/RELEASE b/RELEASE
index b485b841..2edf8646 100644
--- a/RELEASE
+++ b/RELEASE
@@ -1 +1 @@
-fluoride
+neon
diff --git a/VERSION b/VERSION
index f374f666..78bc1abd 100644
--- a/VERSION
+++ b/VERSION
@@ -1 +1 @@
-0.9.1
+0.10.0
diff --git a/debian/changelog b/debian/changelog
index 6c108e47..ebb42dbe 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+chibi-scheme (0.10-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Sat, 25 Feb 2023 17:18:39 -0000
+
chibi-scheme (0.9.1-3) unstable; urgency=medium
* Adjust debian/rules to upstream Makefile API change
diff --git a/debian/patches/0005-fix-pkg-config-for-static.patch b/debian/patches/0005-fix-pkg-config-for-static.patch
index 6db9c9d2..40f5d678 100644
--- a/debian/patches/0005-fix-pkg-config-for-static.patch
+++ b/debian/patches/0005-fix-pkg-config-for-static.patch
@@ -10,10 +10,10 @@ for gcc, but we do not need libdl to be linked when using static linkage.
chibi-scheme.pc.in | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
-diff --git a/chibi-scheme.pc.in b/chibi-scheme.pc.in
-index 82dcd9e..dc81dc0 100644
---- a/chibi-scheme.pc.in
-+++ b/chibi-scheme.pc.in
+Index: chibi-scheme.git/chibi-scheme.pc.in
+===================================================================
+--- chibi-scheme.git.orig/chibi-scheme.pc.in
++++ chibi-scheme.git/chibi-scheme.pc.in
@@ -3,5 +3,5 @@ URL: http://synthcode.com/scheme/chibi/
Description: Minimal Scheme Implementation for use as an Extension Language
Version: ${version}
diff --git a/debian/patches/0008-fix-snow-chibi-cache-location.patch b/debian/patches/0008-fix-snow-chibi-cache-location.patch
index e06bdbc3..0faed427 100644
--- a/debian/patches/0008-fix-snow-chibi-cache-location.patch
+++ b/debian/patches/0008-fix-snow-chibi-cache-location.patch
@@ -11,10 +11,10 @@ This is not acceptable and we should use a different directory.
lib/chibi/snow/commands.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
-diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm
-index 28877ea..317a677 100644
---- a/lib/chibi/snow/commands.scm
-+++ b/lib/chibi/snow/commands.scm
+Index: chibi-scheme.git/lib/chibi/snow/commands.scm
+===================================================================
+--- chibi-scheme.git.orig/lib/chibi/snow/commands.scm
++++ chibi-scheme.git/lib/chibi/snow/commands.scm
@@ -1136,7 +1136,7 @@
(cond
((zero? (current-user-id))
diff --git a/debian/patches/0010-hide-extra-symbols.patch b/debian/patches/0010-hide-extra-symbols.patch
index cd2a3061..8df1f034 100644
--- a/debian/patches/0010-hide-extra-symbols.patch
+++ b/debian/patches/0010-hide-extra-symbols.patch
@@ -20,10 +20,10 @@ All public symbols are prefixed with "sexp_*".
include/chibi/sexp-hufftabs.h | 3 +++
2 files changed, 6 insertions(+)
-diff --git a/include/chibi/sexp-hufftabs.c b/include/chibi/sexp-hufftabs.c
-index 7704184..2da963e 100644
---- a/include/chibi/sexp-hufftabs.c
-+++ b/include/chibi/sexp-hufftabs.c
+Index: chibi-scheme.git/include/chibi/sexp-hufftabs.c
+===================================================================
+--- chibi-scheme.git.orig/include/chibi/sexp-hufftabs.c
++++ chibi-scheme.git/include/chibi/sexp-hufftabs.c
@@ -1,5 +1,7 @@
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
@@ -37,10 +37,10 @@ index 7704184..2da963e 100644
};
+#pragma GCC visibility pop
-diff --git a/include/chibi/sexp-hufftabs.h b/include/chibi/sexp-hufftabs.h
-index 7704184..2da963e 100644
---- a/include/chibi/sexp-hufftabs.h
-+++ b/include/chibi/sexp-hufftabs.h
+Index: chibi-scheme.git/include/chibi/sexp-hufftabs.h
+===================================================================
+--- chibi-scheme.git.orig/include/chibi/sexp-hufftabs.h
++++ chibi-scheme.git/include/chibi/sexp-hufftabs.h
@@ -1,5 +1,7 @@
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
diff --git a/debian/patches/0013-remove-chibi-ffi-debug-chatter.patch b/debian/patches/0013-remove-chibi-ffi-debug-chatter.patch
index 1fc95a1d..79fd50a0 100644
--- a/debian/patches/0013-remove-chibi-ffi-debug-chatter.patch
+++ b/debian/patches/0013-remove-chibi-ffi-debug-chatter.patch
@@ -12,11 +12,11 @@ packages with snow-chibi that have some native extensions.
tools/chibi-ffi | 3 ---
1 file changed, 3 deletions(-)
-diff --git a/tools/chibi-ffi b/tools/chibi-ffi
-index d8cd34a..c65da5a 100755
---- a/tools/chibi-ffi
-+++ b/tools/chibi-ffi
-@@ -2366,7 +2366,4 @@
+Index: chibi-scheme.git/tools/chibi-ffi
+===================================================================
+--- chibi-scheme.git.orig/tools/chibi-ffi
++++ chibi-scheme.git/tools/chibi-ffi
+@@ -2424,7 +2424,4 @@
(macosx (append '("-dynamiclib" "-Oz") ',base-args))
(else (append '("-fPIC" "-shared" "-Os") ',base-args)))))
(cc (or cc (if *c++?* "c++" "cc"))))
diff --git a/debian/patches/0014-silence-warnings-when-no-config.patch b/debian/patches/0014-silence-warnings-when-no-config.patch
index e9a1f856..b85872c9 100644
--- a/debian/patches/0014-silence-warnings-when-no-config.patch
+++ b/debian/patches/0014-silence-warnings-when-no-config.patch
@@ -24,10 +24,10 @@ being let's just revert this change.
lib/chibi/config.sld | 16 ++--------------
2 files changed, 3 insertions(+), 20 deletions(-)
-diff --git a/lib/chibi/config.scm b/lib/chibi/config.scm
-index e58bb5e..0afafcf 100644
---- a/lib/chibi/config.scm
-+++ b/lib/chibi/config.scm
+Index: chibi-scheme.git/lib/chibi/config.scm
+===================================================================
+--- chibi-scheme.git.orig/lib/chibi/config.scm
++++ chibi-scheme.git/lib/chibi/config.scm
@@ -111,12 +111,7 @@
(else (lp (cdr ls) (cons (car ls) rev))))))
@@ -42,10 +42,10 @@ index e58bb5e..0afafcf 100644
(call-with-input-file file read)))
(define (alist? x)
-diff --git a/lib/chibi/config.sld b/lib/chibi/config.sld
-index d6dcab1..810f300 100644
---- a/lib/chibi/config.sld
-+++ b/lib/chibi/config.sld
+Index: chibi-scheme.git/lib/chibi/config.sld
+===================================================================
+--- chibi-scheme.git.orig/lib/chibi/config.sld
++++ chibi-scheme.git/lib/chibi/config.sld
@@ -10,18 +10,6 @@
;; This is only used for config verification, it's acceptable to
;; substitute file existence for the stronger directory check.
diff --git a/debian/patches/0015-spelling.patch b/debian/patches/0015-spelling.patch
index 9a97a5af..ba20d911 100644
--- a/debian/patches/0015-spelling.patch
+++ b/debian/patches/0015-spelling.patch
@@ -6,10 +6,10 @@ Subject: spelling
lib/srfi/166/write.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
-diff --git a/lib/srfi/166/write.scm b/lib/srfi/166/write.scm
-index 7c58eae..2edb867 100644
---- a/lib/srfi/166/write.scm
-+++ b/lib/srfi/166/write.scm
+Index: chibi-scheme.git/lib/srfi/166/write.scm
+===================================================================
+--- chibi-scheme.git.orig/lib/srfi/166/write.scm
++++ chibi-scheme.git/lib/srfi/166/write.scm
@@ -477,7 +477,7 @@
(else
(displayed (write-to-string obj))))))))))
diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1
index fd75017d..3ec3689b 100644
--- a/doc/chibi-scheme.1
+++ b/doc/chibi-scheme.1
@@ -225,6 +225,10 @@ Loads the Scheme heap from
.I image-file
instead of compiling the init file on the fly.
This feature is still experimental.
+.TP
+.BI -b
+Makes stdio nonblocking (blocking by default). Only available when
+lightweight threads are enabled.
.SH ENVIRONMENT
.TP
diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl
index 0bbb957f..5f6eef71 100755
--- a/doc/chibi.scrbl
+++ b/doc/chibi.scrbl
@@ -230,7 +230,7 @@ module \scheme{(foo bar baz)} is searched for in the file
installed directories, \scheme{"."} and \scheme{"./lib"}. Additional
directories can be specified with the command-line options \ccode{-I}
and \ccode{-A} (see the command-line options below) or with the
-\scheme{add-modue-directory} procedure at runtime. You can search for
+\scheme{add-module-directory} procedure at runtime. You can search for
a module file with \scheme{(find-module-file <file>)}, or load it with
\scheme{(load-module-file <file> <env>)}.
@@ -1283,6 +1283,7 @@ snow-fort):
\item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}}
\item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}}
\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}}
+\item{\hyperlink["http://srfi.schemers.org/srfi-179/srfi-179.html"]{(srfi 179) - nonempty intervals and generalized arrays}}
\item{\hyperlink["http://srfi.schemers.org/srfi-188/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}}
]
@@ -1296,6 +1297,8 @@ namespace.
\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}}
+\item{\hyperlink["lib/chibi/assert.html"]{(chibi assert) - A nicer assert macro}}
+
\item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}}
\item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}}
diff --git a/eval.c b/eval.c
index 1d44ea22..d3ca1af0 100644
--- a/eval.c
+++ b/eval.c
@@ -221,7 +221,7 @@ sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
e = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_parent(e) = env;
sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
sexp_env_renames(e) = SEXP_NULL;
#endif
for ( ; sexp_pairp(vars); vars = sexp_cdr(vars))
@@ -241,7 +241,7 @@ sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e;
sexp_env_bindings(e2) = sexp_env_bindings(e1);
sexp_env_syntactic_p(e2) = 1;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
sexp_env_renames(e2) = sexp_env_renames(e1);
#endif
}
@@ -361,6 +361,17 @@ sexp sexp_complete_bytecode (sexp ctx) {
#if SEXP_USE_FULL_SOURCE_INFO
if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) {
sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc));
+ /* omit the leading -1 source marker for the bytecode if the next */
+ /* entry is in the same file */
+ if (sexp_pairp(sexp_cdr(sexp_bytecode_source(bc))) &&
+ sexp_pairp(sexp_car(sexp_bytecode_source(bc))) &&
+ sexp_pairp(sexp_cdar(sexp_bytecode_source(bc))) &&
+ sexp_pairp(sexp_cadr(sexp_bytecode_source(bc))) &&
+ sexp_pairp(sexp_cdr(sexp_cadr(sexp_bytecode_source(bc)))) &&
+ sexp_cadr(sexp_car(sexp_bytecode_source(bc)))
+ == sexp_cadr(sexp_cadr(sexp_bytecode_source(bc)))) {
+ sexp_bytecode_source(bc) = sexp_cdr(sexp_bytecode_source(bc));
+ }
sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc));
}
#endif
@@ -496,12 +507,12 @@ void sexp_init_eval_context_globals (sexp ctx) {
sexp_init_eval_context_bytecodes(ctx);
#endif
sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
- no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
- if (!no_sys_path || strcmp(no_sys_path, "0")==0)
- sexp_add_path(ctx, sexp_default_module_path);
user_path = getenv(SEXP_MODULE_PATH_VAR);
if (!user_path) user_path = sexp_default_user_module_path;
sexp_add_path(ctx, user_path);
+ no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
+ if (!no_sys_path || strcmp(no_sys_path, "0")==0)
+ sexp_add_path(ctx, sexp_default_module_path);
#if SEXP_USE_GREEN_THREADS
sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)
= sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL);
@@ -1011,7 +1022,7 @@ static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) {
sexp_env_syntactic_p(env) = 1;
sexp_env_parent(env) = sexp_context_env(ctx);
sexp_env_bindings(env) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
sexp_env_renames(env) = SEXP_NULL;
#endif
ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
@@ -2198,7 +2209,7 @@ sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
sexp_env_lambda(e) = NULL;
sexp_env_parent(e) = NULL;
sexp_env_bindings(e) = SEXP_NULL;
-#if SEXP_USE_RENAME_BINDINGS
+#if SEXP_USE_STABLE_ABI || SEXP_USE_RENAME_BINDINGS
sexp_env_renames(e) = SEXP_NULL;
#endif
return e;
diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h
index 54792ace..dc40ccab 100644
--- a/include/chibi/bignum.h
+++ b/include/chibi/bignum.h
@@ -8,7 +8,11 @@
#include "chibi/eval.h"
#if SEXP_USE_CUSTOM_LONG_LONGS
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
#include <stdint.h>
+#endif
typedef struct
{
uint64_t hi;
diff --git a/include/chibi/features.h b/include/chibi/features.h
index 644c416e..a4c22954 100644
--- a/include/chibi/features.h
+++ b/include/chibi/features.h
@@ -1,5 +1,5 @@
/* features.h -- general feature configuration */
-/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
+/* Copyright (c) 2009-2021 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
/* uncomment this to disable most features */
@@ -64,6 +64,15 @@
/* if you suspect a bug in the native GC. */
/* #define SEXP_USE_BOEHM 1 */
+/* uncomment this to enable automatic file descriptor unification */
+/* File descriptors as returned by C functions are raw integers, */
+/* which are convereted to GC'ed first-class objects on the Scheme */
+/* side. By default we assume that each fd is new, however if this */
+/* option is enabled and an fd is returned which matches an existing */
+/* open fd, they are assumed to refer to the same descriptor and */
+/* unified. */
+/* #define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 1 */
+
/* uncomment this to disable weak references */
/* #define SEXP_USE_WEAK_REFERENCES 0 */
@@ -173,6 +182,18 @@
/* Automatically disabled if you've disabled flonums. */
/* #define SEXP_USE_MATH 0 */
+/* uncomment this to enable lenient matching of top-level bindings */
+/* Historically, to match behavior with some other Schemes and in */
+/* hopes of making it easier to use macros and modules, Chibi allowed */
+/* top-level bindings with the same underlying symbol name to match */
+/* with identifier=?. In particular, there still isn't a good way */
+/* to handle the case where auxiliary syntax conflicts with some other */
+/* binding without renaming one or the other (though SRFI 206 helps). */
+/* However, if people make use of this you can write Chibi programs */
+/* which don't work portably in other implementations, which has been */
+/* a source of confusion, so the default has reverted to strict R7RS. */
+/* #define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0 */
+
/* uncomment this to disable warning about references to undefined variables */
/* This is something of a hack, but can be quite useful. */
/* It's very fast and doesn't involve any separate analysis */
@@ -308,7 +329,7 @@
/************************************************************************/
#ifndef SEXP_64_BIT
-#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__)
+#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) || defined(__mips64__) || defined(__sparc64__) || defined(__arm64)
#define SEXP_64_BIT 1
#else
#define SEXP_64_BIT 0
@@ -452,9 +473,17 @@
#define SEXP_USE_BOEHM 0
#endif
+#ifdef SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_UNIFY_FILENOS_BY_NUMBER 0
+#endif
+
#ifndef SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
+#define SEXP_USE_WEAK_REFERENCES 1
+#else
#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES
#endif
+#endif
#ifndef SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
#define SEXP_USE_FIXED_CHUNK_SIZE_HEAPS 0
@@ -553,7 +582,7 @@
#endif
#ifndef SEXP_USE_STRICT_TOPLEVEL_BINDINGS
-#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0
+#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 1
#endif
#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index e34d9cbf..dbead7c8 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -231,9 +231,15 @@ typedef int sexp_sint_t;
#define sexp_heap_align(n) sexp_align(n, 5)
#define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
#elif SEXP_64_BIT
+#if PLAN9
+typedef uintptr sexp_tag_t;
+typedef uintptr sexp_uint_t;
+typedef intptr sexp_sint_t;
+#else
typedef unsigned int sexp_tag_t;
typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t;
+#endif
#define SEXP_PRIdFIXNUM "ld"
#define sexp_heap_align(n) sexp_align(n, 5)
#define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
@@ -244,6 +250,13 @@ typedef int sexp_sint_t;
#define SEXP_PRIdFIXNUM "d"
#define sexp_heap_align(n) sexp_align(n, 5)
#define sexp_heap_chunks(n) (sexp_heap_align(n)>>5)
+#elif PLAN9
+typedef uintptr sexp_tag_t;
+typedef unsigned int sexp_uint_t;
+typedef int sexp_sint_t;
+#define SEXP_PRIdFIXNUM "d"
+#define sexp_heap_align(n) sexp_align(n, 4)
+#define sexp_heap_chunks(n) (sexp_heap_align(n)>>4)
#else
typedef unsigned short sexp_tag_t;
typedef unsigned int sexp_uint_t;
@@ -260,7 +273,11 @@ typedef int sexp_sint_t;
#ifdef SEXP_USE_INTTYPES
+#ifdef PLAN9
+#include <ape/stdint.h>
+#else
#include <stdint.h>
+#endif
# ifdef UINT8_MAX
# define SEXP_UINT8_DEFINED 1
typedef uint8_t sexp_uint8_t;
@@ -276,9 +293,13 @@ typedef int32_t sexp_int32_t;
# else
# include <limits.h>
# if SEXP_USE_UNIFORM_VECTOR_LITERALS
+# ifdef PLAN9
+# include <ape/stdint.h>
+# else
# include <stdint.h>
# endif
# endif
+# endif
# if UCHAR_MAX == 255
# define SEXP_UINT8_DEFINED 1
typedef unsigned char sexp_uint8_t;
@@ -484,7 +505,7 @@ struct sexp_struct {
sexp_sint_t fd, count;
} fileno;
struct {
- sexp kind, message, irritants, procedure, source;
+ sexp kind, message, irritants, procedure, source, stack_trace;
} exception;
struct {
signed char sign;
@@ -1223,6 +1244,7 @@ enum sexp_uniform_vector_type {
#define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
#define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
#define sexp_exception_source(x) (sexp_field(x, exception, SEXP_EXCEPTION, source))
+#define sexp_exception_stack_trace(x) (sexp_field(x, exception, SEXP_EXCEPTION, stack_trace))
#define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
#define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
@@ -1728,12 +1750,14 @@ SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n);
SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port);
SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x);
+SEXP_API sexp sexp_user_exception_ls (sexp ctx, sexp self, const char *msg, int n, ...);
SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x);
SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
+SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
@@ -1868,6 +1892,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
#define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in)
#define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out)
#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out)
+#define sexp_print_exception_stack_trace(ctx, e, out) sexp_print_exception_stack_trace_op(ctx, NULL, 2, e, out)
#define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out)
#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
#define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
diff --git a/lib/chibi/assert-test.sld b/lib/chibi/assert-test.sld
new file mode 100644
index 00000000..b98ec2ac
--- /dev/null
+++ b/lib/chibi/assert-test.sld
@@ -0,0 +1,30 @@
+
+(define-library (chibi assert-test)
+ (import (chibi) (chibi assert) (chibi test))
+ (export run-tests)
+ (begin
+ (define-syntax test-assert
+ (syntax-rules ()
+ ((test-assert irritants expr)
+ (protect (exn
+ (else
+ (test irritants (exception-irritants exn))))
+ expr
+ (error "assertion not triggered")))))
+ (define (run-tests)
+ (test-begin "assert")
+ (test-assert '((= x (+ x 1))
+ (x 3))
+ (let ((x 3)) (assert (= x (+ x 1)))))
+ (test-assert '((= x (+ y 1))
+ (x 3)
+ (y 42))
+ (let ((x 3) (y 42)) (assert (= x (+ y 1)))))
+ (test-assert '((eq? x 'three)
+ (x 3))
+ (let ((x 3)) (assert (eq? x 'three))))
+ (test-assert '((eq? x 'three)
+ "expected three: "
+ 3)
+ (let ((x 3)) (assert (eq? x 'three) "expected three: " x)))
+ (test-end))))
diff --git a/lib/chibi/assert.sld b/lib/chibi/assert.sld
new file mode 100644
index 00000000..d5a3b27d
--- /dev/null
+++ b/lib/chibi/assert.sld
@@ -0,0 +1,115 @@
+
+;;> A nice assert macro.
+;;>
+;;> Assert macros are common in Scheme, in particular being helpful
+;;> for domain checks at the beginning of a procedure to catch errors
+;;> as early as possible. Compared to statically typed languages this
+;;> has the advantages that the assertions are optional, and that they
+;;> are not limited by the type system. SRFI 145 provides the related
+;;> notion of assumptions, but the motivation there is to provide
+;;> hints to optimizing compilers, and these are not required to
+;;> actually signal an error.
+;;>
+;;> \macro{(assert expr [msg ...])}
+;;>
+;;> Equivalent to SRFI 145 \code{assume} except that an error is
+;;> guaranteed to be raised if \var{expr} is false. Conceptually
+;;> shorthand for
+;;>
+;;> \code{(or \var{expr}
+;;> (error "assertion failed" \var{msg} ...))}
+;;>
+;;> that is, evaluates \var{expr} and returns it if true, but raises
+;;> an exception otherwise. The error is augmented to include the
+;;> text of the failed \var{expr}. If no additional \var{msg}
+;;> arguments are provided then \var{expr} is scanned for free
+;;> variables in non-operator positions to report values from, e.g. in
+;;>
+;;> \code{(let ((x 3))
+;;> (assert (= x (+ x 1))))}
+;;>
+;;> the error would also report the bound value of \code{x}. This
+;;> uses the technique from Oleg Kiselyov's \hyperlink[http://okmij.org/ftp/Scheme/assert-syntax-rule.txt]{good assert macro},
+;;> which is convenient but fallible. It is thus best to keep the
+;;> body of the assertion simple, moving any predicates you need to
+;;> external utilities, or provide an explicit \var{msg}.
+
+(define-library (chibi assert)
+ (export assert)
+ (cond-expand
+ (chibi
+ (import (chibi))
+ (begin
+ (define-syntax syntax-identifier?
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (if (identifier? (cadr expr))
+ (car (cddr expr))
+ (cadr (cddr expr))))))
+ (define-syntax syntax-id-memq?
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (let ((expr (cdr expr)))
+ (if (any (lambda (x) (compare x (car expr))) (cadr expr))
+ (car (cddr expr))
+ (cadr (cddr expr)))))))))
+ (else
+ (import (scheme base))
+ (begin
+ ;; from match.scm
+ (define-syntax syntax-identifier?
+ (syntax-rules ()
+ ((_ (x . y) success-k failure-k) failure-k)
+ ((_ #(x ...) success-k failure-k) failure-k)
+ ((_ x success-k failure-k)
+ (let-syntax
+ ((sym?
+ (syntax-rules ()
+ ((sym? x sk fk) sk)
+ ((sym? y sk fk) fk))))
+ (sym? abracadabra success-k failure-k)))))
+ (define-syntax syntax-id-memq?
+ (syntax-rules ()
+ ((syntax-memq? id (ids ...) sk fk)
+ (let-syntax
+ ((memq?
+ (syntax-rules (ids ...)
+ ((memq? id sk2 fk2) fk2)
+ ((memq? any-other sk2 fk2) sk2))))
+ (memq? random-symbol-to-match sk fk))))))))
+ (begin
+ (define-syntax extract-vars
+ (syntax-rules ()
+ ((report-vars (op arg0 arg1 ...) (next ...) res)
+ (syntax-id-memq? op (quote quasiquote lambda let let* letrec letrec*
+ let-syntax letrec-syntax let-values let*-values
+ receive match case define define-syntax do)
+ (next ... res)
+ (extract-vars arg0
+ (extract-vars (op arg1 ...) (next ...))
+ res)))
+ ((report-vars (op . x) (next ...) res)
+ (next ... res))
+ ((report-vars x (next ...) (res ...))
+ (syntax-identifier? x
+ (syntax-id-memq? x (res ...)
+ (next ... (res ...))
+ (next ... (res ... x)))
+ (next ... (res ...))))))
+ (define-syntax qq-vars
+ (syntax-rules ()
+ ((qq-vars (next ...) (var ...))
+ (next ... `(var ,var) ...))))
+ (define-syntax report-final
+ (syntax-rules ()
+ ((report-final expr msg ...)
+ (error "assertion failed" 'expr msg ...))))
+ (define-syntax assert
+ (syntax-rules ()
+ ((assert test)
+ (or test
+ (extract-vars test (qq-vars (report-final test)) ())))
+ ((assert test msg ...)
+ (or test
+ (report-final test msg ...)))
+ ((assert) #t)))))
diff --git a/lib/chibi/binary-types.scm b/lib/chibi/binary-types.scm
index 908a7c96..69a55e41 100644
--- a/lib/chibi/binary-types.scm
+++ b/lib/chibi/binary-types.scm
@@ -91,7 +91,7 @@
(define-syntax name
(syntax-rules ()
((name . x)
- (syntax-error "invalid use of auxilliary syntax" (name . x))))))))
+ (syntax-error "invalid use of auxiliary syntax" (name . x))))))))
(define-auxiliary-syntax make:)
(define-auxiliary-syntax pred:)
diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm
index a47efb86..ec80c3bf 100644
--- a/lib/chibi/doc.scm
+++ b/lib/chibi/doc.scm
@@ -693,8 +693,6 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
(('begin body0 ... body) (get-value-signature mod id proc name body))
(else (get-procedure-signature mod id proc))))
-;; TODO: analyze and match on AST instead of making assumptions about
-;; bindings
(define (get-signature mod id proc source form)
(match form
(('define (name args ...) . body)
@@ -708,7 +706,11 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
(map (lambda (x) (cons name (cdr x)))
(filter external-clause? clause)))
(else
- (get-procedure-signature mod id proc))))
+ (cond
+ ((procedure-analysis proc mod)
+ => (lambda (lam) (list (cons (lambda-name lam) (lambda-params lam)))))
+ (else
+ (get-procedure-signature mod id proc))))))
(define (get-ffi-signatures form)
(match form
@@ -721,6 +723,8 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
args)))))
(('define-c-const type (or (name _) name))
(list (list 'const: type name)))
+ (('cond-expand (test . clauses) . rest)
+ (append-map get-ffi-signatures clauses))
(((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
(let lp ((ls rest) (res '()))
(cond
@@ -807,38 +811,39 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
(write-to-string sig)))
(define (insert-signature orig-ls name sig)
- (cond
- ((not (pair? sig))
- orig-ls)
- (else
- (let ((name
- (cond
- (name)
- ((not (pair? (car sig))) (car sig))
- ((eq? 'const: (caar sig)) (cadr (cdar sig)))
- (else (caar sig)))))
- (let lp ((ls orig-ls) (rev-pre '()))
- (cond
- ((or (null? ls)
- (section>=? (car ls) (section-number 'subsubsection)))
- `(,@(reverse rev-pre)
- ,@(if (and (pair? ls)
- (section-describes?
- (extract-sxml
- '(subsubsection procedure macro)
- (car ls))
- name))
- '()
- `((subsubsection
- tag: ,(write-to-string name)
- (rawcode
- ,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
- `((i ,(write-to-string (car (cdar sig))) ": ")
- ,(write-to-string (cadr (cdar sig))))
- (intersperse (map write-signature sig) '(br)))))))
- ,@ls))
- (else
- (lp (cdr ls) (cons (car ls) rev-pre)))))))))
+ (let ((sig (if (pair? sig) sig (and name (list name)))))
+ (cond
+ ((not (pair? sig))
+ '())
+ (else
+ (let ((name
+ (cond
+ (name)
+ ((not (pair? (car sig))) (car sig))
+ ((eq? 'const: (caar sig)) (cadr (cdar sig)))
+ (else (caar sig)))))
+ (let lp ((ls orig-ls) (rev-pre '()))
+ (cond
+ ((or (null? ls)
+ (section>=? (car ls) (section-number 'subsubsection)))
+ `(,@(reverse rev-pre)
+ ,@(if (and (pair? ls)
+ (section-describes?
+ (extract-sxml
+ '(subsubsection procedure macro)
+ (car ls))
+ name))
+ '()
+ `((subsubsection
+ tag: ,(write-to-string name)
+ (rawcode
+ ,@(if (and (pair? (car sig)) (eq? 'const: (caar sig)))
+ `((i ,(write-to-string (car (cdar sig))) ": ")
+ ,(write-to-string (cadr (cdar sig))))
+ (intersperse (map write-signature sig) '(br)))))))
+ ,@ls))
+ (else
+ (lp (cdr ls) (cons (car ls) rev-pre))))))))))
;;> Extract inline Scribble documentation (with the ;;> prefix) from
;;> the source file \var{file}, associating any signatures from the
@@ -846,17 +851,22 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
(define (extract-file-docs mod file all-defs strict? . o)
;; extract (<file> . <line>) macro source or
- ;; (<offset> <file . <line>>) procedure source
+ ;; (<offset> <file . <line>) procedure source or
+ ;; ((<offset> <file . <line>) ...) bytecode sources
(define (source-line source)
(and (pair? source)
- (if (string? (car source))
- (and (equal? file (car source))
- (number? (cdr source))
- (cdr source))
- (and (number? (car source))
- (pair? (cdr source))
- (equal? file (cadr source))
- (cddr source)))))
+ (cond
+ ((string? (car source))
+ (and (equal? file (car source))
+ (number? (cdr source))
+ (cdr source)))
+ ((pair? (car source))
+ (source-line (car source)))
+ (else
+ (and (number? (car source))
+ (pair? (cdr source))
+ (equal? file (cadr source))
+ (cddr source))))))
(define (read-to-paren in)
(let lp1 ((res '()))
(let ((ch (peek-char in)))
diff --git a/lib/chibi/log-test.sld b/lib/chibi/log-test.sld
index 9398c3f8..f6b670da 100644
--- a/lib/chibi/log-test.sld
+++ b/lib/chibi/log-test.sld
@@ -16,22 +16,23 @@
(syntax-rules ()
((log->string/no-dates expr ...)
(string-join
- (map (lambda (line) (substring line 20))
+ (map (lambda (line)
+ (if (string-null? line) line (substring line 20)))
(string-split (log->string expr ...) "\n"))
"\n"))))
(define (run-tests)
(test-begin "logging")
- (test "D four: 4"
+ (test "D four: 4\n"
(log->string/no-dates
(log-debug "four: " (+ 2 2))))
- (test "I pi: 3.14"
+ (test "I pi: 3.14\n"
(log->string/no-dates
(log-info "pi: " (with ((precision 2)) (acos -1)))))
(test-assert
(string-prefix? "E "
(log->string/no-dates
(with-logged-errors (/ 1 0)))))
- (test "W warn\nE error"
+ (test "W warn\nE error\n"
(log->string/no-dates
(with-log-level
'warn
diff --git a/lib/chibi/math/prime-test.sld b/lib/chibi/math/prime-test.sld
index d171be56..ba8dc82a 100644
--- a/lib/chibi/math/prime-test.sld
+++ b/lib/chibi/math/prime-test.sld
@@ -32,7 +32,19 @@
(test 1009 (nth-prime 168))
(test 1013 (nth-prime 169))
+ (test 2 (prime-above 1))
+ (test 3 (prime-above 2))
+ (test 5 (prime-above 3))
+ (test 5 (prime-above 4))
+ (test 7 (prime-above 5))
(test 907 (prime-above 888))
+ (test 911 (prime-above 907))
+ (test-not (prime-below 2))
+ (test 2 (prime-below 3))
+ (test 3 (prime-below 4))
+ (test 3 (prime-below 5))
+ (test 5 (prime-below 6))
+ (test 5 (prime-below 7))
(test 797 (prime-below 808))
(test 1 (totient 2))
diff --git a/lib/chibi/math/prime.scm b/lib/chibi/math/prime.scm
index 65ba56e3..50775b40 100644
--- a/lib/chibi/math/prime.scm
+++ b/lib/chibi/math/prime.scm
@@ -146,20 +146,34 @@
;;> Returns the first prime less than or equal to \var{n}, or #f if
;;> there are no such primes.
(define (prime-below n)
- (and (>= n 3)
- (let lp ((n (if (even? n) (- n 1) n)))
- (if (prime? n) n (lp (- n 2))))))
+ (cond
+ ((> n 3)
+ (let lp ((n (if (even? n) (- n 1) (- n 2))))
+ (if (prime? n) n (lp (- n 2)))))
+ ((= n 3)
+ 2)
+ (else
+ #f)))
;;> Returns the first prime greater than or equal to \var{n}. If the
;;> optional \var{limit} is given and not false, returns \scheme{#f}
;;> if no such primes exist below \var{limit}.
(define (prime-above n . o)
(let ((limit (and (pair? o) (car o))))
- (let lp ((n (if (even? n) (+ n 1) n)))
- (cond
- ((and limit (>= n limit)) #f)
- ((prime? n) n)
- (else (lp (+ n 2)))))))
+ (cond
+ ((< n 2)
+ 2)
+ (limit
+ (let lp ((n (if (even? n) (+ n 1) (+ n 2))))
+ (cond
+ ((>= n limit) #f)
+ ((prime? n) n)
+ (else (lp (+ n 2))))))
+ (else
+ (let lp ((n (if (even? n) (+ n 1) (+ n 2))))
+ (cond
+ ((prime? n) n)
+ (else (lp (+ n 2)))))))))
;;> Returns the factorization of \var{n} as a monotonically
;;> increasing list of primes.
diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm
index 7389494b..5f0b4310 100644
--- a/lib/chibi/modules.scm
+++ b/lib/chibi/modules.scm
@@ -117,6 +117,12 @@
(lp (append (map include-source (cdar ls)) (cdr ls)) res))
((include-library-declarations)
(lp (append (append-map file->sexp-list (map resolve-file (cdar ls))) (cdr ls)) res))
+ ((include-shared include-shared-optionally)
+ (for-each
+ (lambda (file)
+ (let ((f (string-append file *shared-object-extension*)))
+ (cond ((find-module-file f) => (lambda (path) (load path env))))))
+ (cdar ls)))
((begin body)
(let lp2 ((ls2 (cdar ls)) (res res))
(cond
diff --git a/lib/chibi/process.scm b/lib/chibi/process.scm
index 0f8f5284..39f417ea 100644
--- a/lib/chibi/process.scm
+++ b/lib/chibi/process.scm
@@ -175,6 +175,8 @@
(close-output-port in)
(let ((res (port->bytevector out)))
(waitpid pid 0)
+ (close-input-port out)
+ (close-input-port err)
res))))
;;> Utility to run \var{command} and return the accumulated output as
@@ -186,6 +188,8 @@
(close-output-port in)
(let ((res (port->string out)))
(waitpid pid 0)
+ (close-input-port out)
+ (close-input-port err)
res))))
;;> Utility to run \var{command} and return the accumulated output as
@@ -201,10 +205,12 @@
command
(lambda (pid in out err)
(close-output-port in)
- (let* ((out (port->string out))
- (err (port->string err))
+ (let* ((outs (port->string out))
+ (errs (port->string err))
(res (waitpid pid 0)))
- (list out err (cadr res))))))
+ (close-input-port out)
+ (close-input-port err)
+ (list outs errs (cadr res))))))
;;> Utility to run \var{command} and return a list of two values:
;;> the accumulated output as a string, the error output as a string.
@@ -221,4 +227,6 @@
(close-output-port in)
(let ((res (port->string-list out)))
(waitpid pid 0)
+ (close-input-port out)
+ (close-input-port err)
res))))
diff --git a/lib/chibi/sxml.scm b/lib/chibi/sxml.scm
index ab521fb5..ab21f0e1 100644
--- a/lib/chibi/sxml.scm
+++ b/lib/chibi/sxml.scm
@@ -141,16 +141,17 @@
;;> Render \var{sxml} as text for viewing in a terminal.
(define (sxml-display-as-text sxml . o)
- (let ((out (if (pair? o) (car o) (current-output-port))))
- (let lp ((sxml (if (and (pair? sxml) (eq? '*TOP* (car sxml)))
- (cdr sxml)
+ (let ((out (if (pair? o) (car o) (current-output-port)))
+ (sxml (if (and (pair? sxml) (null? (cddr sxml)) (eq? '*TOP* (car sxml)))
+ (cadr sxml)
sxml)))
+ (let lp ((sxml sxml))
(cond
((pair? sxml)
(let ((tag (car sxml)))
(cond
;; skip headers and the menu
- ((or (memq tag '(head style script))
+ ((or (memq tag '(head style script !DOCTYPE))
(and (eq? 'div tag)
(pair? (cdr sxml))
(pair? (cadr sxml))
@@ -158,6 +159,8 @@
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
;; recurse other tags, appending newlines for new sections
((symbol? tag)
+ (if (memq tag '(h1 h2 h3 h4 h5 h6))
+ (newline out))
(for-each
lp
(if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm
index 4be77896..b4180a2f 100644
--- a/lib/chibi/test.scm
+++ b/lib/chibi/test.scm
@@ -204,10 +204,14 @@
;;> \section{Test Groups}
-;;> Tests can be collected in groups for
-
-;;> Wraps \var{body} as a single test group, which can be filtered
-;;> and summarized separately.
+;;> Tests can be collected in groups for separate reporting, filtering
+;;> and for catching exceptions outside of a test case.
+
+;;> Wraps \var{body} as a single test group, which can be filtered and
+;;> summarized separately. The \var{body} is arbitrary Scheme code,
+;;> and tests run within its dynamic extent will be associated with
+;;> the group. If an uncaught exception is raised outside of a test
+;;> case, it will cause the whole group to fail with an error status.
;;> \example{
;;> (test-group "pi"
diff --git a/lib/chibi/trace.scm b/lib/chibi/trace.scm
index 4d4beb0a..d873856e 100644
--- a/lib/chibi/trace.scm
+++ b/lib/chibi/trace.scm
@@ -26,13 +26,25 @@
(define (make-tracer cell)
(let ((proc (cdr cell)))
- (lambda args
- (show-trace cell args)
- (active-trace-depth (+ (active-trace-depth) 1))
- (let ((res (apply proc args)))
- (active-trace-depth (- (active-trace-depth) 1))
- (show-trace-result cell args res)
- res))))
+ (if (macro? proc)
+ (make-macro
+ (lambda (expr use-env mac-env)
+ (show-trace cell (strip-syntactic-closures (cdr expr)))
+ (active-trace-depth (+ (active-trace-depth) 1))
+ (let ((res ((macro-procedure proc) expr use-env mac-env)))
+ (active-trace-depth (- (active-trace-depth) 1))
+ (show-trace-result cell
+ (strip-syntactic-closures (cdr expr))
+ (strip-syntactic-closures res))
+ res))
+ (macro-env proc))
+ (lambda args
+ (show-trace cell args)
+ (active-trace-depth (+ (active-trace-depth) 1))
+ (let ((res (apply proc args)))
+ (active-trace-depth (- (active-trace-depth) 1))
+ (show-trace-result cell args res)
+ res)))))
;;> Write a trace of all calls to the procedure \var{id} to
;;> \scheme{(current-error-port)}.
diff --git a/lib/scheme/bytevector-test.sld b/lib/scheme/bytevector-test.sld
index c26417e7..a8192ddb 100644
--- a/lib/scheme/bytevector-test.sld
+++ b/lib/scheme/bytevector-test.sld
@@ -234,11 +234,18 @@
(equal? (bytevector-s16-native-ref b 0)
(- 44444 65536)))))
- (test-assert "bytevector-s16-{ref,set!} [unaligned]"
- (let ((b (make-bytevector 3)))
+ (test-assert "bytevector-{u16,s16}-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 5)))
(bytevector-s16-set! b 1 -77 (endianness little))
- (equal? (bytevector-s16-ref b 1 (endianness little))
- -77)))
+ (bytevector-s16-set! b 3 -77 (endianness big))
+ (and (equal? (bytevector-s16-ref b 1 (endianness little))
+ -77)
+ (equal? (bytevector-u16-ref b 1 (endianness little))
+ (- 65536 77))
+ (equal? (bytevector-s16-ref b 3 (endianness big))
+ -77)
+ (equal? (bytevector-u16-ref b 3 (endianness big))
+ (- 65536 77)))))
(test-end)
(test-begin "2.6 Operations on 32-bit Integers")
@@ -276,6 +283,19 @@
2222222222)
(equal? (bytevector-s32-native-ref b 0)
(- 2222222222 (expt 2 32))))))
+
+ (test-assert "bytevector-{u32,s32}-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 9)))
+ (bytevector-s32-set! b 1 -77777 (endianness little))
+ (bytevector-s32-set! b 5 -77777 (endianness big))
+ (and (equal? (bytevector-s32-ref b 1 (endianness little))
+ -77777)
+ (equal? (bytevector-u32-ref b 1 (endianness little))
+ (- (expt 2 32) 77777))
+ (equal? (bytevector-s32-ref b 5 (endianness big))
+ -77777)
+ (equal? (bytevector-u32-ref b 5 (endianness big))
+ (- (expt 2 32) 77777)))))
(test-end)
(test-begin "2.7 Operations on 64-bit Integers")
@@ -314,6 +334,18 @@
(bytevector-u64-set! b 0 0 (endianness big))
(= 0 (bytevector-u64-ref b 0 (endianness big)))))
+ (test-assert "bytevector-{u64,s64}-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 17)))
+ (bytevector-s64-set! b 1 -7777777777 (endianness little))
+ (bytevector-s64-set! b 9 -7777777777 (endianness big))
+ (and (equal? (bytevector-s64-ref b 1 (endianness little))
+ -7777777777)
+ (equal? (bytevector-u64-ref b 1 (endianness little))
+ (- (expt 2 64) 7777777777))
+ (equal? (bytevector-s64-ref b 9 (endianness big))
+ -7777777777)
+ (equal? (bytevector-u64-ref b 9 (endianness big))
+ (- (expt 2 64) 7777777777)))))
(test-end)
(test-begin "2.8 Operations on IEEE-754 Representations")
@@ -375,6 +407,14 @@
(bytevector-ieee-double-set! b 8 number (endianness big))
(equal? (bytevector-ieee-double-ref b 0 (endianness little))
(bytevector-ieee-double-ref b 8 (endianness big)))))
+
+ (test-assert "bytevector-ieee-double-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 17))
+ (number 3.14))
+ (bytevector-ieee-double-set! b 1 number (endianness little))
+ (bytevector-ieee-double-set! b 9 number (endianness big))
+ (equal? (bytevector-ieee-double-ref b 1 (endianness little))
+ (bytevector-ieee-double-ref b 9 (endianness big)))))
(test-end)
diff --git a/lib/scheme/bytevector.stub b/lib/scheme/bytevector.stub
index 88c6acb7..7698c523 100644
--- a/lib/scheme/bytevector.stub
+++ b/lib/scheme/bytevector.stub
@@ -50,6 +50,76 @@ static double sexp_swap_double(const double x) {
return y;
}
+/* 16-bit integers */
+static inline int16_t ref_s16(const void* p) {
+ int16_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline uint16_t ref_u16(const void* p) {
+ uint16_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline void set_s16(void* p, int16_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+static inline void set_u16(void* p, uint16_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+/* 32-bit integers */
+static inline int32_t ref_s32(const void* p) {
+ int32_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline uint32_t ref_u32(const void* p) {
+ uint32_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline void set_s32(void* p, int32_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+static inline void set_u32(void* p, uint32_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+/* 64-bit integers */
+static inline int64_t ref_s64(const void* p) {
+ int64_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline uint64_t ref_u64(const void* p) {
+ uint64_t v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline void set_s64(void* p, int64_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+static inline void set_u64(void* p, uint64_t v) {
+ memcpy(p, &v, sizeof(v));
+}
+/* 32-bit floats */
+static inline float ref_f32(const void* p) {
+ float v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline void set_f32(void* p, float v) {
+ memcpy(p, &v, sizeof(v));
+}
+/* 64-bit floats */
+static inline double ref_f64(const void* p) {
+ double v;
+ memcpy(&v, p, sizeof(v));
+ return v;
+}
+static inline void set_f64(void* p, double v) {
+ memcpy(p, &v, sizeof(v));
+}
+
sexp_sint_t decode_utf8(unsigned char* p, int ch_len) {
if (ch_len <= 1)
return *p;
@@ -222,101 +292,101 @@ sexp utf32_2_str(sexp ctx, char* bv, int len, sexp endianness, int endianness_ma
(inline "((int8_t*)arg0)[arg1] = arg2"))
(define-c int16_t bytevector-s16-native-ref (bytevector int)
- (inline "*((int16_t*)(arg0+arg1))"))
+ (inline "ref_s16(arg0+arg1)"))
(define-c void bytevector-s16-native-set! (bytevector int int16_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((int16_t*)(arg0+arg1)) = arg2"))
+ (inline "set_s16(arg0+arg1, arg2)"))
(define-c int16_t bytevector-s16-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int16_t*)(arg1+arg2)) : sexp_swap_s16(*((int16_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_s16(arg1+arg2) : sexp_swap_s16(ref_s16(arg1+arg2)))"))
(define-c void bytevector-s16-set! ((value ctx sexp) bytevector int int16_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((int16_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s16(arg3))"))
+ (inline "set_s16(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s16(arg3)))"))
(define-c int32_t bytevector-s32-native-ref (bytevector int)
- (inline "*((int32_t*)(arg0+arg1))"))
+ (inline "ref_s32(arg0+arg1)"))
(define-c void bytevector-s32-native-set! (bytevector int int32_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((int32_t*)(arg0+arg1)) = arg2"))
+ (inline "set_s32(arg0+arg1, arg2)"))
(define-c int32_t bytevector-s32-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int32_t*)(arg1+arg2)) : sexp_swap_s32(*((int32_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_s32(arg1+arg2) : sexp_swap_s32(ref_s32(arg1+arg2)))"))
(define-c void bytevector-s32-set! ((value ctx sexp) bytevector int int32_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((int32_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s32(arg3))"))
+ (inline "set_s32(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s32(arg3)))"))
(define-c int64_t bytevector-s64-native-ref (bytevector int)
- (inline "*((int64_t*)(arg0+arg1))"))
+ (inline "ref_s64(arg0+arg1)"))
(define-c void bytevector-s64-native-set! (bytevector int int64_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((int64_t*)(arg0+arg1)) = arg2"))
+ (inline "set_s64(arg0+arg1, arg2)"))
(define-c int64_t bytevector-s64-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int64_t*)(arg1+arg2)) : sexp_swap_s64(*((int64_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_s64(arg1+arg2) : sexp_swap_s64(ref_s64(arg1+arg2)))"))
(define-c void bytevector-s64-set! ((value ctx sexp) bytevector int int64_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((int64_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s64(arg3))"))
+ (inline "set_s64(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s64(arg3)))"))
(define-c uint16_t bytevector-u16-native-ref (bytevector int)
- (inline "*((uint16_t*)(arg0+arg1))"))
+ (inline "ref_u16(arg0+arg1)"))
(define-c void bytevector-u16-native-set! (bytevector int uint16_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((uint16_t*)(arg0+arg1)) = arg2"))
+ (inline "set_u16(arg0+arg1, arg2)"))
(define-c uint16_t bytevector-u16-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint16_t*)(arg1+arg2)) : sexp_swap_u16(*((uint16_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_u16(arg1+arg2) : sexp_swap_u16(ref_u16(arg1+arg2)))"))
(define-c void bytevector-u16-set! ((value ctx sexp) bytevector int uint16_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((uint16_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u16(arg3))"))
+ (inline "set_u16(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u16(arg3)))"))
(define-c uint32_t bytevector-u32-native-ref (bytevector int)
- (inline "*((uint32_t*)(arg0+arg1))"))
+ (inline "ref_u32(arg0+arg1)"))
(define-c void bytevector-u32-native-set! (bytevector int uint32_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((uint32_t*)(arg0+arg1)) = arg2"))
+ (inline "set_u32(arg0+arg1, arg2)"))
(define-c uint32_t bytevector-u32-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint32_t*)(arg1+arg2)) : sexp_swap_u32(*((uint32_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_u32(arg1+arg2) : sexp_swap_u32(ref_u32(arg1+arg2)))"))
(define-c void bytevector-u32-set! ((value ctx sexp) bytevector int uint32_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((uint32_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u32(arg3))"))
+ (inline "set_u32(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u32(arg3)))"))
(define-c uint64_t bytevector-u64-native-ref (bytevector int)
- (inline "*((uint64_t*)(arg0+arg1))"))
+ (inline "ref_u64(arg0+arg1)"))
(define-c void bytevector-u64-native-set! (bytevector int uint64_t)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((uint64_t*)(arg0+arg1)) = arg2"))
+ (inline "set_u64(arg0+arg1, arg2)"))
(define-c uint64_t bytevector-u64-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint64_t*)(arg1+arg2)) : sexp_swap_u64(*((uint64_t*)(arg1+arg2))))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_u64(arg1+arg2) : sexp_swap_u64(ref_u64(arg1+arg2)))"))
(define-c void bytevector-u64-set! ((value ctx sexp) bytevector int uint64_t sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((uint64_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u64(arg3))"))
+ (inline "set_u64(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u64(arg3)))"))
(define-c float bytevector-ieee-single-native-ref (bytevector int)
- (inline "*((float*)(arg0+arg1))"))
+ (inline "ref_f32(arg0+arg1)"))
(define-c void bytevector-ieee-single-native-set! (bytevector int float)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((float*)(arg0+arg1)) = arg2"))
+ (inline "set_f32(arg0+arg1, arg2)"))
(define-c float bytevector-ieee-single-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((float*)(arg1+arg2)) : sexp_swap_float(*(float*)(arg1+arg2)))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_f32(arg1+arg2) : sexp_swap_float(ref_f32(arg1+arg2)))"))
(define-c void bytevector-ieee-single-set! ((value ctx sexp) bytevector int float sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((float*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_float(arg3))"))
+ (inline "set_f32(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_float(arg3)))"))
(define-c double bytevector-ieee-double-native-ref (bytevector int)
- (inline "*((double*)(arg0+arg1))"))
+ (inline "ref_f64(arg0+arg1)"))
(define-c void bytevector-ieee-double-native-set! (bytevector int double)
(assert (< -1 arg1 (bytevector-length arg0)))
- (inline "*((double*)(arg0+arg1)) = arg2"))
+ (inline "set_f64(arg0+arg1, arg2)"))
(define-c double bytevector-ieee-double-ref ((value ctx sexp) bytevector int sexp)
- (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((double*)(arg1+arg2)) : sexp_swap_double(*(double*)(arg1+arg2)))"))
+ (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? ref_f64(arg1+arg2) : sexp_swap_double(ref_f64(arg1+arg2)))"))
(define-c void bytevector-ieee-double-set! ((value ctx sexp) bytevector int double sexp)
(assert (< -1 arg2 (bytevector-length arg1)))
- (inline "*((double*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_double(arg3))"))
+ (inline "set_f64(arg1+arg2, (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_double(arg3)))"))
(define-c sexp (%string->utf16 "str2utf16")
((value ctx sexp) string (value (string-size arg1) int) (default (native-endianness) sexp)))
diff --git a/lib/srfi/130.scm b/lib/srfi/130.scm
index 34462bfc..e528be8a 100644
--- a/lib/srfi/130.scm
+++ b/lib/srfi/130.scm
@@ -252,6 +252,8 @@
(let* ((delim-len (string-length delim))
(grammar (if (pair? o) (car o) 'infix))
(o (if (pair? o) (cdr o) '()))
+ ;; default to an arbitrary limit guaranteed to be more than
+ ;; the maximum number of matches
(limit (or (and (pair? o) (car o)) (string-length str)))
(o (if (pair? o) (cdr o) '()))
(start (cursor-arg str
@@ -261,17 +263,37 @@
(string-cursor-end str)))))
(if (and (eq? grammar 'strict-infix) (string-cursor>=? start end))
(error "string-split 'strict-infix called on an empty string"))
- (let lp ((sc start) (i 0) (res '()))
+ (let lp ((sc start) (found? #f) (i 1) (res '()))
(cond
((string-cursor>=? sc end)
- (reverse res))
- ((and (< i limit) (string-contains str delim sc end))
+ (if (and found? (not (eq? 'suffix grammar)))
+ (reverse (cons "" res))
+ (reverse res)))
+ ((string-contains str delim sc end)
=> (lambda (sc2)
- (lp (string-cursor-forward str sc2 delim-len)
- (+ i 1)
- (cons (substring-cursor str sc sc2) res))))
+ (let ((sc3 (string-cursor-forward str sc2 delim-len)))
+ (cond
+ ((>= i limit)
+ (let* ((res (if (equal? "" delim)
+ res
+ (cons (substring-cursor str sc sc2) res)))
+ (res (if (and (string-cursor=? sc3 end)
+ (eq? 'suffix grammar))
+ res
+ (cons (substring-cursor str sc3 end) res))))
+ (lp end #f i res)))
+ ((equal? "" delim)
+ (lp (string-cursor-forward str sc2 1)
+ #f
+ (+ i 1)
+ (cons (string (string-cursor-ref str sc2)) res)))
+ ((and (string-cursor=? sc2 start) (eq? 'prefix grammar))
+ (lp sc3 #t (+ i 1) res))
+ (else
+ (lp sc3 #t (+ i 1)
+ (cons (substring-cursor str sc sc2) res)))))))
(else
- (lp end i (cons (substring-cursor str sc end) res)))))))
+ (lp end #f i (cons (substring-cursor str sc end) res)))))))
(define (string-filter pred str . o)
(let ((out (open-output-string)))
diff --git a/lib/srfi/130/test.sld b/lib/srfi/130/test.sld
index bfe99813..6c7cdf7b 100644
--- a/lib/srfi/130/test.sld
+++ b/lib/srfi/130/test.sld
@@ -343,6 +343,8 @@
(test '("foo" "bar" "baz")
(string-split "foo:bar:baz" ":"))
+ (test '("foo" "bar" "baz" "")
+ (string-split "foo:bar:baz:" ":"))
(test '("foo" "bar" "baz")
(string-split "foo:bar:baz:" ":" 'suffix))
(test '("foo" "bar:baz:")
@@ -352,8 +354,113 @@
(test '() (string-split "" ":"))
(test '() (string-split "" ":" 'suffix))
(test '("") (string-split ":" ":" 'suffix))
-
- ;;; Regression tests: check that reported bugs have been fixed
+ (test '("foo" "bar" "baz")
+ (string-split ":foo:bar:baz" ":" 'prefix))
+
+ ;; from SRFI 130 test suite
+ (test '() (string-split "" ""))
+ (test '("a" "b" "c") (string-split "abc" ""))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " "))
+ (test '("" "there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***"))
+ (test '() (string-split "" "" 'infix))
+ (test '("a" "b" "c") (string-split "abc" "" 'infix))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'infix))
+ (test '("" "there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'infix))
+ (test-error (string-split "" "" 'strict-infix))
+ (test '("a" "b" "c") (string-split "abc" "" 'strict-infix))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'strict-infix))
+ (test '("" "there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'strict-infix))
+ (test '() (string-split "" "" 'prefix))
+ (test '("a" "b" "c") (string-split "abc" "" 'prefix))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'prefix))
+ (test '("there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'prefix))
+ (test '() (string-split "" "" 'suffix))
+ (test '("a" "b" "c") (string-split "abc" "" 'suffix))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'suffix))
+ (test '("" "there" "ya" "go")
+ (string-split "***there***ya***go***" "***" 'suffix))
+ (test '() (string-split "" "" 'infix #f))
+ (test '("a" "b" "c") (string-split "abc" "" 'infix #f))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'infix #f))
+ (test '("" "there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'infix #f))
+ (test '("a" "b" "c") (string-split "abc" "" 'strict-infix #f))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'strict-infix #f))
+ (test '("" "there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'strict-infix #f))
+ (test '() (string-split "" "" 'prefix #f))
+ (test '("a" "b" "c") (string-split "abc" "" 'prefix #f))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'prefix #f))
+ (test '("there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'prefix #f))
+ (test '() (string-split "" "" 'suffix #f))
+ (test '("a" "b" "c") (string-split "abc" "" 'suffix #f))
+ (test '("too" "" "much" "" "data")
+ (string-split "too much data" " " 'suffix #f))
+ (test '("" "there" "ya" "go")
+ (string-split "***there***ya***go***" "***" 'suffix #f))
+ (test-error (string-split "" "" 'strict-infix 3))
+ (test '("a" "b" "c") (string-split "abc" "" 'strict-infix 3))
+ (test '("too" "" "much" " data")
+ (string-split "too much data" " " 'strict-infix 3))
+ (test '("" "there" "ya" "go***")
+ (string-split "***there***ya***go***" "***" 'strict-infix 3))
+ (test '() (string-split "" "" 'prefix 3))
+ (test '("a" "b" "c") (string-split "abc" "" 'prefix 3))
+ (test '("too" "" "much" " data")
+ (string-split "too much data" " " 'prefix 3))
+ (test '("there" "ya" "go***")
+ (string-split "***there***ya***go***" "***" 'prefix 3))
+ (test '() (string-split "" "" 'suffix 3))
+ (test '("a" "b" "c") (string-split "abc" "" 'suffix 3))
+ (test '("too" "" "much" " data")
+ (string-split "too much data" " " 'suffix 3))
+ (test '("" "there" "ya" "go***")
+ (string-split "***there***ya***go***" "***" 'suffix 3))
+ (test-error (string-split "" "" 'strict-infix 3 0))
+ (test '("b" "c") (string-split "abc" "" 'strict-infix 3 1))
+ (test '("oo" "" "much" " data")
+ (string-split "too much data" " " 'strict-infix 3 1))
+ (test '("**there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'strict-infix 3 1))
+ (test '() (string-split "" "" 'prefix 3 0))
+ (test '("b" "c") (string-split "abc" "" 'prefix 3 1))
+ (test '("oo" "" "much" " data")
+ (string-split "too much data" " " 'prefix 3 1))
+ (test '("**there" "ya" "go" "")
+ (string-split "***there***ya***go***" "***" 'prefix 3 1))
+ (test '() (string-split "" "" 'suffix 3 0))
+ (test '("b" "c") (string-split "abc" "" 'suffix 3 1))
+ (test '("oo" "" "much" " data")
+ (string-split "too much data" " " 'suffix 3 1))
+ (test '("**there" "ya" "go")
+ (string-split "***there***ya***go***" "***" 'suffix 3 1))
+ (test-error (string-split "" "" 'strict-infix 3 0 0))
+ (test '("b") (string-split "abc" "" 'strict-infix 3 1 2))
+ (test '("oo" "" "much" " ")
+ (string-split "too much data" " " 'strict-infix 3 1 11))
+ (test '() (string-split "" "" 'prefix 3 0 0))
+ (test '("b") (string-split "abc" "" 'prefix 3 1 2))
+ (test '("oo" "" "much" " ")
+ (string-split "too much data" " " 'prefix 3 1 11))
+ (test '() (string-split "" "" 'suffix 3 0 0))
+ (test '("b") (string-split "abc" "" 'suffix 3 1 2))
+ (test '("oo" "" "much" " ")
+ (string-split "too much data" " " 'suffix 3 1 11))
+
+;;; Regression tests: check that reported bugs have been fixed
;; From: Matthias Radestock <matthias@sorted.org>
;; Date: Wed, 10 Dec 2003 21:05:22 +0100
diff --git a/lib/srfi/145.sld b/lib/srfi/145.sld
index 8023dc89..b35d4985 100644
--- a/lib/srfi/145.sld
+++ b/lib/srfi/145.sld
@@ -1,6 +1,6 @@
(define-library (srfi 145)
(export assume)
- (import (scheme base))
+ (import (scheme base) (chibi assert))
(cond-expand
((or elide-assumptions
(and (not assumptions)
@@ -17,7 +17,6 @@
(define-syntax assume
(syntax-rules ()
((assume expression objs ...)
- (or expression
- (error "invalid assumption" 'expression objs ...)))
+ (assert expression objs ...))
((assume)
(syntax-error "assume requires an expression"))))))))
diff --git a/lib/srfi/160/base.sld b/lib/srfi/160/base.sld
index f2f62cbd..fb75093e 100644
--- a/lib/srfi/160/base.sld
+++ b/lib/srfi/160/base.sld
@@ -119,26 +119,100 @@
(define (f64vector . ls) (list->f64vector ls))
(define (c64vector . ls) (list->c64vector ls))
(define (c128vector . ls) (list->c128vector ls))
- (define (make-u1vector len) (make-uvector SEXP_U1 len))
+ (define (make-u1vector len . o)
+ (let ((res (make-uvector SEXP_U1 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (u1vector-set! res i 1)))
+ res))
(define make-u8vector make-bytevector)
- (define (make-s8vector len) (make-uvector SEXP_S8 len))
- (define (make-u16vector len) (make-uvector SEXP_U16 len))
- (define (make-s16vector len) (make-uvector SEXP_S16 len))
- (define (make-u32vector len) (make-uvector SEXP_U32 len))
- (define (make-s32vector len) (make-uvector SEXP_S32 len))
- (define (make-u64vector len) (make-uvector SEXP_U64 len))
- (define (make-s64vector len) (make-uvector SEXP_S64 len))
- (define (make-f32vector len) (make-uvector SEXP_F32 len))
- (define (make-f64vector len) (make-uvector SEXP_F64 len))
- (define (make-c64vector len) (make-uvector SEXP_C64 len))
- (define (make-c128vector len) (make-uvector SEXP_C128 len))
+ (define (make-s8vector len . o)
+ (let ((res (make-uvector SEXP_S8 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (s8vector-set! res i (car o))))
+ res))
+ (define (make-u16vector len . o)
+ (let ((res (make-uvector SEXP_U16 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (u16vector-set! res i (car o))))
+ res))
+ (define (make-s16vector len . o)
+ (let ((res (make-uvector SEXP_S16 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (s16vector-set! res i (car o))))
+ res))
+ (define (make-u32vector len . o)
+ (let ((res (make-uvector SEXP_U32 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (u32vector-set! res i (car o))))
+ res))
+ (define (make-s32vector len . o)
+ (let ((res (make-uvector SEXP_S32 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (s32vector-set! res i (car o))))
+ res))
+ (define (make-u64vector len . o)
+ (let ((res (make-uvector SEXP_U64 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (u64vector-set! res i (car o))))
+ res))
+ (define (make-s64vector len . o)
+ (let ((res (make-uvector SEXP_S64 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (s64vector-set! res i (car o))))
+ res))
+ (define (make-f32vector len . o)
+ (let ((res (make-uvector SEXP_F32 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (f32vector-set! res i (car o))))
+ res))
+ (define (make-f64vector len . o)
+ (let ((res (make-uvector SEXP_F64 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (f64vector-set! res i (car o))))
+ res))
+ (define (make-c64vector len . o)
+ (let ((res (make-uvector SEXP_C64 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (c64vector-set! res i (car o))))
+ res))
+ (define (make-c128vector len . o)
+ (let ((res (make-uvector SEXP_C128 len)))
+ (if (and (pair? o) (not (zero? (car o))))
+ (do ((i 0 (+ i 1)))
+ ((>= i len))
+ (c128vector-set! res i (car o))))
+ res))
(define-syntax define-uvector->list
(syntax-rules ()
((define-uvector->list uv->list len ref)
- (define (uv->list uv)
- (do ((i (- (len uv) 1) (- i 1))
- (res '() (cons (ref uv i) res)))
- ((< i 0) res))))))
+ (define (uv->list uv . o)
+ (let ((start (if (pair? o) (car o) 0))
+ (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (len uv))))
+ (do ((i (- end 1) (- i 1))
+ (res '() (cons (ref uv i) res)))
+ ((< i start) res)))))))
(define-uvector->list u1vector->list u1vector-length u1vector-ref)
(define-uvector->list u8vector->list bytevector-length bytevector-u8-ref)
(define-uvector->list s8vector->list s8vector-length s8vector-ref)
diff --git a/lib/srfi/160/c128.sld b/lib/srfi/160/c128.sld
index 83e8eaeb..36971ddf 100644
--- a/lib/srfi/160/c128.sld
+++ b/lib/srfi/160/c128.sld
@@ -7,7 +7,6 @@
c128vector-ref
c128vector-set!
c128vector-length
- (rename vector c128vector)
(rename uvector-unfold c128vector-unfold)
(rename uvector-unfold-right c128vector-unfold-right)
(rename vector-copy c128vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! c128vector-reverse!)
(rename vector-copy! c128vector-copy!)
(rename vector-reverse-copy! c128vector-reverse-copy!)
- (rename uvector->list c128vector->list)
(rename reverse-vector->list reverse-c128vector->list)
- (rename list->uvector list->c128vector)
(rename reverse-list->vector reverse-list->c128vector)
(rename uvector->vector c128vector->vector)
(rename vector->uvector vector->c128vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? c128vector?)
(define make-uvector make-c128vector)
+ (define vector c128vector)
+ (define uvector->list c128vector->list)
+ (define list->uvector list->c128vector)
(define uvector-length c128vector-length)
(define uvector-ref c128vector-ref)
(define uvector-set! c128vector-set!))
diff --git a/lib/srfi/160/c64.sld b/lib/srfi/160/c64.sld
index 99d4ae4f..4934d918 100644
--- a/lib/srfi/160/c64.sld
+++ b/lib/srfi/160/c64.sld
@@ -7,7 +7,6 @@
c64vector-ref
c64vector-set!
c64vector-length
- (rename vector c64vector)
(rename uvector-unfold c64vector-unfold)
(rename uvector-unfold-right c64vector-unfold-right)
(rename vector-copy c64vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! c64vector-reverse!)
(rename vector-copy! c64vector-copy!)
(rename vector-reverse-copy! c64vector-reverse-copy!)
- (rename uvector->list c64vector->list)
(rename reverse-vector->list reverse-c64vector->list)
- (rename list->uvector list->c64vector)
(rename reverse-list->vector reverse-list->c64vector)
(rename uvector->vector c64vector->vector)
(rename vector->uvector vector->c64vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? c64vector?)
(define make-uvector make-c64vector)
+ (define vector c64vector)
+ (define uvector->list c64vector->list)
+ (define list->uvector list->c64vector)
(define uvector-length c64vector-length)
(define uvector-ref c64vector-ref)
(define uvector-set! c64vector-set!))
diff --git a/lib/srfi/160/f32.sld b/lib/srfi/160/f32.sld
index ec924278..47c48dad 100644
--- a/lib/srfi/160/f32.sld
+++ b/lib/srfi/160/f32.sld
@@ -7,7 +7,6 @@
f32vector-ref
f32vector-set!
f32vector-length
- (rename vector f32vector)
(rename uvector-unfold f32vector-unfold)
(rename uvector-unfold-right f32vector-unfold-right)
(rename vector-copy f32vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! f32vector-reverse!)
(rename vector-copy! f32vector-copy!)
(rename vector-reverse-copy! f32vector-reverse-copy!)
- (rename uvector->list f32vector->list)
(rename reverse-vector->list reverse-f32vector->list)
- (rename list->uvector list->f32vector)
(rename reverse-list->vector reverse-list->f32vector)
(rename uvector->vector f32vector->vector)
(rename vector->uvector vector->f32vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? f32vector?)
(define make-uvector make-f32vector)
+ (define vector f32vector)
+ (define uvector->list f32vector->list)
+ (define list->uvector list->f32vector)
(define uvector-length f32vector-length)
(define uvector-ref f32vector-ref)
(define uvector-set! f32vector-set!))
diff --git a/lib/srfi/160/f64.sld b/lib/srfi/160/f64.sld
index 628fdf12..15e05bab 100644
--- a/lib/srfi/160/f64.sld
+++ b/lib/srfi/160/f64.sld
@@ -7,7 +7,6 @@
f64vector-ref
f64vector-set!
f64vector-length
- (rename vector f64vector)
(rename uvector-unfold f64vector-unfold)
(rename uvector-unfold-right f64vector-unfold-right)
(rename vector-copy f64vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! f64vector-reverse!)
(rename vector-copy! f64vector-copy!)
(rename vector-reverse-copy! f64vector-reverse-copy!)
- (rename uvector->list f64vector->list)
(rename reverse-vector->list reverse-f64vector->list)
- (rename list->uvector list->f64vector)
(rename reverse-list->vector reverse-list->f64vector)
(rename uvector->vector f64vector->vector)
(rename vector->uvector vector->f64vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? f64vector?)
(define make-uvector make-f64vector)
+ (define vector f64vector)
+ (define uvector->list f64vector->list)
+ (define list->uvector list->f64vector)
(define uvector-length f64vector-length)
(define uvector-ref f64vector-ref)
(define uvector-set! f64vector-set!))
diff --git a/lib/srfi/160/s16.sld b/lib/srfi/160/s16.sld
index 8b98c41a..d8b4f1e6 100644
--- a/lib/srfi/160/s16.sld
+++ b/lib/srfi/160/s16.sld
@@ -7,7 +7,6 @@
s16vector-ref
s16vector-set!
s16vector-length
- (rename vector s16vector)
(rename uvector-unfold s16vector-unfold)
(rename uvector-unfold-right s16vector-unfold-right)
(rename vector-copy s16vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! s16vector-reverse!)
(rename vector-copy! s16vector-copy!)
(rename vector-reverse-copy! s16vector-reverse-copy!)
- (rename uvector->list s16vector->list)
(rename reverse-vector->list reverse-s16vector->list)
- (rename list->uvector list->s16vector)
(rename reverse-list->vector reverse-list->s16vector)
(rename uvector->vector s16vector->vector)
(rename vector->uvector vector->s16vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? s16vector?)
(define make-uvector make-s16vector)
+ (define vector s16vector)
+ (define uvector->list s16vector->list)
+ (define list->uvector list->s16vector)
(define uvector-length s16vector-length)
(define uvector-ref s16vector-ref)
(define uvector-set! s16vector-set!))
diff --git a/lib/srfi/160/s32.sld b/lib/srfi/160/s32.sld
index 33bfb1cc..9914e937 100644
--- a/lib/srfi/160/s32.sld
+++ b/lib/srfi/160/s32.sld
@@ -7,7 +7,6 @@
s32vector-ref
s32vector-set!
s32vector-length
- (rename vector s32vector)
(rename uvector-unfold s32vector-unfold)
(rename uvector-unfold-right s32vector-unfold-right)
(rename vector-copy s32vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! s32vector-reverse!)
(rename vector-copy! s32vector-copy!)
(rename vector-reverse-copy! s32vector-reverse-copy!)
- (rename uvector->list s32vector->list)
(rename reverse-vector->list reverse-s32vector->list)
- (rename list->uvector list->s32vector)
(rename reverse-list->vector reverse-list->s32vector)
(rename uvector->vector s32vector->vector)
(rename vector->uvector vector->s32vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? s32vector?)
(define make-uvector make-s32vector)
+ (define vector s32vector)
+ (define uvector->list s32vector->list)
+ (define list->uvector list->s32vector)
(define uvector-length s32vector-length)
(define uvector-ref s32vector-ref)
(define uvector-set! s32vector-set!))
diff --git a/lib/srfi/160/s64.sld b/lib/srfi/160/s64.sld
index de9aaafd..8c5bbbda 100644
--- a/lib/srfi/160/s64.sld
+++ b/lib/srfi/160/s64.sld
@@ -7,7 +7,6 @@
s64vector-ref
s64vector-set!
s64vector-length
- (rename vector s64vector)
(rename uvector-unfold s64vector-unfold)
(rename uvector-unfold-right s64vector-unfold-right)
(rename vector-copy s64vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! s64vector-reverse!)
(rename vector-copy! s64vector-copy!)
(rename vector-reverse-copy! s64vector-reverse-copy!)
- (rename uvector->list s64vector->list)
(rename reverse-vector->list reverse-s64vector->list)
- (rename list->uvector list->s64vector)
(rename reverse-list->vector reverse-list->s64vector)
(rename uvector->vector s64vector->vector)
(rename vector->uvector vector->s64vector)
@@ -64,6 +61,10 @@
(begin
(define uvector? s64vector?)
(define make-uvector make-s64vector)
+ (define vector s64vector)
+ (define uvector->list s64vector->list)
+ (define list->uvector list->s64vector)
+ (define uvector->list s64vector->list)
(define uvector-length s64vector-length)
(define uvector-ref s64vector-ref)
(define uvector-set! s64vector-set!))
diff --git a/lib/srfi/160/s8.sld b/lib/srfi/160/s8.sld
index a92219ed..94aa3987 100644
--- a/lib/srfi/160/s8.sld
+++ b/lib/srfi/160/s8.sld
@@ -7,7 +7,6 @@
s8vector-ref
s8vector-set!
s8vector-length
- (rename vector s8vector)
(rename uvector-unfold s8vector-unfold)
(rename uvector-unfold-right s8vector-unfold-right)
(rename vector-copy s8vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! s8vector-reverse!)
(rename vector-copy! s8vector-copy!)
(rename vector-reverse-copy! s8vector-reverse-copy!)
- (rename uvector->list s8vector->list)
(rename reverse-vector->list reverse-s8vector->list)
- (rename list->uvector list->s8vector)
(rename reverse-list->vector reverse-list->s8vector)
(rename uvector->vector s8vector->vector)
(rename vector->uvector vector->s8vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? s8vector?)
(define make-uvector make-s8vector)
+ (define vector s8vector)
+ (define uvector->list s8vector->list)
+ (define list->uvector list->s8vector)
(define uvector-length s8vector-length)
(define uvector-ref s8vector-ref)
(define uvector-set! s8vector-set!))
diff --git a/lib/srfi/160/test.sld b/lib/srfi/160/test.sld
index c70e3091..fc2d805d 100644
--- a/lib/srfi/160/test.sld
+++ b/lib/srfi/160/test.sld
@@ -1,6 +1,6 @@
(define-library (srfi 160 test)
(import (scheme base)
- (srfi 160 u32) (srfi 160 u64) (srfi 160 s64)
+ (srfi 160 base) (srfi 160 u32) (srfi 160 u64) (srfi 160 s64)
(chibi test))
(export run-tests)
(begin
@@ -141,6 +141,9 @@
(test '#u32(1 40 30 20 10) (u32vector-copy vrc1))
(u32vector-reverse-copy! vrc2 1 '#u32(0 10 20 30 40) 1 4)
(test '#u32(1 30 20 10 5) (u32vector-copy vrc2))
+ (let ((uv (make-u64vector 2 0)))
+ (u64vector-set! uv 0 10631884467263188874)
+ (test '#u64(10631884467263188874 0) uv))
)
(test-group "uvectors/conversion"
@@ -154,4 +157,40 @@
(test '#u32(3 2 1) (reverse-list->u32vector '(1 2 3)))
)
+ (test-group "bitvectors"
+ (let ((uv #u1(0 1 0 1 0 1 0)))
+ (test 0 (u1vector-ref uv 0))
+ (test 1 (u1vector-ref uv 1))
+ (test 0 (u1vector-ref uv 2))
+ (test 1 (u1vector-ref uv 3))
+ (test 0 (u1vector-ref uv 4))
+ (test 1 (u1vector-ref uv 5))
+ (test 0 (u1vector-ref uv 6))
+ (test-error (u1vector-ref uv -1))
+ (test-error (u1vector-ref uv 7)))
+ (let ((uv #u1(1 0 1 0 1 0 1 0)))
+ (test 1 (u1vector-ref uv 0))
+ (test 0 (u1vector-ref uv 1))
+ (test 1 (u1vector-ref uv 2))
+ (test 0 (u1vector-ref uv 3))
+ (test 1 (u1vector-ref uv 4))
+ (test 0 (u1vector-ref uv 5))
+ (test 1 (u1vector-ref uv 6))
+ (test 0 (u1vector-ref uv 7))
+ (test-error (u1vector-ref uv -1))
+ (test-error (u1vector-ref uv 8)))
+ (let ((uv #u1(0 1 0 1 0 1 0 1 0)))
+ (test 0 (u1vector-ref uv 0))
+ (test 1 (u1vector-ref uv 1))
+ (test 0 (u1vector-ref uv 2))
+ (test 1 (u1vector-ref uv 3))
+ (test 0 (u1vector-ref uv 4))
+ (test 1 (u1vector-ref uv 5))
+ (test 0 (u1vector-ref uv 6))
+ (test 1 (u1vector-ref uv 7))
+ (test 0 (u1vector-ref uv 8))
+ (test-error (u1vector-ref uv -1))
+ (test-error (u1vector-ref uv 9)))
+ )
+
(test-end))))
diff --git a/lib/srfi/160/u16.sld b/lib/srfi/160/u16.sld
index 133b4801..88325d28 100644
--- a/lib/srfi/160/u16.sld
+++ b/lib/srfi/160/u16.sld
@@ -7,7 +7,6 @@
u16vector-ref
u16vector-set!
u16vector-length
- (rename vector u16vector)
(rename uvector-unfold u16vector-unfold)
(rename uvector-unfold-right u16vector-unfold-right)
(rename vector-copy u16vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! u16vector-reverse!)
(rename vector-copy! u16vector-copy!)
(rename vector-reverse-copy! u16vector-reverse-copy!)
- (rename uvector->list u16vector->list)
(rename reverse-vector->list reverse-u16vector->list)
- (rename list->uvector list->u16vector)
(rename reverse-list->vector reverse-list->u16vector)
(rename uvector->vector u16vector->vector)
(rename vector->uvector vector->u16vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? u16vector?)
(define make-uvector make-u16vector)
+ (define vector u16vector)
+ (define uvector->list u16vector->list)
+ (define list->uvector list->u16vector)
(define uvector-length u16vector-length)
(define uvector-ref u16vector-ref)
(define uvector-set! u16vector-set!))
diff --git a/lib/srfi/160/u32.sld b/lib/srfi/160/u32.sld
index 968787f3..56a5f60c 100644
--- a/lib/srfi/160/u32.sld
+++ b/lib/srfi/160/u32.sld
@@ -7,7 +7,6 @@
u32vector-ref
u32vector-set!
u32vector-length
- (rename vector u32vector)
(rename uvector-unfold u32vector-unfold)
(rename uvector-unfold-right u32vector-unfold-right)
(rename vector-copy u32vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! u32vector-reverse!)
(rename vector-copy! u32vector-copy!)
(rename vector-reverse-copy! u32vector-reverse-copy!)
- (rename uvector->list u32vector->list)
(rename reverse-vector->list reverse-u32vector->list)
- (rename list->uvector list->u32vector)
(rename reverse-list->vector reverse-list->u32vector)
(rename uvector->vector u32vector->vector)
(rename vector->uvector vector->u32vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? u32vector?)
(define make-uvector make-u32vector)
+ (define vector u32vector)
+ (define uvector->list u32vector->list)
+ (define list->uvector list->u32vector)
(define uvector-length u32vector-length)
(define uvector-ref u32vector-ref)
(define uvector-set! u32vector-set!))
diff --git a/lib/srfi/160/u64.sld b/lib/srfi/160/u64.sld
index 7c04249b..075be3b3 100644
--- a/lib/srfi/160/u64.sld
+++ b/lib/srfi/160/u64.sld
@@ -7,7 +7,6 @@
u64vector-ref
u64vector-set!
u64vector-length
- (rename vector u64vector)
(rename uvector-unfold u64vector-unfold)
(rename uvector-unfold-right u64vector-unfold-right)
(rename vector-copy u64vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! u64vector-reverse!)
(rename vector-copy! u64vector-copy!)
(rename vector-reverse-copy! u64vector-reverse-copy!)
- (rename uvector->list u64vector->list)
(rename reverse-vector->list reverse-u64vector->list)
- (rename list->uvector list->u64vector)
(rename reverse-list->vector reverse-list->u64vector)
(rename uvector->vector u64vector->vector)
(rename vector->uvector vector->u64vector)
@@ -64,6 +61,10 @@
(begin
(define uvector? u64vector?)
(define make-uvector make-u64vector)
+ (define vector u64vector)
+ (define uvector->list u64vector->list)
+ (define list->uvector list->u64vector)
+ (define uvector->list u64vector->list)
(define uvector-length u64vector-length)
(define uvector-ref u64vector-ref)
(define uvector-set! u64vector-set!))
diff --git a/lib/srfi/160/u8.sld b/lib/srfi/160/u8.sld
index 558a917e..3716e29e 100644
--- a/lib/srfi/160/u8.sld
+++ b/lib/srfi/160/u8.sld
@@ -7,7 +7,6 @@
u8vector-ref
u8vector-set!
u8vector-length
- (rename vector u8vector)
(rename uvector-unfold u8vector-unfold)
(rename uvector-unfold-right u8vector-unfold-right)
(rename vector-copy u8vector-copy)
@@ -48,9 +47,7 @@
(rename vector-reverse! u8vector-reverse!)
(rename vector-copy! u8vector-copy!)
(rename vector-reverse-copy! u8vector-reverse-copy!)
- (rename uvector->list u8vector->list)
(rename reverse-vector->list reverse-u8vector->list)
- (rename list->uvector list->u8vector)
(rename reverse-list->vector reverse-list->u8vector)
(rename uvector->vector u8vector->vector)
(rename vector->uvector vector->u8vector)
@@ -64,6 +61,9 @@
(begin
(define uvector? u8vector?)
(define make-uvector make-u8vector)
+ (define vector u8vector)
+ (define uvector->list u8vector->list)
+ (define list->uvector list->u8vector)
(define uvector-length u8vector-length)
(define uvector-ref u8vector-ref)
(define uvector-set! u8vector-set!))
diff --git a/lib/srfi/160/uvector.scm b/lib/srfi/160/uvector.scm
index 80adfcea..36f74512 100644
--- a/lib/srfi/160/uvector.scm
+++ b/lib/srfi/160/uvector.scm
@@ -17,19 +17,9 @@
(lp2 (+ i 1)))))
(lp1 (cdr ls)))))))
-(define (list->uvector ls)
- (let ((res (make-uvector (length ls))))
- (do ((ls ls (cdr ls))
- (i 0 (+ i 1)))
- ((null? ls) res)
- (uvector-set! res i (car ls)))))
-
(define (reverse-list->uvector ls)
(list->uvector (reverse ls)))
-(define (vector . ls)
- (list->uvector ls))
-
(define (uvector-unfold f len seed)
(let ((res (make-uvector len)))
(let lp ((i 0) (seed seed))
@@ -315,9 +305,6 @@
(define (reverse-list->vector ls)
(list->uvector (reverse ls)))
-(define (uvector->list vec . o)
- (reverse (apply reverse-vector->list vec o)))
-
(define (uvector->vector vec . o)
(list->vector (apply uvector->list vec o)))
diff --git a/lib/srfi/160/uvprims.stub b/lib/srfi/160/uvprims.stub
index a1481a70..7e6d2474 100644
--- a/lib/srfi/160/uvprims.stub
+++ b/lib/srfi/160/uvprims.stub
@@ -135,38 +135,69 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(define-c boolean (c64vector? "uvector_of") (sexp (value SEXP_C64 int)))
(define-c boolean (c128vector? "uvector_of") (sexp (value SEXP_C128 int)))
-(define-c int u1vector-ref (sexp int))
-(define-c void (u1vector-set! "u1vector_set") (sexp int int))
-
-(define-c signed-char s8vector-ref (s8vector int))
-(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char))
-
-(define-c unsigned-short u16vector-ref (u16vector int))
-(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short))
-
-(define-c short s16vector-ref (s16vector int))
-(define-c void (s16vector-set! "s16vector_set") (s16vector int short))
-
-(define-c unsigned-int u32vector-ref (u32vector int))
-(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int))
-
-(define-c int32_t s32vector-ref (s32vector int))
-(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t))
-
-(define-c uint64_t u64vector-ref (u64vector int))
-(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t))
-
-(define-c int64_t s64vector-ref (s64vector int))
-(define-c void (s64vector-set! "s64vector_set") (s64vector int int64_t))
-
-(define-c float f32vector-ref (f32vector int))
-(define-c void (f32vector-set! "f32vector_set") (f32vector int float))
-
-(define-c double f64vector-ref (f64vector int))
-(define-c void (f64vector-set! "f64vector_set") (f64vector int double))
-
-(define-c sexp c64vector-ref ((value ctx sexp) c64vector int))
-(define-c void (c64vector-set! "c64vector_set") ((value ctx sexp) c64vector int sexp))
-
-(define-c sexp c128vector-ref ((value ctx sexp) c128vector int))
-(define-c void (c128vector-set! "c128vector_set") ((value ctx sexp) c128vector int sexp))
+(define-c int u1vector-ref (sexp int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (u1vector-set! "u1vector_set") (sexp int int)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (< -1 arg2 (expt 2 1))))
+
+(define-c signed-char s8vector-ref (s8vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= (- (expt 2 7)) arg2 (- (expt 2 7) 1))))
+
+(define-c unsigned-short u16vector-ref (u16vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= 0 arg2 (expt 2 16))))
+
+(define-c short s16vector-ref (s16vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (s16vector-set! "s16vector_set") (s16vector int short)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= (- (expt 2 15)) arg2 (- (expt 2 15) 1))))
+
+(define-c unsigned-int u32vector-ref (u32vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= 0 arg2 (expt 2 32))))
+
+(define-c int32_t s32vector-ref (s32vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= (- (expt 2 31)) arg2 (- (expt 2 31) 1))))
+
+(define-c uint64_t u64vector-ref (u64vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)
+ (assert (< -1 arg1 (uvector-length arg0))
+ (<= 0 arg2)))
+
+(define-c int64_t s64vector-ref (s64vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (s64vector-set! "s64vector_set") (s64vector int int64_t)
+ (assert (< -1 arg1 (uvector-length arg0))))
+
+(define-c float f32vector-ref (f32vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (f32vector-set! "f32vector_set") (f32vector int float)
+ (assert (< -1 arg1 (uvector-length arg0))))
+
+(define-c double f64vector-ref (f64vector int)
+ (assert (< -1 arg1 (uvector-length arg0))))
+(define-c void (f64vector-set! "f64vector_set") (f64vector int double)
+ (assert (< -1 arg1 (uvector-length arg0))))
+
+(define-c sexp c64vector-ref ((value ctx sexp) c64vector int)
+ (assert (< -1 arg2 (uvector-length arg1))))
+(define-c void (c64vector-set! "c64vector_set") ((value ctx sexp) c64vector int sexp)
+ (assert (< -1 arg2 (uvector-length arg1))))
+
+(define-c sexp c128vector-ref ((value ctx sexp) c128vector int)
+ (assert (< -1 arg2 (uvector-length arg1))))
+(define-c void (c128vector-set! "c128vector_set") ((value ctx sexp) c128vector int sexp)
+ (assert (< -1 arg2 (uvector-length arg1))))
diff --git a/lib/srfi/179.sld b/lib/srfi/179.sld
new file mode 100644
index 00000000..11e7b2f6
--- /dev/null
+++ b/lib/srfi/179.sld
@@ -0,0 +1,44 @@
+(define-library (srfi 179)
+ (import (scheme base)
+ (scheme list)
+ (scheme vector)
+ (scheme sort)
+ (srfi 160 base)
+ (srfi 179 base)
+ (chibi assert))
+ (export
+ ;; Miscellaneous Functions
+ translation? permutation?
+ ;; Intervals
+ make-interval interval? interval-dimension interval-lower-bound
+ interval-upper-bound interval-lower-bounds->list
+ interval-upper-bounds->list interval-lower-bounds->vector
+ interval-upper-bounds->vector interval= interval-volume
+ interval-subset? interval-contains-multi-index? interval-projections
+ interval-for-each interval-dilate interval-intersect
+ interval-translate interval-permute interval-rotate
+ interval-scale interval-cartesian-product
+ ;; Storage Classes
+ make-storage-class storage-class? storage-class-getter
+ storage-class-setter storage-class-checker storage-class-maker
+ storage-class-copier storage-class-length storage-class-default
+ generic-storage-class s8-storage-class s16-storage-class
+ s32-storage-class s64-storage-class u1-storage-class
+ u8-storage-class u16-storage-class u32-storage-class
+ u64-storage-class f8-storage-class f16-storage-class
+ f32-storage-class f64-storage-class
+ c64-storage-class c128-storage-class
+ ;; Arrays
+ make-array array? array-domain array-getter array-dimension
+ mutable-array? array-setter specialized-array-default-safe?
+ specialized-array-default-mutable? make-specialized-array
+ specialized-array? array-storage-class array-indexer array-body
+ array-safe? array-elements-in-order? specialized-array-share
+ array-copy array-curry array-extract array-tile array-translate
+ array-permute array-rotate array-reverse array-sample
+ array-outer-product array-map array-for-each array-fold
+ array-fold-right array-reduce array-any array-every
+ array->list list->array array-assign! array-ref array-set!
+ specialized-array-reshape
+ )
+ (include "179/transforms.scm"))
diff --git a/lib/srfi/179/base.scm b/lib/srfi/179/base.scm
new file mode 100644
index 00000000..4442530a
--- /dev/null
+++ b/lib/srfi/179/base.scm
@@ -0,0 +1,469 @@
+;; Miscellaneous Functions
+
+(define (translation? x)
+ (and (vector? x) (not (vector-empty? x)) (vector-every exact-integer? x)))
+
+(define (permutation? x)
+ (and (translation? x)
+ (let* ((len (vector-length x))
+ (seen (make-vector len 0)))
+ (let lp ((i 0))
+ (or (>= i len)
+ (and (< -1 (vector-ref x i) len)
+ (zero? (vector-ref seen (vector-ref x i)))
+ (begin
+ (vector-set! seen (vector-ref x i) 1)
+ (lp (+ i 1)))))))))
+
+;; Intervals
+
+(define-record-type Interval
+ (%%make-interval lb ub)
+ interval?
+ (lb interval-lb)
+ (ub interval-ub))
+
+(define (%make-interval lo hi)
+ (assert (and (translation? lo)
+ (translation? hi)
+ (= (vector-length lo) (vector-length hi))
+ (vector-every < lo hi)))
+ (%%make-interval lo hi))
+
+(define (make-interval x . o)
+ (if (pair? o)
+ (%make-interval x (car o))
+ (%make-interval (make-vector (vector-length x) 0) x)))
+
+(define (interval-dimension iv)
+ (vector-length (interval-lb iv)))
+
+(define (interval-lower-bound iv i) (vector-ref (interval-lb iv) i))
+(define (interval-upper-bound iv i) (vector-ref (interval-ub iv) i))
+(define (interval-lower-bounds->list iv) (vector->list (interval-lb iv)))
+(define (interval-upper-bounds->list iv) (vector->list (interval-ub iv)))
+(define (interval-lower-bounds->vector iv) (vector-copy (interval-lb iv)))
+(define (interval-upper-bounds->vector iv) (vector-copy (interval-ub iv)))
+
+(define (interval= iv1 iv2)
+ (assert (and (interval? iv1) (interval? iv2)))
+ (and (equal? (interval-lb iv1) (interval-lb iv2))
+ (equal? (interval-ub iv1) (interval-ub iv2))))
+
+(define (interval-volume iv)
+ (vector-fold (lambda (acc lower upper) (* acc (- upper lower)))
+ 1
+ (interval-lb iv) (interval-ub iv)))
+
+(define (interval-subset? iv1 iv2)
+ (assert (and (interval? iv1) (interval? iv2)
+ (= (interval-dimension iv1) (interval-dimension iv2))))
+ (and (vector-every >= (interval-lb iv1) (interval-lb iv2))
+ (vector-every <= (interval-ub iv1) (interval-ub iv2))))
+
+(define (interval-contains-multi-index? iv i0 . o)
+ (assert (interval? iv))
+ (let ((i (list->vector (cons i0 o))))
+ (assert (and (= (interval-dimension iv) (vector-length i))
+ (vector-every integer? i)))
+ (and (vector-every >= i (interval-lb iv))
+ (vector-every < i (interval-ub iv)))))
+
+(define (interval-projections iv rd)
+ (values (make-interval (vector-copy (interval-lb iv) 0 rd)
+ (vector-copy (interval-ub iv) 0 rd))
+ (make-interval (vector-copy (interval-lb iv) rd)
+ (vector-copy (interval-ub iv) rd))))
+
+(define (rev-index-next! rev-index rev-lowers rev-uppers)
+ (cond
+ ((null? rev-index) #f)
+ ((< (caar rev-index) (- (car rev-uppers) 1))
+ (set-car! (car rev-index) (+ 1 (caar rev-index)))
+ #t)
+ (else
+ (set-car! (car rev-index) (car rev-lowers))
+ (rev-index-next! (cdr rev-index) (cdr rev-lowers) (cdr rev-uppers)))))
+
+(define (interval-cursor iv)
+ (let* ((rev-lowers (reverse (interval-lower-bounds->list iv)))
+ (rev-uppers (reverse (interval-upper-bounds->list iv)))
+ (multi-index (interval-lower-bounds->list iv))
+ (rev-index (pair-fold cons '() multi-index)))
+ (vector multi-index rev-index rev-lowers rev-uppers)))
+
+(define (interval-cursor-get ivc)
+ (vector-ref ivc 0))
+
+(define (interval-cursor-next! ivc)
+ (and (rev-index-next! (vector-ref ivc 1)
+ (vector-ref ivc 2)
+ (vector-ref ivc 3))
+ (vector-ref ivc 0)))
+
+(define (interval-cursor-next ivc)
+ (let* ((multi-index (list-copy (vector-ref ivc 0)))
+ (ivc (vector multi-index
+ (pair-fold cons '() multi-index)
+ (vector-ref ivc 2)
+ (vector-ref ivc 3))))
+ (and (rev-index-next! (vector-ref ivc 1)
+ (vector-ref ivc 2)
+ (vector-ref ivc 3))
+ (values ivc (vector-ref ivc 0)))))
+
+(define (interval-fold kons knil iv)
+ (case (interval-dimension iv)
+ ((1)
+ (let ((end (interval-upper-bound iv 0)))
+ (do ((i (interval-lower-bound iv 0) (+ i 1))
+ (acc knil (kons acc i)))
+ ((>= i end) acc))))
+ ((2)
+ (let ((end0 (interval-upper-bound iv 0))
+ (start1 (interval-lower-bound iv 1))
+ (end1 (interval-upper-bound iv 1)))
+ (do ((i (interval-lower-bound iv 0) (+ i 1))
+ (acc knil
+ (do ((j start1 (+ j 1))
+ (acc acc (kons acc i j)))
+ ((>= j end1) acc))))
+ ((>= i end0) acc))))
+ (else
+ (let ((ivc (interval-cursor iv)))
+ (let lp ((acc knil))
+ (let ((acc (apply kons acc (interval-cursor-get ivc))))
+ (if (interval-cursor-next! ivc)
+ (lp acc)
+ acc)))))))
+
+(define (interval-for-each f iv)
+ (interval-fold (lambda (acc . multi-index) (apply f multi-index)) #f iv)
+ (if #f #f))
+
+(define (interval-dilate iv lower-diffs upper-diffs)
+ (assert (= (interval-dimension iv)
+ (vector-length lower-diffs)
+ (vector-length upper-diffs)))
+ (make-interval (vector-map + (interval-lb iv) lower-diffs)
+ (vector-map + (interval-ub iv) upper-diffs)))
+
+(define (interval-intersect iv0 . o)
+ (let ((ls (cons iv0 o)))
+ (assert (and (every interval? ls)
+ (or (null? o) (apply = (map interval-dimension ls)))))
+ (let ((lower (apply vector-map max (map interval-lb ls)))
+ (upper (apply vector-map min (map interval-ub ls))))
+ (and (vector-every < lower upper)
+ (make-interval lower upper)))))
+
+(define (interval-translate iv translation)
+ (assert (translation? translation))
+ (interval-dilate iv translation translation))
+
+(define (interval-permute iv perm)
+ (assert (and (interval? iv) (permutation? perm)))
+ (let* ((len (interval-dimension iv))
+ (lower (make-vector len))
+ (upper (make-vector len)))
+ (assert (= len (vector-length perm)))
+ (do ((i 0 (+ i 1)))
+ ((>= i len) (make-interval lower upper))
+ (vector-set! lower i (interval-lower-bound iv (vector-ref perm i)))
+ (vector-set! upper i (interval-upper-bound iv (vector-ref perm i))))))
+
+(define (interval-rotate iv dim)
+ (let ((lower (interval-lb iv))
+ (upper (interval-ub iv)))
+ (make-interval (vector-append (vector-copy lower dim)
+ (vector-copy lower 0 dim))
+ (vector-append (vector-copy upper dim)
+ (vector-copy upper 0 dim)))))
+
+(define (interval-scale iv scales)
+ (assert (and (interval? iv)
+ (vector? scales)
+ (= (interval-dimension iv) (vector-length scales))
+ (vector-every exact-integer? scales)
+ (vector-every positive? scales)))
+ (make-interval
+ (vector-map (lambda (u s) (exact (ceiling (/ u s))))
+ (interval-ub iv)
+ scales)))
+
+(define (interval-cartesian-product iv0 . o)
+ (make-interval (apply vector-append (map interval-lb (cons iv0 o)))
+ (apply vector-append (map interval-ub (cons iv0 o)))))
+
+;; Storage Classes
+
+(define-record-type Storage-Class
+ (make-storage-class getter setter checker maker copier length default)
+ storage-class?
+ (getter storage-class-getter)
+ (setter storage-class-setter)
+ (checker storage-class-checker)
+ (maker storage-class-maker)
+ (copier storage-class-copier)
+ (length storage-class-length)
+ (default storage-class-default))
+
+(define generic-storage-class
+ (make-storage-class
+ vector-ref vector-set! (lambda (x) #t) make-vector
+ vector-copy! vector-length #f))
+
+;; Parameters
+
+;; Note safety is ignored in this implementation.
+(define specialized-array-default-safe?
+ (make-parameter #f (lambda (x) (assert (boolean? x)) x)))
+
+(define specialized-array-default-mutable?
+ (make-parameter #t (lambda (x) (assert (boolean? x)) x)))
+
+;; Arrays
+
+(define-record-type Array
+ (%%make-array domain getter setter storage body coeffs indexer safe? adjacent?)
+ array?
+ (domain array-domain)
+ (getter array-getter)
+ (setter array-setter %array-setter-set!)
+ (storage array-storage-class)
+ (body array-body)
+ (coeffs array-coeffs)
+ (indexer array-indexer)
+ (safe? array-safe?)
+ (adjacent? array-adjacent? array-adjacent?-set!))
+
+(define (%make-array domain getter setter storage body coeffs
+ indexer safe? adjacent?)
+ (assert (and (interval? domain)
+ (procedure? getter)
+ (or (not setter) (procedure? setter))
+ (or (not storage) (storage-class? storage))))
+ (%%make-array
+ domain getter setter storage body coeffs indexer safe? adjacent?))
+
+(define (make-array domain getter . o)
+ (assert (and (interval? domain) (procedure? getter)))
+ (%make-array domain getter (and (pair? o) (car o)) #f #f #f #f #f #f))
+
+(define (array-dimension a)
+ (interval-dimension (array-domain a)))
+
+(define (mutable-array? x)
+ (and (array? x) (array-setter x) #t))
+
+(define (array-ref array . multi-index)
+ (apply (array-getter array) multi-index))
+
+(define (array-set! array val . multi-index)
+ (apply (array-setter array) val multi-index))
+
+(define (specialized-getter body indexer getter)
+ (lambda multi-index
+ (getter body (apply indexer multi-index))))
+
+(define (specialized-setter body indexer setter)
+ (lambda (val . multi-index)
+ (setter body (apply indexer multi-index) val)))
+
+
+;; Indexing
+
+(define (indexer->coeffs indexer domain . o)
+ (let* ((verify? (and (pair? o) (car o)))
+ (res (make-vector (+ 1 (interval-dimension domain)) 0))
+ (multi-index (interval-lower-bounds->list domain))
+ (base (apply indexer multi-index)))
+ (vector-set! res 0 base)
+ (let lp ((i 1)
+ (ls multi-index)
+ (offset base)
+ (count 0))
+ (cond
+ ((null? ls)
+ (if (and verify? (zero? count))
+ (lp 1 multi-index offset (+ count 1))
+ res))
+ ((= (+ 1 (interval-lower-bound domain (- i 1)))
+ (interval-upper-bound domain (- i 1)))
+ (lp (+ i 1) (cdr ls) offset count))
+ (else
+ (let ((dir (if (and (> count 0)
+ (= (+ (car ls) 1)
+ (interval-upper-bound domain (- i 1))))
+ -1
+ 1)))
+ (set-car! ls (+ (car ls) dir))
+ (let* ((offset2 (apply indexer multi-index))
+ (coeff (* dir (- offset2 offset))))
+ (cond
+ ((> count 0)
+ (and (= coeff (vector-ref res i))
+ (lp (+ i 1) (cdr ls) offset2 count)))
+ (else
+ (vector-set! res i coeff)
+ (vector-set! res 0 (- (vector-ref res 0)
+ (* coeff
+ (interval-lower-bound domain (- i 1)))))
+ (lp (+ i 1) (cdr ls) offset2 count))))))))))
+
+(define (coeffs->indexer coeffs domain)
+ (case (vector-length coeffs)
+ ((2)
+ (let ((a (vector-ref coeffs 0))
+ (b (vector-ref coeffs 1)))
+ (lambda (x) (+ a (* b x)))))
+ ((3)
+ (let ((a (vector-ref coeffs 0))
+ (b (vector-ref coeffs 1))
+ (c (vector-ref coeffs 2)))
+ (lambda (x y) (+ a (* b x) (* c y)))))
+ ((4)
+ (let ((a (vector-ref coeffs 0))
+ (b (vector-ref coeffs 1))
+ (c (vector-ref coeffs 2))
+ (d (vector-ref coeffs 3)))
+ (lambda (x y z) (+ a (* b x) (* c y) (* d z)))))
+ (else
+ (lambda multi-index
+ (let ((lim (vector-length coeffs)))
+ (let lp ((ls multi-index)
+ (i 1)
+ (res (vector-ref coeffs 0)))
+ (cond
+ ((null? ls)
+ (if (< i lim)
+ (error "multi-index too short for domain" multi-index domain)
+ res))
+ ((>= i lim)
+ (error "multi-index too long for domain" multi-index domain))
+ (else
+ (lp (cdr ls)
+ (+ i 1)
+ (+ res (* (car ls) (vector-ref coeffs i))))))))))))
+
+(define (default-coeffs domain)
+ (let* ((dim (interval-dimension domain))
+ (res (make-vector (+ 1 dim))))
+ (vector-set! res 0 0)
+ (vector-set! res dim 1)
+ (let lp ((i (- dim 1))
+ (scale 1))
+ (cond
+ ((< i 0)
+ res)
+ ((= (+ 1 (interval-lower-bound domain i))
+ (interval-upper-bound domain i))
+ (vector-set! res (+ i 1) 0)
+ (lp (- i 1) scale))
+ (else
+ (let ((coeff (* scale (- (interval-upper-bound domain i)
+ (interval-lower-bound domain i)))))
+ (vector-set! res (+ i 1) scale)
+ (vector-set! res 0 (- (vector-ref res 0)
+ (* scale (interval-lower-bound domain i))))
+ (lp (- i 1) coeff)))))))
+
+(define (default-indexer domain)
+ (coeffs->indexer (default-coeffs domain) domain))
+
+;; Converts the raw integer index to the multi-index in domain that
+;; would map to it using the default indexer (i.e. iterating over the
+;; possible multi-indices in domain in lexicographic order would
+;; produce 0 through volume-1).
+(define (invert-default-index domain raw-index)
+ (let lp ((index raw-index)
+ (i 0)
+ (scale (/ (interval-volume domain)
+ (max 1
+ (- (interval-upper-bound domain 0)
+ (interval-lower-bound domain 0)))))
+ (res '()))
+ (cond
+ ((>= (+ i 1) (interval-dimension domain))
+ (reverse (cons (+ index (interval-lower-bound domain i)) res)))
+ (else
+ (let ((digit (quotient index scale)))
+ (lp (- index (* digit scale))
+ (+ i 1)
+ (/ scale
+ (max 1
+ (- (interval-upper-bound domain (+ i 1))
+ (interval-lower-bound domain (+ i 1)))))
+ (cons (+ digit
+ (interval-lower-bound domain i))
+ res)))))))
+
+;; Specialized arrays
+
+(define (%make-specialized domain storage body coeffs indexer
+ safe? mutable? adjacent?)
+ (%make-array
+ domain
+ (specialized-getter body indexer (storage-class-getter storage))
+ (and mutable?
+ (specialized-setter body indexer (storage-class-setter storage)))
+ storage
+ body
+ coeffs
+ indexer
+ safe?
+ adjacent?))
+
+(define (make-specialized-array domain . o)
+ (let* ((storage (if (pair? o) (car o) generic-storage-class))
+ (safe? (if (and (pair? o) (pair? (cdr o)))
+ (cadr o)
+ (specialized-array-default-safe?)))
+ (body ((storage-class-maker storage)
+ (interval-volume domain)
+ (storage-class-default storage)))
+ (coeffs (default-coeffs domain))
+ (indexer (coeffs->indexer coeffs domain)))
+ (assert (boolean? safe?))
+ (%make-specialized domain storage body coeffs indexer safe? #t #t)))
+
+(define (specialized-array? x)
+ (and (array? x) (array-storage-class x) #t))
+
+(define (compute-array-elements-in-order? array)
+ (let ((indexer (array-indexer array)))
+ (call-with-current-continuation
+ (lambda (return)
+ (interval-fold
+ (lambda (prev . multi-index)
+ (let ((i (apply indexer multi-index)))
+ (if (and prev (not (= i (+ prev 1))))
+ (return #f)
+ i)))
+ #f
+ (array-domain array))
+ #t))))
+
+(define (array-elements-in-order? array)
+ (assert (specialized-array? array))
+ (let ((res (array-adjacent? array)))
+ (when (eq? res 'unknown)
+ (set! res (compute-array-elements-in-order? array))
+ (array-adjacent?-set! array res))
+ res))
+
+(define (specialized-array-share array new-domain project)
+ (assert (and (specialized-array? array) (interval? new-domain)))
+ (let* ((body (array-body array))
+ (coeffs
+ (indexer->coeffs
+ (lambda multi-index
+ (call-with-values
+ (lambda () (apply project multi-index))
+ (array-indexer array)))
+ new-domain))
+ (indexer
+ (coeffs->indexer coeffs new-domain))
+ (storage (array-storage-class array)))
+ (%make-specialized new-domain storage body coeffs indexer
+ (array-safe? array) (array-setter array) 'unknown)))
diff --git a/lib/srfi/179/base.sld b/lib/srfi/179/base.sld
new file mode 100644
index 00000000..2616d580
--- /dev/null
+++ b/lib/srfi/179/base.sld
@@ -0,0 +1,41 @@
+
+;;> The base array definitions of SRFI 179, plus some extra internal
+;;> bindings.
+
+(define-library (srfi 179 base)
+ (import (scheme base)
+ (scheme list)
+ (scheme vector)
+ (chibi assert))
+ (export
+ ;; Miscellaneous Functions
+ translation? permutation?
+ ;; Intervals
+ make-interval interval? interval-dimension interval-lb interval-ub
+ interval-lower-bound interval-upper-bound interval-lower-bounds->list
+ interval-upper-bounds->list interval-lower-bounds->vector
+ interval-upper-bounds->vector interval= interval-volume
+ interval-subset? interval-contains-multi-index? interval-projections
+ interval-for-each interval-dilate interval-intersect
+ interval-translate interval-permute interval-rotate
+ interval-scale interval-cartesian-product
+ ;; Indexing
+ indexer->coeffs coeffs->indexer default-indexer default-coeffs
+ invert-default-index interval-cursor interval-cursor-next!
+ interval-cursor-next interval-cursor-get interval-fold
+ ;; Storage Classes
+ make-storage-class storage-class? storage-class-getter
+ storage-class-setter storage-class-checker storage-class-maker
+ storage-class-copier storage-class-length storage-class-default
+ generic-storage-class
+ ;; Arrays
+ make-array array? array-domain array-getter array-dimension
+ mutable-array? array-setter specialized-array-default-safe?
+ specialized-array-default-mutable? make-specialized-array
+ specialized-array? array-storage-class array-indexer array-body
+ array-safe? array-coeffs array-adjacent? array-elements-in-order?
+ specialized-array-share array-ref array-set!
+ %make-specialized %array-setter-set!
+ specialized-getter specialized-setter
+ )
+ (include "base.scm"))
diff --git a/lib/srfi/179/test.sld b/lib/srfi/179/test.sld
new file mode 100644
index 00000000..e32073e1
--- /dev/null
+++ b/lib/srfi/179/test.sld
@@ -0,0 +1,3803 @@
+#|
+Adapted from original SRFI reference test suite:
+
+SRFI 179: Nonempty Intervals and Generalized Arrays (Updated)
+
+Copyright 2016, 2018, 2020 Bradley J Lucier.
+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
+(including the next paragraph) 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.
+|#
+
+;;; A test program for SRFI 179:
+;;; Nonempty Intervals and Generalized Arrays (Updated)
+
+(define-library (srfi 179 test)
+ (import (scheme base) (scheme cxr) (scheme complex)
+ (scheme file) (scheme list) (scheme read)
+ (scheme sort) (scheme vector) (scheme write)
+ (chibi test)
+ (srfi 27) (srfi 143) (srfi 144) (srfi 160 base) (srfi 179))
+ (export run-tests)
+ (begin
+ ;; Just run 1 pass of the randomized tests.
+ ;; TODO: remove all randomized tests.
+ (define tests 1)
+
+ (define (random a . b)
+ (if (pair? b)
+ (+ a (random-integer (- (car b) a)))
+ (random-integer a)))
+
+ (define (random-sample n . o)
+ (let ((l (if (pair? o) (car o) 4)))
+ (list->vector (map (lambda (i)
+ (random 1 l))
+ (iota n)))))
+
+ (define (random-f64vector n)
+ (let ((res (make-f64vector n)))
+ (do ((i 0 (+ i 1)))
+ ((= i n) res)
+ (f64vector-set! res i (random-real)))))
+
+ (define (f64vector->list vec)
+ (do ((i (- (f64vector-length vec) 1) (- i 1))
+ (res '() (cons (f64vector-ref vec i) res)))
+ ((< i 0) res)))
+
+ (define (random-permutation n)
+ (let ((result (make-vector n)))
+ ;; fill it
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i n))
+ (vector-set! result i i))
+ ;; permute it
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i n)
+ ;;(write `(random-permutation ,n -> ,result)) (newline)
+ result)
+ (vector-swap! result i (random i n)))))
+
+ (define (inverse-permutation permutation)
+ (list->vector
+ (map
+ car
+ (list-sort
+ (lambda (a b) (< (cdr a) (cdr b)))
+ (map cons
+ (iota (vector-length permutation))
+ (vector->list permutation))))))
+
+ (define (vector-permute v permutation)
+ (let* ((n (vector-length v))
+ (result (make-vector n)))
+ (do ((i 0 (+ i 1)))
+ ((= i n) result)
+ (vector-set! result i (vector-ref v (vector-ref permutation i))))))
+
+ (define (in-order < l)
+ (or (null? l)
+ (null? (cdr l))
+ (and (< (car l) (cadr l))
+ (in-order < (cdr l)))))
+
+ (define (local-iota a b)
+ (if (= a b)
+ '()
+ (cons a (local-iota (+ a 1) b))))
+
+ (define (all-elements lower upper)
+ (if (null? (cdr lower))
+ (map list (local-iota (car lower) (car upper)))
+ (apply append (map (lambda (x)
+ (map (lambda (y)
+ (cons x y))
+ (all-elements (cdr lower) (cdr upper))))
+ (local-iota (car lower) (car upper))))))
+
+ ;; define random-interval, random-multi-index
+
+ (define (random-multi-index interval)
+ (apply values
+ (apply map
+ random
+ (map (lambda (bounds)
+ (bounds interval))
+ (list interval-lower-bounds->list
+ interval-upper-bounds->list)))))
+
+ (define use-bignum-intervals #f)
+
+ (define (random-interval . o)
+ ;; a random interval with min <= dimension < max
+ ;; positive and negative lower bounds
+ (let* ((min (if (pair? o) (car o) 1))
+ (max (if (and (pair? o) (pair? (cdr o))) (cadr o) 4))
+ (lower
+ (map (lambda (x)
+ (if use-bignum-intervals
+ (random (- (expt 2 90)) (expt 2 90))
+ (random -10 10)))
+ (vector->list (make-vector (random min max)))))
+ (upper
+ (map (lambda (x)
+ (+ (random 1 8) x))
+ lower)))
+ (make-interval (list->vector lower)
+ (list->vector upper))))
+
+ (define (random-subinterval interval)
+ (let* ((lowers (interval-lower-bounds->vector interval))
+ (uppers (interval-upper-bounds->vector interval))
+ (new-lowers (vector-map random lowers uppers))
+ (new-uppers (vector-map (lambda (x) (+ x 1))
+ (vector-map random new-lowers uppers)))
+ (subinterval (make-interval new-lowers new-uppers)))
+ subinterval))
+
+ (define (random-nonnegative-interval . o)
+ ;; a random interval with min <= dimension < max
+ (let* ((min (if (pair? o) (car o) 1))
+ (max (if (and (pair? o) (pair? (cdr o))) (cadr o) 6))
+ (lower
+ (make-vector (random min max) 0))
+ (upper
+ (vector-map (lambda (x) (random 1 7)) lower)))
+ (make-interval lower upper)))
+
+ (define (random-positive-vector n . o)
+ (let ((max (if (pair? o) (car o) 5)))
+ (vector-map (lambda (x)
+ (random 1 max))
+ (make-vector n))))
+
+ (define (random-boolean)
+ (zero? (random 2)))
+
+ (define (array-display A)
+
+ (define (display-item x)
+ (display x) (display "\t"))
+
+ (newline)
+ (case (array-dimension A)
+ ((1) (array-for-each display-item A) (newline))
+ ((2) (array-for-each (lambda (row)
+ (array-for-each display-item row)
+ (newline))
+ (array-curry A 1)))
+ (else
+ (error "array-display can't handle > 2 dimensions: " A))))
+
+ (define (myindexer= indexer1 indexer2 interval)
+ (array-fold (lambda (x y) (and x y))
+ #t
+ (make-array interval
+ (lambda args
+ (= (apply indexer1 args)
+ (apply indexer2 args))))))
+
+ (define (my-indexer base lower-bounds increments)
+ (lambda indices
+ (apply + base (map * increments (map - indices lower-bounds)))))
+
+ (define (random-sign)
+ (- 1 (* 2 (random 2))))
+
+ (define (myarray= array1 array2)
+ (and (interval= (array-domain array1)
+ (array-domain array2))
+ (array-fold (lambda (vs result)
+ (and (equal? (car vs)
+ (cadr vs))
+ result))
+ #t
+ (array-map list array1 array2))))
+
+ (define random-storage-class-and-initializer
+ (let* ((storage-classes
+ (vector
+ ;; generic
+ (list generic-storage-class
+ (lambda args (random-permutation (length args))))
+ ;; signed integer
+ (list s8-storage-class
+ (lambda args (random (- (expt 2 7)) (- (expt 2 7) 1))))
+ (list s16-storage-class
+ (lambda args (random (- (expt 2 15)) (- (expt 2 15) 1))))
+ (list s32-storage-class
+ (lambda args (random (- (expt 2 31)) (- (expt 2 31) 1))))
+ (list s64-storage-class
+ (lambda args (random (- (expt 2 63)) (- (expt 2 63) 1))))
+ ;; unsigned integer
+ (list u1-storage-class
+ (lambda args (random (expt 2 1))))
+ (list u8-storage-class
+ (lambda args (random (expt 2 8))))
+ (list u16-storage-class
+ (lambda args (random (expt 2 16))))
+ (list u32-storage-class
+ (lambda args (random (expt 2 32))))
+ (list u64-storage-class
+ (lambda args (random (expt 2 64))))
+ ;; float
+ (list f32-storage-class
+ (lambda args (random-real)))
+ (list f64-storage-class
+ (lambda args (random-real)))
+ ;; complex-float
+ (list c64-storage-class
+ (lambda args (make-rectangular (random-real) (random-real))))
+ (list c128-storage-class
+ (lambda args (make-rectangular (random-real) (random-real))))))
+ (n
+ (vector-length storage-classes)))
+ (lambda ()
+ (vector-ref storage-classes (random n)))))
+
+ ;; Elements of extracted arrays of newly created specialized
+ ;; arrays are not in order unless
+ ;; (1) the differences in the upper and lower bounds of the
+ ;; first dimensions all equal 1 *and*
+ ;; (2) the next dimension doesn't matter *and*
+ ;; (3) the upper and lower bounds of the latter dimensions
+ ;; of the original and extracted arrays are the same
+ ;; Whew!
+
+ (define (extracted-array-elements-in-order? base extracted)
+ (let ((base-domain (array-domain base))
+ (extracted-domain (array-domain extracted))
+ (dim (array-dimension base)))
+ (let loop-1 ((i 0))
+ (or (= i (- dim 1))
+ (or (and (= 1 (- (interval-upper-bound extracted-domain i)
+ (interval-lower-bound extracted-domain i)))
+ (loop-1 (+ i 1)))
+ (let loop-2 ((i (+ i 1)))
+ (or (= i dim)
+ (and (= (interval-upper-bound extracted-domain i)
+ (interval-upper-bound base-domain i))
+ (= (interval-lower-bound extracted-domain i)
+ (interval-lower-bound base-domain i))
+ (loop-2 (+ i 1))))))))))
+
+
+ ;; A permuted array has elements in order iff all the dimensions with
+ ;; sidelength > 1 are in the same order.
+ (define (permuted-array-elements-in-order? array permutation)
+ (let* ((domain
+ (array-domain array))
+ (axes-and-limits
+ (vector-map list
+ (list->vector (iota (vector-length permutation)))
+ (interval-lower-bounds->vector domain)
+ (interval-upper-bounds->vector domain)))
+ (permuted-axes-and-limits
+ (vector->list (vector-permute axes-and-limits permutation))))
+ (in-order (lambda (x y)
+ (< (car x) (car y)))
+ (filter (lambda (l)
+ (let ((i (car l))
+ (l (cadr l))
+ (u (caddr l)))
+ (< 1 (- u l))))
+ permuted-axes-and-limits))))
+
+ ;; a sampled array has elements in order iff after a string of
+ ;; dimensions with side-length 1 at the beginning, all the rest
+ ;; of the dimensions have sidelengths the same as the original
+ (define (sampled-array-elements-in-order? base scales)
+ (let* ((domain
+ (array-domain base))
+ (sampled-base
+ (array-sample base scales))
+ (scaled-domain
+ (array-domain sampled-base))
+ (base-sidelengths
+ (vector->list
+ (vector-map -
+ (interval-upper-bounds->vector domain)
+ (interval-lower-bounds->vector domain))))
+ (scaled-sidelengths
+ (vector->list
+ (vector-map -
+ (interval-upper-bounds->vector scaled-domain)
+ (interval-lower-bounds->vector scaled-domain)))))
+ (let loop-1 ((base-lengths base-sidelengths)
+ (scaled-lengths scaled-sidelengths))
+ (or (null? base-lengths)
+ (if (= (car scaled-lengths) 1)
+ (loop-1 (cdr base-lengths)
+ (cdr scaled-lengths))
+ (let loop-2 ((base-lengths base-lengths)
+ (scaled-lengths scaled-lengths))
+ (or (null? base-lengths)
+ (and (= (car base-lengths) (car scaled-lengths))
+ (loop-2 (cdr base-lengths)
+ (cdr scaled-lengths))))))))))
+
+ (define (multi-index< ind1 ind2)
+ (and (not (null? ind1))
+ (not (null? ind2))
+ (or (< (car ind1)
+ (car ind2))
+ (and (= (car ind1)
+ (car ind2))
+ (multi-index< (cdr ind1)
+ (cdr ind2))))))
+
+ (define (indices-in-proper-order l)
+ (or (null? l)
+ (null? (cdr l))
+ (and (multi-index< (car l)
+ (cadr l))
+ (indices-in-proper-order (cdr l)))))
+
+ ;; OK, how to test array-reduce?
+
+ ;; Well, we take an associative, non-commutative operation,
+ ;; multiplying 2x2 matrices, with data such that doing operations
+ ;; in the opposite order gives the wrong answer, doing it for the
+ ;; wrong interval (e.g., swapping axes) gives the wrong answer.
+
+ ;; This is not in the same style as the other tests, which use random
+ ;; data to a great extent, but I couldn't see how to choose random
+ ;; data that would satisfy the constraints.
+
+ (define matrix vector)
+
+ (define (x2x2-multiply A B)
+ (let ((a_11 (vector-ref A 0)) (a_12 (vector-ref A 1))
+ (a_21 (vector-ref A 2)) (a_22 (vector-ref A 3))
+ (b_11 (vector-ref B 0)) (b_12 (vector-ref B 1))
+ (b_21 (vector-ref B 2)) (b_22 (vector-ref B 3)))
+ (vector (+ (* a_11 b_11) (* a_12 b_21))
+ (+ (* a_11 b_12) (* a_12 b_22))
+ (+ (* a_21 b_11) (* a_22 b_21))
+ (+ (* a_21 b_12) (* a_22 b_22)))))
+
+ (define (my-array-translate Array translation)
+ (let* ((array-copy (array-copy Array))
+ (getter (array-getter array-copy))
+ (setter (array-setter array-copy)))
+ (make-array (interval-translate (array-domain Array)
+ translation)
+ (lambda args
+ (apply getter
+ (map - args (vector->list translation))))
+ (lambda (v . args)
+ (apply setter
+ v
+ (map - args (vector->list translation)))))))
+
+ (define (my-array-permute Array permutation)
+ (let* ((array-copy (array-copy Array))
+ (getter (array-getter array-copy))
+ (setter (array-setter array-copy))
+ (permutation-inverse (inverse-permutation permutation)))
+ (make-array (interval-permute (array-domain Array)
+ permutation)
+ (lambda args
+ (apply getter
+ (vector->list
+ (vector-permute (list->vector args)
+ permutation-inverse))))
+ (lambda (v . args)
+ (apply setter
+ v
+ (vector->list
+ (vector-permute (list->vector args)
+ permutation-inverse)))))))
+
+ (define (my-interval-intersect . args)
+ (define (fold-left operator ;; called with (op result-so-far (car list))
+ initial-value
+ list)
+ (if (null? list)
+ initial-value
+ (fold-left operator
+ (operator initial-value (car list))
+ (cdr list))))
+ (let ((new-uppers
+ (let ((uppers (map interval-upper-bounds->vector args)))
+ (fold-left (lambda (arg result)
+ (vector-map min arg result))
+ (car uppers)
+ uppers)))
+ (new-lowers (let ((lowers (map interval-lower-bounds->vector args)))
+ (fold-left (lambda (arg result)
+ (vector-map max arg result))
+ (car lowers)
+ lowers))))
+ (and (vector-every < new-lowers new-uppers)
+ (make-interval new-lowers new-uppers))))
+
+ (define (my-interval-scale interval scales)
+ (make-interval (interval-lower-bounds->vector interval)
+ (vector-map (lambda (u s)
+ (quotient (+ u s -1) s))
+ (interval-upper-bounds->vector interval)
+ scales)))
+
+ (define sparse-array
+ (let ((domain (make-interval '#(1000000 1000000)))
+ (sparse-rows (make-vector 1000000 '())))
+ (make-array
+ domain
+ (lambda (i j)
+ (cond ((assv j (vector-ref sparse-rows i))
+ => cdr)
+ (else
+ 0.0)))
+ (lambda (v i j)
+ (cond
+ ((assv j (vector-ref sparse-rows i))
+ => (lambda (pair)
+ (set-cdr! pair v)))
+ (else
+ (vector-set! sparse-rows i (cons (cons j v)
+ (vector-ref sparse-rows i)))))))))
+
+ (define (myarray-sample array scales)
+ (let ((scales-list (vector->list scales)))
+ (cond ((specialized-array? array)
+ (specialized-array-share
+ array
+ (interval-scale (array-domain array) scales)
+ (lambda multi-index
+ (apply values (map * multi-index scales-list)))))
+ ((mutable-array? array)
+ (let ((getter (array-getter array))
+ (setter (array-setter array)))
+ (make-array
+ (interval-scale (array-domain array) scales)
+ (lambda multi-index
+ (apply getter (map * multi-index scales-list)))
+ (lambda (v . multi-index)
+ (apply setter v (map * multi-index scales-list))))))
+ (else
+ (let ((getter (array-getter array)))
+ (make-array
+ (interval-scale (array-domain array) scales)
+ (lambda multi-index
+ (apply getter (map * multi-index scales-list)))))))))
+
+ (define (ceiling-quotient x d)
+ ;; assumes x and d are positive
+ (quotient (+ x d -1) d))
+
+ (define (my-array-tile array sidelengths)
+ ;; an alternate definition more-or-less from the srfi document
+ (let* ((domain
+ (array-domain array))
+ (lowers
+ (interval-lower-bounds->vector domain))
+ (uppers
+ (interval-upper-bounds->vector domain))
+ (result-lowers
+ (vector-map (lambda (x)
+ 0)
+ lowers))
+ (result-uppers
+ (vector-map (lambda (l u s)
+ (ceiling-quotient (- u l) s))
+ lowers uppers sidelengths)))
+ (make-array
+ (make-interval result-lowers result-uppers)
+ (lambda i
+ (let* ((vec-i
+ (list->vector i))
+ (result-lowers
+ (vector-map (lambda (l i s)
+ (+ l (* i s)))
+ lowers vec-i sidelengths))
+ (result-uppers
+ (vector-map (lambda (l u i s)
+ (min u (+ l (* (+ i 1) s))))
+ lowers uppers vec-i sidelengths)))
+ (array-extract array
+ (make-interval result-lowers result-uppers)))))))
+
+ (define (myarray-reverse array flip?)
+ (let* ((flips (vector->list flip?))
+ (domain (array-domain array))
+ (lowers (interval-lower-bounds->list domain))
+ (uppers (interval-upper-bounds->list domain))
+ (transform
+ (lambda (multi-index)
+ (map (lambda (i_k l_k u_k f_k?)
+ (if f_k?
+ (- (+ u_k l_k -1) i_k)
+ i_k))
+ multi-index lowers uppers flips))))
+ (cond ((specialized-array? array)
+ (specialized-array-share
+ array
+ domain
+ (lambda multi-index
+ (apply values (transform multi-index)))))
+ ((mutable-array? array)
+ (let ((getter (array-getter array))
+ (setter (array-setter array)))
+ (make-array domain
+ (lambda multi-index
+ (apply getter (transform multi-index)))
+ (lambda (v . multi-index)
+ (apply setter v (transform multi-index))))))
+ (else
+ (let ((getter (array-getter array)))
+ (make-array domain
+ (lambda multi-index
+ (apply getter (transform multi-index)))))))))
+
+ (define (my-interval-cartesian-product . args)
+ (make-interval
+ (list->vector (apply append (map interval-lower-bounds->list args)))
+ (list->vector (apply append (map interval-upper-bounds->list args)))))
+
+ (define make-pgm cons)
+ (define pgm-greys car)
+ (define pgm-pixels cdr)
+
+ (define (read-pgm file)
+ (define (read-pgm-object port)
+ (skip-white-space port)
+ (let ((o (read port)))
+ (read-char port) ; to skip the newline or next whitespace
+ (if (eof-object? o)
+ (error "reached end of pgm file")
+ o)))
+ (define (skip-to-end-of-line port)
+ (let loop ((ch (read-char port)))
+ (if (not (eq? ch #\newline))
+ (loop (read-char port)))))
+ (define (white-space? ch)
+ (case ch
+ ((#\newline #\space #\tab) #t)
+ (else #f)))
+ (define (skip-white-space port)
+ (let ((ch (peek-char port)))
+ (cond ((white-space? ch) (read-char port) (skip-white-space port))
+ ((eq? ch #\#) (skip-to-end-of-line port)(skip-white-space port))
+ (else #f))))
+ (call-with-input-file file
+ (lambda (port)
+ ;; We're going to read text for a while,
+ ;; then switch to binary.
+ ;; So we need to turn off buffering until
+ ;; we switch to binary.
+ ;;(port-settings-set! port '(buffering: #f))
+ (let* ((header (read-pgm-object port))
+ (columns (read-pgm-object port))
+ (rows (read-pgm-object port))
+ (greys (read-pgm-object port)))
+
+ ;; now we switch back to buffering
+ ;; to speed things up
+ ;; (port-settings-set! port '(buffering: #t))
+ (make-pgm greys
+ (array-copy
+ (make-array
+ (make-interval (vector rows columns))
+ (cond ((or (eq? header 'p5) ;; pgm binary
+ (eq? header 'P5))
+ (if (< greys 256)
+ (lambda (i j) ;; one byte/pixel
+ (char->integer (read-char port)))
+ (lambda (i j) ;; two bytes/pixel, little-endian
+ (let* ((first-byte
+ (char->integer (read-char port)))
+ (second-byte
+ (char->integer (read-char port))))
+ (+ (* second-byte 256) first-byte)))))
+ ((or (eq? header 'p2) ;; pgm ascii
+ (eq? header 'P2))
+ (lambda (i j)
+ (read port)))
+ (else
+ (error "read-pgm: not a pgm file"))))))))))
+
+ (define (write-pgm pgm-data file . force-ascii)
+ (call-with-output-file file
+ (lambda (port)
+ (let* ((greys
+ (pgm-greys pgm-data))
+ (pgm-array
+ (pgm-pixels pgm-data))
+ (domain
+ (array-domain pgm-array))
+ (rows
+ (fx- (interval-upper-bound domain 0)
+ (interval-lower-bound domain 0)))
+ (columns
+ (fx- (interval-upper-bound domain 1)
+ (interval-lower-bound domain 1))))
+ (if (and (pair? force-ascii) (car force-ascii))
+ (display "P2" port)
+ (display "P5" port))
+ (newline port)
+ (display columns port) (display " " port)
+ (display rows port) (newline port)
+ (display greys port) (newline port)
+ (array-for-each
+ (if (and (pair? force-ascii) (car force-ascii))
+ (let ((next-pixel-in-line 1))
+ (lambda (p)
+ (write p port)
+ (if (fxzero? (fxand next-pixel-in-line 15))
+ (begin
+ (newline port)
+ (set! next-pixel-in-line 1))
+ (begin
+ (display " " port)
+ (set! next-pixel-in-line
+ (fx+ 1 next-pixel-in-line))))))
+ (if (fx<? greys 256)
+ (lambda (p)
+ (write-u8 p port))
+ (lambda (p)
+ (write-u8 (fxand p 255) port)
+ (write-u8 (fxarithmetic-shift-right p 8) port))))
+ pgm-array)))))
+
+ ;;(define test-pgm (read-pgm "girl.pgm"))
+
+ (define (array-dot-product a b)
+ (array-fold (lambda (x y)
+ (+ x y))
+ 0
+ (array-map
+ (lambda (x y)
+ (* x y))
+ a b)))
+
+ (define (array-convolve source filter)
+ (let* ((source-domain
+ (array-domain source))
+ (S_
+ (array-getter source))
+ (filter-domain
+ (array-domain filter))
+ (F_
+ (array-getter filter))
+ (result-domain
+ (interval-dilate
+ source-domain
+ ;; left bound of an interval is an equality,
+ ;; right bound is an inequality, hence the
+ ;; the difference in the following two expressions
+ (vector-map -
+ (interval-lower-bounds->vector filter-domain))
+ (vector-map (lambda (x)
+ (- 1 x))
+ (interval-upper-bounds->vector filter-domain)))))
+ (make-array
+ result-domain
+ (lambda (i j)
+ (array-fold
+ (lambda (p q)
+ (+ p q))
+ 0
+ (make-array
+ filter-domain
+ (lambda (k l)
+ (* (S_ (+ i k)
+ (+ j l))
+ (F_ k l)))))))))
+
+ ;; (define sharpen-filter
+ ;; (list->array
+ ;; '(0 -1 0
+ ;; -1 5 -1
+ ;; 0 -1 0)
+ ;; (make-interval '#(-1 -1) '#(2 2))))
+
+ ;; (define edge-filter
+ ;; (list->array
+ ;; '(0 -1 0
+ ;; -1 4 -1
+ ;; 0 -1 0)
+ ;; (make-interval '#(-1 -1) '#(2 2))))
+
+ (define (round-and-clip pixel max-grey)
+ (max 0 (min (exact (round pixel)) max-grey)))
+
+ (define (array-sum a)
+ (array-fold + 0 a))
+ (define (array-max a)
+ (array-fold max -inf.0 a))
+
+ (define (max-norm a)
+ (array-max (array-map abs a)))
+ (define (one-norm a)
+ (array-sum (array-map abs a)))
+
+ (define (operator-max-norm a)
+ (max-norm (array-map one-norm (array-curry (array-permute a '#(1 0)) 1))))
+ (define (operator-one-norm a)
+ ;; The "permutation" to apply here is the identity, so we omit it.
+ (max-norm (array-map one-norm (array-curry a 1))))
+
+ (define (make-separable-transform ~1D-transform)
+ (lambda (a)
+ (let ((n (array-dimension a)))
+ (do ((d 0 (fx+ d 1)))
+ ((fx=? d n))
+ (array-for-each
+ ~1D-transform
+ (array-curry (array-rotate a d) 1))))))
+
+ (define (recursively-apply-transform-and-downsample transform)
+ (lambda (a)
+ (let ((sample-vector (make-vector (array-dimension a) 2)))
+ (define (helper a)
+ (if (fx<? 1 (interval-upper-bound (array-domain a) 0))
+ (begin
+ (transform a)
+ (helper (array-sample a sample-vector)))))
+ (helper a))))
+
+ (define (recursively-downsample-and-apply-transform transform)
+ (lambda (a)
+ (let ((sample-vector (make-vector (array-dimension a) 2)))
+ (define (helper a)
+ (if (fx<? 1 (interval-upper-bound (array-domain a) 0))
+ (begin
+ (helper (array-sample a sample-vector))
+ (transform a))))
+ (helper a))))
+
+ (define (~1D-Haar-loop a)
+ (let ((a_ (array-getter a))
+ (a! (array-setter a))
+ (n (interval-upper-bound (array-domain a) 0)))
+ (do ((i 0 (fx+ i 2)))
+ ((fx=? i n))
+ (let* ((a_i (a_ i))
+ (a_i+1 (a_ (fx+ i 1)))
+ (scaled-sum (fl/ (fl+ a_i a_i+1) (flsqrt 2.0)))
+ (scaled-difference (fl/ (fl- a_i a_i+1) (flsqrt 2.0))))
+ (a! scaled-sum i)
+ (a! scaled-difference (fx+ i 1))))))
+
+ (define ~1D-Haar-transform
+ (recursively-apply-transform-and-downsample ~1D-Haar-loop))
+
+ (define ~1D-Haar-inverse-transform
+ (recursively-downsample-and-apply-transform ~1D-Haar-loop))
+
+ (define hyperbolic-Haar-transform
+ (make-separable-transform ~1D-Haar-transform))
+
+ (define hyperbolic-Haar-inverse-transform
+ (make-separable-transform ~1D-Haar-inverse-transform))
+
+ (define Haar-transform
+ (recursively-apply-transform-and-downsample
+ (make-separable-transform ~1D-Haar-loop)))
+
+ (define Haar-inverse-transform
+ (recursively-downsample-and-apply-transform
+ (make-separable-transform ~1D-Haar-loop)))
+
+ (define (LU-decomposition A)
+ ;; Assumes the domain of A is [0,n)\\times [0,n)
+ ;; and that Gaussian elimination can be applied
+ ;; without pivoting.
+ (let ((n
+ (interval-upper-bound (array-domain A) 0))
+ (A_
+ (array-getter A)))
+ (do ((i 0 (fx+ i 1)))
+ ((= i (fx- n 1)) A)
+ (let* ((pivot
+ (A_ i i))
+ (column/row-domain
+ ;; both will be one-dimensional
+ (make-interval (vector (+ i 1))
+ (vector n)))
+ (column
+ ;; the column below the (i,i) entry
+ (specialized-array-share A
+ column/row-domain
+ (lambda (k)
+ (values k i))))
+ (row
+ ;; the row to the right of the (i,i) entry
+ (specialized-array-share A
+ column/row-domain
+ (lambda (k)
+ (values i k))))
+ ;; the subarray to the right and
+ ;;below the (i,i) entry
+ (subarray
+ (array-extract
+ A (make-interval
+ (vector (fx+ i 1) (fx+ i 1))
+ (vector n n)))))
+ ;; compute multipliers
+ (array-assign!
+ column
+ (array-map (lambda (x)
+ (/ x pivot))
+ column))
+ ;; subtract the outer product of i'th
+ ;; row and column from the subarray
+ (array-assign!
+ subarray
+ (array-map -
+ subarray
+ (array-outer-product * column row)))))))
+
+ ;; We'll define a brief, not-very-efficient matrix multiply routine.
+ (define (matrix-multiply a b)
+ (let ((a-rows
+ ;; We copy this array because its elements are accessed
+ ;; multiple times.
+ (array-copy (array-curry a 1)))
+ (b-columns
+ ;; We copy this array because its elements are accessed
+ ;; multiple times.
+ (array-copy (array-curry (array-rotate b 1) 1))))
+ (array-outer-product array-dot-product a-rows b-columns)))
+
+ (define (inner-product A f g B)
+ (array-outer-product
+ (lambda (a b)
+ (array-reduce f (array-map g a b)))
+ (array-copy (array-curry A 1))
+ (array-copy (array-curry (array-rotate B 1) 1))))
+
+ (define (x2x2-matrix-multiply-into! A B C)
+ (let ((C! (array-setter C))
+ (A_ (array-getter A))
+ (B_ (array-getter B)))
+ (C! (+ (* (A_ 0 0) (B_ 0 0))
+ (* (A_ 0 1) (B_ 1 0)))
+ 0 0)
+ (C! (+ (* (A_ 0 0) (B_ 0 1))
+ (* (A_ 0 1) (B_ 1 1)))
+ 0 1)
+ (C! (+ (* (A_ 1 0) (B_ 0 0))
+ (* (A_ 1 1) (B_ 1 0)))
+ 1 0)
+ (C! (+ (* (A_ 1 0) (B_ 0 1))
+ (* (A_ 1 1) (B_ 1 1)))
+ 1 1)))
+
+ (define (run-tests)
+
+ (random-source-pseudo-randomize! default-random-source 7 23)
+
+ (test-begin "srfi-179: nonempty intervals and generalized arrays")
+
+ (test-group "interval tests"
+ (test-error (make-interval 1 '#(3 4)))
+ (test-error (make-interval '#(1 1) 3))
+ (test-error (make-interval '#(1 1) '#(3)))
+ (test-error (make-interval '#() '#()))
+ (test-error (make-interval '#(1.) '#(1)))
+ (test-error (make-interval '#(1 #f) '#(1 2)))
+ (test-error (make-interval '#(1) '#(1.)))
+ (test-error (make-interval '#(1 1) '#(1 #f)))
+ (test-error (make-interval '#(1) '#(1)))
+ (test-error (make-interval '#(1 2 3) '#(4 2 6)))
+ (test-error (make-interval 1))
+ (test-error (make-interval '#()))
+ (test-error (make-interval '#(1.)))
+ (test-error (make-interval '#(-1)))
+
+ (test (make-interval '#(11111) '#(11112))
+ (make-interval '#(11111) '#(11112)))
+
+ (test (make-interval '#(1 2 3) '#(4 5 6))
+ (make-interval '#(1 2 3) '#(4 5 6)))
+
+ (test-not (interval? #t))
+
+ (test-assert (interval? (make-interval '#(1 2 3) '#(4 5 6))))
+
+ (test-error (interval-dimension 1))
+
+ (test 3
+ (interval-dimension (make-interval '#(1 2 3) '#(4 5 6))))
+
+ (test-error
+ (interval-lower-bound 1 0))
+ (test-error
+ (interval-lower-bound (make-interval '#(1 2 3) '#(4 5 6)) #f))
+ (test-error
+ (interval-lower-bound (make-interval '#(1 2 3) '#(4 5 6)) 1.))
+ (test-error
+ (interval-lower-bound (make-interval '#(1 2 3) '#(4 5 6)) -1))
+ (test-error
+ (interval-lower-bound (make-interval '#(1 2 3) '#(4 5 6)) 3))
+ (test-error
+ (interval-lower-bound (make-interval '#(1 2 3) '#(4 5 6)) 4))
+ (test-error
+ (interval-upper-bound 1 0))
+ (test-error
+ (interval-upper-bound (make-interval '#(1 2 3) '#(4 5 6)) #f))
+ (test-error
+ (interval-upper-bound (make-interval '#(1 2 3) '#(4 5 6)) 1.))
+ (test-error
+ (interval-upper-bound (make-interval '#(1 2 3) '#(4 5 6)) -1))
+ (test-error
+ (interval-upper-bound (make-interval '#(1 2 3) '#(4 5 6)) 3))
+ (test-error
+ (interval-upper-bound (make-interval '#(1 2 3) '#(4 5 6)) 4))
+ (test-error
+ (interval-lower-bounds->list 1))
+ (test-error
+ (interval-upper-bounds->list #f))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower (map (lambda (x) (random 10))
+ (vector->list (make-vector (random 1 11)))))
+ (upper (map (lambda (x) (+ (random 1 11) x))
+ lower)))
+ (let ((interval (make-interval (list->vector lower)
+ (list->vector upper)))
+ (offset (random (length lower))))
+ (test (list-ref lower offset)
+ (interval-lower-bound interval offset))
+ (test (list-ref upper offset)
+ (interval-upper-bound interval offset))
+ (test lower
+ (interval-lower-bounds->list interval))
+ (test upper
+ (interval-upper-bounds->list interval)))))
+
+ (test-error (interval-lower-bounds->vector 1))
+ (test-error (interval-upper-bounds->vector #f))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower (map (lambda (x) (random 10))
+ (vector->list (make-vector (random 1 11)))))
+ (upper (map (lambda (x) (+ (random 1 11) x))
+ lower)))
+ (let ((interval (make-interval (list->vector lower)
+ (list->vector upper)))
+ (offset (random (length lower))))
+ (test (list-ref lower offset)
+ (interval-lower-bound interval offset))
+ (test (list-ref upper offset)
+ (interval-upper-bound interval offset))
+ (test (list->vector lower)
+ (interval-lower-bounds->vector interval))
+ (test (list->vector upper)
+ (interval-upper-bounds->vector interval)))))
+
+ (test-error (interval-projections 1 1))
+ (test-error (interval-projections (make-interval '#(0) '#(1)) #t))
+ (test-error (interval-projections (make-interval '#(0 0) '#(1 1)) 1/2))
+ (test-error (interval-projections (make-interval '#(0 0) '#(1 1)) 1.))
+ (test-error (interval-projections (make-interval '#(0 0) '#(1 1)) 0))
+ (test-error (interval-projections (make-interval '#(0 0) '#(1 1)) 2))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower (map (lambda (x) (random 10))
+ (vector->list (make-vector (random 3 11)))))
+ (upper (map (lambda (x) (+ (random 1 11) x))
+ lower))
+ (left-dimension (random 1 (- (length lower) 1)))
+ (right-dimension (- (length lower) left-dimension)))
+ (test-values
+ (interval-projections (make-interval (list->vector lower)
+ (list->vector upper))
+ right-dimension)
+ (values
+ (make-interval (list->vector (take lower right-dimension))
+ (list->vector (take upper right-dimension)))
+ (make-interval (list->vector (drop lower right-dimension))
+ (list->vector (drop upper right-dimension))))
+ )))
+
+ (test-error (interval-volume #f))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower (map (lambda (x) (random 10))
+ (vector->list (make-vector (random 1 11)))))
+ (upper (map (lambda (x) (+ (random 1 11) x))
+ lower)))
+ (test (apply * (map - upper lower))
+ (interval-volume (make-interval (list->vector lower)
+ (list->vector upper))))))
+
+ (test-error (interval= #f (make-interval '#(1 2 3) '#(4 5 6))))
+ (test-error (interval= (make-interval '#(1 2 3) '#(4 5 6)) #f))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower1 (map (lambda (x) (random 2))
+ (vector->list (make-vector (random 1 6)))))
+ (upper1 (map (lambda (x) (+ (random 1 3) x)) lower1))
+ (lower2 (map (lambda (x) (random 2)) lower1))
+ (upper2 (map (lambda (x) (+ 1 (random 1 3) x)) lower2)))
+ (test (and (equal? lower1 lower2) ; prob ~1/16
+ (equal? upper1 upper2))
+ (interval= (make-interval (list->vector lower1)
+ (list->vector upper1))
+ (make-interval (list->vector lower2)
+ (list->vector upper2))))))
+
+ (test-error (interval-subset? #f (make-interval '#(1 2 3) '#(4 5 6))))
+ (test-error (interval-subset? (make-interval '#(1 2 3) '#(4 5 6)) #f))
+ (test-error (interval-subset? (make-interval '#(1) '#(2))
+ (make-interval '#(0 0) '#(1 2))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower1 (map (lambda (x) (random 2))
+ (vector->list (make-vector (random 1 6)))))
+ (upper1 (map (lambda (x) (+ (random 1 3) x)) lower1))
+ (lower2 (map (lambda (x) (random 2)) lower1))
+ (upper2 (map (lambda (x) (+ (random 1 3) x)) lower2)))
+ (test (and (every (lambda (x) (>= (car x) (cdr x)))
+ (map cons lower1 lower2))
+ (every (lambda (x) (<= (car x) (cdr x)))
+ (map cons upper1 upper2)))
+ (interval-subset? (make-interval (list->vector lower1)
+ (list->vector upper1))
+ (make-interval (list->vector lower2)
+ (list->vector upper2))))))
+
+ (test-error (interval-contains-multi-index? 1 1))
+ (test-error (interval-contains-multi-index?
+ (make-interval '#(1 2 3) '#(4 5 6)) 1))
+ (test-error (interval-contains-multi-index?
+ (make-interval '#(1 2 3) '#(4 5 6)) 1 1/2 0.1))
+
+ (let ((interval (make-interval '#(1 2 3) '#(4 5 6)))
+ (interval-2 (make-interval '#(10 11 12) '#(13 14 15))))
+ (test-assert
+ (array-every
+ (lambda (x)
+ (apply interval-contains-multi-index? interval x))
+ (make-array interval list)))
+ (test-assert
+ (array-every
+ (lambda (x)
+ (not (apply interval-contains-multi-index? interval x)))
+ (make-array interval-2 list))))
+
+ (test-error (interval-for-each (lambda (x) x) 1))
+ (test-error (interval-for-each 1 (make-interval '#(3) '#(4))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((lower (map (lambda (x) (random 10))
+ (vector->list (make-vector (random 1 7)))))
+ (upper (map (lambda (x) (+ (random 1 4) x))
+ lower)))
+ (let ((result '()))
+ (define (f . args)
+ (set! result (cons args result)))
+ (test (reverse (all-elements lower upper))
+ (begin
+ (interval-for-each f
+ (make-interval (list->vector lower)
+ (list->vector upper)))
+ result)))))
+
+ (let ((interval (make-interval '#(0 0) '#(100 100))))
+ (test-error (interval-dilate interval 'a '#(-10 10)))
+ (test-error (interval-dilate 'a '#(10 10) '#(-10 -10)))
+ (test-error (interval-dilate interval '#(10 10) 'a))
+ (test-error (interval-dilate interval '#(10) '#(-10 -10)))
+ (test-error (interval-dilate interval '#(10 10) '#( -10)))
+ (test-error (interval-dilate interval '#(100 100) '#(-100 -100))))
+ )
+
+ (test-group "basic"
+ (test-error (make-array 1 values))
+ (test-error (make-array (make-interval '#(3) '#(4)) 1))
+
+ ;; (let ((getter (lambda args 1.)))
+ ;; (test (make-array (make-interval '#(3) '#(4)) getter)
+ ;; (make-%%array (make-interval '#(3) '#(4))
+ ;; getter
+ ;; #f
+ ;; #f
+ ;; #f
+ ;; #f
+ ;; #f
+ ;; %%order-unknown)))
+
+ (test-error (array-domain #f))
+ (test-error (array-getter #f))
+
+ (let* ((getter (lambda args 1.))
+ (array (make-array (make-interval '#(3) '#(4)) getter)))
+ (test-not (array? #f))
+ (test-assert (array? array))
+ (test (make-interval '#(3) '#(4))
+ (array-domain array))
+ (test getter
+ (array-getter array)))
+
+ ;; (let ((result #f))
+ ;; (let ((getter (lambda (i) result))
+ ;; (setter (lambda (v i) (set! result v)))
+ ;; (domain (make-interval '#(3) '#(4))))
+ ;; (test (make-array domain
+ ;; getter
+ ;; setter)
+ ;; (make-%%array domain
+ ;; getter
+ ;; setter
+ ;; #f
+ ;; #f
+ ;; #f
+ ;; #f
+ ;; %%order-unknown))))
+
+ (test-error (array-setter #f))
+
+ (let ((result (cons #f #f)))
+ (let ((getter (lambda (i) (car result)))
+ (setter (lambda (v i) (set-car! result v)))
+ (domain (make-interval '#(3) '#(4))))
+ (let ((array (make-array domain
+ getter
+ setter)))
+ (test-assert (array? array))
+ (test-assert (mutable-array? array))
+ (test-not (mutable-array? 1))
+ (test setter
+ (array-setter array))
+ (test getter
+ (array-getter array))
+ (test domain
+ (array-domain array)))))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((lower-bounds
+ ;; (map (lambda (x) (random 2))
+ ;; (vector->list (make-vector (random 1 7)))))
+ ;; (upper-bounds
+ ;; (map (lambda (x) (+ x (random 1 3)))
+ ;; lower-bounds))
+ ;; (new-domain
+ ;; (make-interval (list->vector lower-bounds)
+ ;; (list->vector upper-bounds)))
+ ;; (new-domain-dimension
+ ;; (interval-dimension new-domain))
+ ;; (old-domain-dimension
+ ;; (random 1 7))
+ ;; (base
+ ;; (random 100))
+ ;; (coefficients
+ ;; (map (lambda (x) (* (random-sign)
+ ;; (random 20)))
+ ;; (local-iota 0 old-domain-dimension)))
+ ;; (old-indexer
+ ;; (lambda args
+ ;; (apply + base (map * args coefficients))))
+ ;; (new-domain->old-domain-coefficients
+ ;; (map (lambda (x)
+ ;; (map (lambda (x) (* (random-sign) (random 10)))
+ ;; (local-iota 0 new-domain-dimension)))
+ ;; (local-iota 0 old-domain-dimension)))
+ ;; (new-domain->old-domain
+ ;; (lambda args
+ ;; (apply values (map (lambda (row)
+ ;; (apply + (map * row args)))
+ ;; new-domain->old-domain-coefficients)))))
+ ;; (if (not (and (myindexer=
+ ;; (lambda args
+ ;; (call-with-values
+ ;; (lambda () (apply new-domain->old-domain args))
+ ;; old-indexer))
+ ;; (%%compose-indexers old-indexer new-domain
+ ;; new-domain->old-domain)
+ ;; new-domain)))
+ ;; (error (list new-domain
+ ;; old-domain-dimension
+ ;; base
+ ;; coefficients
+ ;; new-domain->old-domain-coefficients))
+ ;; )))
+
+ ;; errors are not required to signal
+ ;; (let ((a (make-array (make-interval '#(0 0) '#(1 1)) ;; not valid
+ ;; values
+ ;; values)))
+ ;; (test-error (array-body a))
+ ;; (test-error (array-indexer a))
+ ;; (test-error (array-storage-class a))
+ ;; (test-error (array-safe? a)))
+
+ (test-error (make-specialized-array 'a))
+ (test-error (make-specialized-array (make-interval '#(0) '#(10)) 'a))
+ (test-error (make-specialized-array
+ (make-interval '#(0) '#(10))
+ generic-storage-class
+ 'a))
+
+ ;; We'll use specialized arrays with u1-storage-class---we never
+ ;; use the array contents, just the indexers, and it saves storage.
+
+ (test-error (array-elements-in-order? 1))
+ (test-error (array-elements-in-order?
+ (make-array (make-interval '#(1 2)) list)))
+ (test-error (array-elements-in-order?
+ (make-array (make-interval '#(1 2)) list list)))
+
+ ;; all these are true, we'll have to see how to screw it up later.
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let ((array
+ ;; (make-specialized-array (random-interval)
+ ;; u1-storage-class)))
+ ;; (test-assert (array-elements-in-order? array))))
+
+ (let ((array
+ (make-specialized-array (make-interval '#(0 0) '#(2 3)))))
+ (test 2 (array-dimension array))
+ (test 6 (interval-volume (array-domain array)))
+ (do ((i 0 (+ i 1)))
+ ((= i 2))
+ (do ((j 0 (+ j 1)))
+ ((= j 3))
+ (array-set! array (+ j (* i 3)) i j)
+ (test (+ j (* i 3))
+ (array-ref array i j)))))
+
+ (let ((array
+ (make-specialized-array (make-interval '#(-2 -1 3) '#(0 2 5)))))
+ (test 3 (array-dimension array))
+ (test 12 (interval-volume (array-domain array)))
+ (do ((i -2 (+ i 1)))
+ ((= i 0))
+ (do ((j -1 (+ j 1)))
+ ((= j 2))
+ (do ((k 3 (+ k 1)))
+ ((= k 5))
+ (let ((cell (+ k (* 2 (+ j (* i 3))))))
+ (array-set! array cell i j k)
+ (test cell (array-ref array i j k)))))))
+
+ ;; the elements of curried arrays are in order
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((base
+ (make-specialized-array (random-interval 2 5)
+ u1-storage-class))
+ (curried
+ (array-curry base (random 1 (array-dimension base)))))
+ (test-assert (array-every array-elements-in-order? curried))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((base
+ (make-specialized-array (random-interval 2 6)
+ u1-storage-class))
+ (extracted
+ (array-extract base (random-subinterval (array-domain base)))))
+ (test (array-elements-in-order? extracted)
+ (extracted-array-elements-in-order? base extracted))))
+
+ ;; Should we do reversed now?
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((base
+ (make-specialized-array (random-interval)
+ u1-storage-class))
+ (domain
+ (array-domain base))
+ (reversed-dimensions
+ (vector-map (lambda args (random-boolean))
+ (make-vector (array-dimension base))))
+ (reversed
+ (array-reverse base reversed-dimensions)))
+ (test (vector-every
+ (lambda (lower upper reversed?)
+ (or (= (+ 1 lower) upper) ;; side-length 1
+ (not reversed?))) ;; dimension not reversed
+ (interval-lower-bounds->vector domain)
+ (interval-upper-bounds->vector domain)
+ reversed-dimensions)
+ (array-elements-in-order? reversed))))
+
+ ;; permutations
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((base
+ (make-specialized-array (random-interval)
+ u1-storage-class))
+ (domain
+ (array-domain base))
+ (permutation
+ (random-permutation (array-dimension base)))
+ (permuted
+ (array-permute base permutation)))
+ (test (permuted-array-elements-in-order? base permutation)
+ (array-elements-in-order? permuted))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((base
+ (make-specialized-array (random-nonnegative-interval 1 6)
+ u1-storage-class))
+ (scales
+ (random-positive-vector (array-dimension base) 4))
+ (sampled
+ (array-sample base scales)))
+ (test (sampled-array-elements-in-order? base scales)
+ (array-elements-in-order? sampled))))
+
+ ;; Now we need to test the precomputation and caching of
+ ;; array-elements-in-order?
+ ;; The only places we precompute are
+ ;; 1. after creating a new specialized array
+ ;; 2. in %%specialized-array-translate
+ ;; 3. in %%specialized-array-curry
+ ;; 4. reshaping a specialized array in place.
+ ;; So we need to check these situations.
+
+ ;; (let ((array (array-copy (make-array (make-interval '#(3 5)) list))))
+ ;; (test-assert (and (array-elements-in-order? array)
+ ;; (%%compute-array-elements-in-order?
+ ;; (%%array-domain array) (%%array-indexer array)))))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((array
+ ;; (make-specialized-array (random-nonnegative-interval)
+ ;; u8-storage-class))
+ ;; (ignore ;; compute and cache the results
+ ;; (array-elements-in-order? array))
+ ;; (sampled-array
+ ;; (array-sample array (random-sample (array-dimension array))))
+ ;; (ignore ;; compute and cache the results
+ ;; ;; possibly not in order
+ ;; (array-elements-in-order? sampled-array))
+ ;; (translated-array
+ ;; (array-translate array
+ ;; (vector-map (lambda (x) (random 10))
+ ;; (make-vector
+ ;; (array-dimension array)))))
+ ;; (translated-sampled-array
+ ;; (array-translate sampled-array
+ ;; (vector-map (lambda (x) (random 10))
+ ;; (make-vector
+ ;; (array-dimension array))))))
+ ;; (test (%%compute-array-elements-in-order?
+ ;; (%%array-domain translated-array)
+ ;; (%%array-indexer translated-array))
+ ;; (array-elements-in-order? translated-array))
+ ;; (test (%%compute-array-elements-in-order?
+ ;; (%%array-domain translated-sampled-array)
+ ;; (%%array-indexer translated-sampled-array))
+ ;; (array-elements-in-order? translated-sampled-array))))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((array
+ ;; (make-specialized-array (random-nonnegative-interval 2 4)
+ ;; u8-storage-class))
+ ;; (d-1
+ ;; (- (array-dimension array) 1))
+ ;; (ignore
+ ;; ;; compute and cache the result, in order
+ ;; (array-elements-in-order? array))
+ ;; (rotated-array
+ ;; (array-rotate array 1))
+ ;; (ignore ;; compute and cache the results
+ ;; ;; possibly not in order
+ ;; (array-elements-in-order? rotated-array))
+ ;; (sampled-array
+ ;; (array-sample array (list->vector (cons 2 (make-list d-1 1)))))
+ ;; (ignore
+ ;; ;; almost definitely not in order, but if we curry it
+ ;; ;; with dimension 1 the subarrays are in order.
+ ;; (array-elements-in-order? sampled-array))
+ ;; (curried-array
+ ;; (array-ref (array-curry array d-1)
+ ;; (interval-lower-bound (array-domain array) 0)))
+ ;; (curried-rotated-array
+ ;; (array-ref
+ ;; (array-curry rotated-array d-1)
+ ;; (interval-lower-bound (array-domain rotated-array) 0)))
+ ;; (curried-sampled-array
+ ;; (array-ref
+ ;; (array-curry sampled-array d-1)
+ ;; (interval-lower-bound (array-domain sampled-array) 0))))
+ ;; (test (%%compute-array-elements-in-order?
+ ;; (%%array-domain curried-array)
+ ;; (%%array-indexer curried-array))
+ ;; (array-elements-in-order? curried-array))
+ ;; (test (%%compute-array-elements-in-order?
+ ;; (%%array-domain curried-rotated-array)
+ ;; (%%array-indexer curried-rotated-array))
+ ;; (array-elements-in-order? curried-rotated-array))
+ ;; (test (%%compute-array-elements-in-order?
+ ;; (%%array-domain curried-sampled-array)
+ ;; (%%array-indexer curried-sampled-array))
+ ;; (array-elements-in-order? curried-sampled-array))))
+
+ ;; FIXME: array-reshape tests.
+
+ ;; error tests
+
+ ;; (test-error
+ ;; (%%move-array-elements
+ ;; (array-reverse (make-specialized-array (make-interval '#(2 2))))
+ ;; (make-array (make-interval '#(1 4)) list)
+ ;; ""))
+
+ ;; (test-error
+ ;; (%%move-array-elements
+ ;; (make-specialized-array (make-interval '#(2 2)))
+ ;; (make-array (make-interval '#(1 5)) list)
+ ;; ""))
+
+ ;; (test-error
+ ;; (%%move-array-elements
+ ;; (make-array (make-interval '#(2 2)) list list) ;; not a valid setter
+ ;; (make-array (make-interval '#(1 4)) list)
+ ;; ""))
+
+ ;; (do ((d 1 (fx+ d 1)))
+ ;; ((= d 6))
+ ;; (let* ((uppers-list
+ ;; (iota d 2))
+ ;; (domain
+ ;; (make-interval (list->vector uppers-list)))
+ ;; (reversed-domain
+ ;; (make-interval (list->vector (reverse uppers-list)))))
+ ;; (do ((i 0 (fx+ i 1)))
+ ;; ;; distribute "tests" results over five dimensions
+ ;; ((= i (quotient tests 5)))
+ ;; (let* ((storage-class-and-initializer
+ ;; (random-storage-class-and-initializer))
+ ;; (storage-class
+ ;; (car storage-class-and-initializer))
+ ;; (initializer
+ ;; (cadr storage-class-and-initializer))
+ ;; (specialized-source
+ ;; (array-copy
+ ;; (make-array domain
+ ;; (lambda args
+ ;; (initializer)))
+ ;; storage-class))
+ ;; (rotated-specialized-source
+ ;; (array-rotate specialized-source (- d 1)))
+ ;; (specialized-reversed-source
+ ;; (array-copy
+ ;; (make-array reversed-domain
+ ;; (lambda args
+ ;; (initializer)))
+ ;; storage-class))
+ ;; (specialized-destination
+ ;; (make-specialized-array domain
+ ;; storage-class))
+ ;; (specialized-reversed-destination
+ ;; (make-specialized-array reversed-domain
+ ;; storage-class))
+ ;; (source
+ ;; (make-array domain
+ ;; (array-getter
+ ;; (array-reverse specialized-source))))
+ ;; (destination
+ ;; (make-array (array-domain specialized-destination)
+ ;; (array-getter specialized-destination)
+ ;; (array-setter specialized-destination)))
+ ;; (rotated-specialized-source
+ ;; (array-rotate specialized-source (- d 1)))
+ ;; (rotated-source
+ ;; (array-rotate source (- d 1)))
+ ;; (reversed-source
+ ;; (make-array reversed-domain
+ ;; (array-getter specialized-reversed-source)))
+ ;; (reversed-destination
+ ;; (make-array reversed-domain
+ ;; (array-getter specialized-reversed-source)
+ ;; (array-setter specialized-reversed-source))))
+ ;; ;; specialized-to-specialized, use fast copy
+ ;; (test-error (%%move-array-elements specialized-destination
+ ;; specialized-source "test: "))
+ ;; (test-assert
+ ;; (myarray= specialized-source specialized-destination))
+ ;; ;; fast copying between specialized of the same volume
+ ;; (test-error (%%move-array-elements specialized-destination
+ ;; specialized-reversed-source
+ ;; "test: "))
+ ;; ;; copy to adjacent elements of destination, checking needed
+ ;; (test-error
+ ;; (%%move-array-elements specialized-destination source "test: "))
+ ;; (test-assert (myarray= source specialized-destination))
+ ;; ;; copy to adjacent elements of destination, no checking needed
+ ;; ;; arrays of different shapes
+ ;; (test-error (%%move-array-elements specialized-destination
+ ;; rotated-specialized-source
+ ;; "test: "))
+ ;; (test (array->list rotated-specialized-source)
+ ;; (array->list specialized-destination))
+ ;; ;; copy to adjacent elements of destination, checking needed
+ ;; ;; arrays of different shapes
+ ;; (test-error (%%move-array-elements specialized-destination
+ ;; rotated-source "test: "))
+ ;; (test (array->list rotated-source)
+ ;; (array->list specialized-destination))
+ ;; ;; copy to non-adjacent elements of destination, no
+ ;; ;; checking needed
+ ;; (test-error (%%move-array-elements
+ ;; (array-reverse specialized-destination)
+ ;; specialized-source "test: "))
+ ;; (test-assert (myarray= specialized-source
+ ;; (array-reverse specialized-destination)))
+ ;; ;; copy to non-specialized array
+ ;; (test-error (%%move-array-elements destination source "test: "))
+ ;; (test-assert (myarray= destination source))
+ ;; ))))
+
+ (test-error (array-copy #f generic-storage-class))
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ #f))
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ generic-storage-class
+ 'a))
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ generic-storage-class
+ (make-interval '#(10))))
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ generic-storage-class
+ #f
+ 'a))
+
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ generic-storage-class
+ #f
+ #f
+ 'a))
+
+ ;; We gotta make sure than the error checks work in all dimensions ...
+ (test-error (array-copy (make-array (make-interval '#(1) '#(2))
+ list)
+ u16-storage-class))
+ (test-error (array-copy (make-array (make-interval '#(1 1) '#(2 2))
+ list)
+ u16-storage-class))
+ (test-error (array-copy (make-array (make-interval '#(1 1 1) '#(2 2 2))
+ list)
+ u16-storage-class))
+ (test-error (array-copy (make-array (make-interval '#(1 1 1 1)
+ '#(2 2 2 2))
+ list)
+ u16-storage-class))
+ (test-error (array-copy (make-array (make-interval '#(1 1 1 1 1)
+ '#(2 2 2 2 2))
+ list)
+ u16-storage-class))
+ (test-error (specialized-array-default-safe? 'a))
+ (test-error (specialized-array-default-mutable? 'a))
+
+ ;; (let ((mutable-default (specialized-array-default-mutable?)))
+ ;; (specialized-array-default-mutable? #f)
+ ;; (do ((i 1 (+ i 1)))
+ ;; ((= i 6))
+ ;; (let ((A (array-copy (make-array (make-interval (make-vector i 2))
+ ;; (lambda args 10)))))
+ ;; (test-error (apply array-set! A 0 (make-list i 0)))
+ ;; (test-error (array-assign! A A))))
+ ;; (specialized-array-default-mutable? mutable-default))
+
+ (specialized-array-default-safe? #t)
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain
+ ;; (random-interval))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list domain))
+ ;; (upper-bounds
+ ;; (interval-upper-bounds->list domain))
+ ;; (array1
+ ;; (let ((alist '()))
+ ;; (make-array
+ ;; domain
+ ;; (lambda indices
+ ;; (cond ((assoc indices alist)
+ ;; => cdr)
+ ;; (else
+ ;; indices)))
+ ;; (lambda (value . indices)
+ ;; (cond ((assoc indices alist)
+ ;; =>(lambda (entry)
+ ;; (set-cdr! entry value)))
+ ;; (else
+ ;; (set! alist (cons (cons indices value)
+ ;; alist))))))))
+ ;; (array2
+ ;; (array-copy array1 generic-storage-class))
+ ;; (setter1
+ ;; (array-setter array1))
+ ;; (setter2
+ ;; (array-setter array2)))
+ ;; (do ((j 0 (+ j 1)))
+ ;; ((= j 25))
+ ;; (let ((v (random 1000))
+ ;; (indices (map random lower-bounds upper-bounds)))
+ ;; (apply setter1 v indices)
+ ;; (apply setter2 v indices)))
+ ;; (test-assert (myarray= array1 array2))
+ ;; (test-assert (myarray= (array-copy array1 generic-storage-class)
+ ;; array2))
+ ;; ))
+
+ (specialized-array-default-safe? #f)
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain
+ ;; (random-interval))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list domain))
+ ;; (upper-bounds
+ ;; (interval-upper-bounds->list domain))
+ ;; (array1
+ ;; (let ((alist '()))
+ ;; (make-array
+ ;; domain
+ ;; (lambda indices
+ ;; (cond ((assoc indices alist)
+ ;; => cdr)
+ ;; (else
+ ;; indices)))
+ ;; (lambda (value . indices)
+ ;; (cond ((assoc indices alist)
+ ;; =>(lambda (entry)
+ ;; (set-cdr! entry value)))
+ ;; (else
+ ;; (set! alist (cons (cons indices value)
+ ;; alist))))))))
+ ;; (array2
+ ;; (array-copy array1 generic-storage-class ))
+ ;; (setter1
+ ;; (array-setter array1))
+ ;; (setter2
+ ;; (array-setter array2)))
+ ;; (do ((j 0 (+ j 1)))
+ ;; ((= j 25))
+ ;; (let ((v (random 1000))
+ ;; (indices (map random lower-bounds upper-bounds)))
+ ;; (apply setter1 v indices)
+ ;; (apply setter2 v indices)))
+ ;; (test-assert (myarray= array1 array2))
+ ;; (test-assert (myarray= (array-copy array1 generic-storage-class)
+ ;; array2))
+ ;; ))
+
+ (test-error (array-map 1 #f))
+ (test-error (array-map list 1 (make-array (make-interval '#(3) '#(4))
+ list)))
+ (test-error (array-map list (make-array (make-interval '#(3) '#(4))
+ list) 1))
+ (test-error (array-map list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ (make-array (make-interval '#(3 4) '#(4 5))
+ list)))
+ (test-error (array-every 1 2))
+ (test-error (array-every list 1))
+ (test-error (array-every list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ 1))
+ (test-error (array-every list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ (make-array (make-interval '#(3 4) '#(4 5))
+ list)))
+ (test-error (array-any 1 2))
+ (test-error (array-any list 1))
+ (test-error (array-any list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ 1))
+ (test-error (array-any list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ (make-array (make-interval '#(3 4) '#(4 5))
+ list)))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((interval
+ ;; (random-nonnegative-interval 1 6))
+ ;; (n
+ ;; (interval-volume interval))
+ ;; (separator
+ ;; ;; I want to make sure that the last item is chosen at least
+ ;; ;; once for each random
+ ;; (random (max 0 (- n 10)) n))
+ ;; (indexer
+ ;; (%%interval->basic-indexer interval))
+ ;; (arguments-1
+ ;; '())
+ ;; (array-1
+ ;; (make-array
+ ;; interval
+ ;; (lambda args
+ ;; (set! arguments-1 (cons args
+ ;; arguments-1))
+ ;; (let ((index (apply indexer args)))
+ ;; (cond
+ ;; ((< index separator)
+ ;; #f)
+ ;; ((= index separator)
+ ;; 1)
+ ;; (else
+ ;; (error "The array should never be called with these args"
+ ;; interval
+ ;; separator
+ ;; args
+ ;; index)))))))
+ ;; (arguments-2
+ ;; '())
+ ;; (array-2
+ ;; (make-array
+ ;; interval
+ ;; (lambda args
+ ;; (set! arguments-2 (cons args
+ ;; arguments-2))
+ ;; (let ((index (apply indexer args)))
+ ;; (cond
+ ;; ((< index separator)
+ ;; #t)
+ ;; ((= index separator)
+ ;; #f)
+ ;; (else
+ ;; (error "The array should never be called with these args"
+ ;; interval
+ ;; separator
+ ;; args
+ ;; index))))))))
+ ;; (test 1
+ ;; (array-any values array-1))
+ ;; (test-not (array-every values array-2))
+ ;; (test-assert (indices-in-proper-order (reverse arguments-1)))
+ ;; (test-assert (indices-in-proper-order (reverse arguments-2)))
+ ;; ))
+
+ (test-error (array-fold 1 1 1))
+ (test-error (array-fold list 1 1))
+ (test-error (array-fold-right 1 1 1))
+ (test-error (array-fold-right list 1 1))
+ (test-error (array-for-each 1 #f))
+ (test-error (array-for-each list 1 (make-array (make-interval '#(3) '#(4))
+ list)))
+ (test-error (array-for-each list (make-array (make-interval '#(3) '#(4))
+ list) 1))
+ (test-error (array-for-each list
+ (make-array (make-interval '#(3) '#(4))
+ list)
+ (make-array (make-interval '#(3 4) '#(4 5))
+ list)))
+
+ (specialized-array-default-safe? #t)
+
+ ;; (let ((array-builders
+ ;; (vector
+ ;; (list u1-storage-class (lambda indices (random 0 (expt 2 1))))
+ ;; (list u8-storage-class (lambda indices (random 0 (expt 2 8))))
+ ;; (list u16-storage-class (lambda indices (random 0 (expt 2 16))))
+ ;; (list u32-storage-class (lambda indices (random 0 (expt 2 32))))
+ ;; (list u64-storage-class (lambda indices (random 0 (expt 2 64))))
+ ;; (list s8-storage-class
+ ;; (lambda indices (random (- (expt 2 7)) (expt 2 7))))
+ ;; (list s16-storage-class
+ ;; (lambda indices (random (- (expt 2 15)) (expt 2 15))))
+ ;; (list s32-storage-class
+ ;; (lambda indices (random (- (expt 2 31)) (expt 2 31))))
+ ;; (list s64-storage-class
+ ;; (lambda indices (random (- (expt 2 63)) (expt 2 63))))
+ ;; (list f32-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list f64-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list c64-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list c128-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list generic-storage-class
+ ;; (lambda indices indices)))))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain
+ ;; (random-interval))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list domain))
+ ;; (upper-bounds
+ ;; (interval-upper-bounds->list domain))
+ ;; (array-length
+ ;; (lambda (a)
+ ;; (let ((upper-bounds
+ ;; (interval-upper-bounds->list (array-domain a)))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list (array-domain a))))
+ ;; (apply * (map - upper-bounds lower-bounds)))))
+ ;; (arrays
+ ;; (map (lambda (ignore)
+ ;; (let ((array-builder
+ ;; (vector-ref array-builders
+ ;; (random
+ ;; (vector-length array-builders)))))
+ ;; (array-copy (make-array domain
+ ;; (cadr array-builder))
+ ;; (car array-builder))))
+ ;; (local-iota 0 (random 1 7))))
+ ;; (result-array-1
+ ;; (apply array-map
+ ;; list
+ ;; arrays))
+ ;; (result-array-2
+ ;; (array-copy
+ ;; (apply array-map
+ ;; list
+ ;; arrays)))
+ ;; (getters
+ ;; (map array-getter arrays))
+ ;; (result-array-3
+ ;; (make-array domain
+ ;; (lambda indices
+ ;; (map (lambda (g) (apply g indices)) getters)))))
+ ;; (test-assert
+ ;; (and (myarray= result-array-1 result-array-2)
+ ;; (myarray= result-array-2 result-array-3)
+ ;; (equal? (vector->list (array-body result-array-2))
+ ;; (reverse (array-fold (lambda (x y) (cons x y))
+ ;; '()
+ ;; result-array-2)))
+ ;; (equal? (vector->list (array-body result-array-2))
+ ;; (reverse (let ((result '()))
+ ;; (array-for-each
+ ;; (lambda (f)
+ ;; (set! result (cons f result)))
+ ;; result-array-2)
+ ;; result)))
+ ;; (equal? (map array-length arrays)
+ ;; (map (lambda (array)
+ ;; ((storage-class-length
+ ;; (array-storage-class array))
+ ;; (array-body array)))
+ ;; arrays))))
+ ;; )))
+
+ (specialized-array-default-safe? #f)
+
+ ;; (let ((array-builders
+ ;; (vector
+ ;; (list u1-storage-class (lambda indices (random (expt 2 1))))
+ ;; (list u8-storage-class (lambda indices (random (expt 2 8))))
+ ;; (list u16-storage-class (lambda indices (random (expt 2 16))))
+ ;; (list u32-storage-class (lambda indices (random (expt 2 32))))
+ ;; (list u64-storage-class (lambda indices (random (expt 2 64))))
+ ;; (list s8-storage-class
+ ;; (lambda indices (random (- (expt 2 7)) (expt 2 7))))
+ ;; (list s16-storage-class
+ ;; (lambda indices (random (- (expt 2 15)) (expt 2 15))))
+ ;; (list s32-storage-class
+ ;; (lambda indices (random (- (expt 2 31)) (expt 2 31))))
+ ;; (list s64-storage-class
+ ;; (lambda indices (random (- (expt 2 63)) (expt 2 63))))
+ ;; (list f32-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list f64-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list c64-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list c128-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list generic-storage-class (lambda indices indices)))))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain
+ ;; (random-interval))
+ ;; ;;(_ (begin (write `(domain: ,domain)) (newline)))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list domain))
+ ;; (upper-bounds
+ ;; (interval-upper-bounds->list domain))
+ ;; (arrays
+ ;; (map (lambda (ignore)
+ ;; (let ((array-builder
+ ;; (vector-ref array-builders
+ ;; (random
+ ;; (vector-length array-builders)))))
+ ;; (array-copy (make-array domain
+ ;; (cadr array-builder))
+ ;; (car array-builder))))
+ ;; (local-iota 0 (random 1 7))))
+ ;; (result-array-1
+ ;; (apply array-map
+ ;; list
+ ;; arrays))
+ ;; (result-array-2
+ ;; (array-copy
+ ;; (apply array-map
+ ;; list
+ ;; arrays)))
+ ;; (getters
+ ;; (map array-getter arrays))
+ ;; (result-array-3
+ ;; (make-array domain
+ ;; (lambda indices
+ ;; (map (lambda (g) (apply g indices)) getters)))))
+ ;; (test-assert
+ ;; (and (myarray= result-array-1 result-array-2)
+ ;; (myarray= result-array-2 result-array-3)
+ ;; (equal? (vector->list (array-body result-array-2))
+ ;; (reverse (array-fold cons
+ ;; '()
+ ;; result-array-2)))
+ ;; (equal? (vector->list (array-body result-array-2))
+ ;; (reverse (let ((result '()))
+ ;; (array-for-each
+ ;; (lambda (f)
+ ;; (set! result (cons f result)))
+ ;; result-array-2)
+ ;; result))))))))
+
+ (test-error (array-reduce 'a 'a))
+ (test-error (array-reduce 'a (make-array (make-interval '#(1) '#(3))
+ list)))
+
+ (let ((A (make-array (make-interval '#(1) '#(11))
+ (lambda (i)
+ (if (even? i)
+ (matrix 1 i
+ 0 1)
+ (matrix 1 0
+ i 1))))))
+ (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A)
+ (array-reduce x2x2-multiply A))
+ (test-not (equal? (array-reduce x2x2-multiply A)
+ (array-fold x2x2-multiply (matrix 1 0 0 1) A))))
+
+ (let ((A_2 (make-array (make-interval '#(1 1) '#(3 7))
+ (lambda (i j)
+ (if (and (even? i) (even? j))
+ (matrix 1 i
+ j 1)
+ (matrix 1 j
+ i -1))))))
+ (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_2)
+ (array-reduce x2x2-multiply A_2))
+ (test-not (equal? (array-reduce x2x2-multiply A_2)
+ (array-fold x2x2-multiply (matrix 1 0 0 1) A_2)))
+ (test-not (equal? (array-reduce x2x2-multiply A_2)
+ (array-reduce x2x2-multiply (array-rotate A_2 1)))))
+
+ (let ((A_3 (make-array (make-interval '#(1 1 1) '#(3 5 4))
+ (lambda (i j k)
+ (if (and (even? i) (even? j))
+ (matrix 1 i
+ j k)
+ (matrix k j
+ i -1))))))
+ (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_3)
+ (array-reduce x2x2-multiply A_3))
+ (test-not (equal? (array-reduce x2x2-multiply A_3)
+ (array-fold x2x2-multiply (matrix 1 0 0 1) A_3)))
+ (test-not (equal? (array-reduce x2x2-multiply A_3)
+ (array-reduce x2x2-multiply (array-rotate A_3 1)))))
+
+ (let ((A_4 (make-array (make-interval '#(1 1 1 1) '#(3 2 4 3))
+ (lambda (i j k l)
+ (if (and (even? i) (even? j))
+ (matrix l i
+ j k)
+ (matrix l k
+ i j))))))
+ (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_4)
+ (array-reduce x2x2-multiply A_4))
+ (test-not (equal? (array-reduce x2x2-multiply A_4)
+ (array-fold x2x2-multiply (matrix 1 0 0 1) A_4)))
+ (test-not (equal? (array-reduce x2x2-multiply A_4)
+ (array-reduce x2x2-multiply (array-rotate A_4 1)))))
+
+ (let ((A_5 (make-array (make-interval '#(1 1 1 1 1) '#(3 2 4 3 3))
+ (lambda (i j k l m)
+ (if (even? m)
+ (matrix (+ m l) i
+ j k)
+ (matrix (- l m) k
+ i j))))))
+ (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_5)
+ (array-reduce x2x2-multiply A_5))
+ (test-not (equal? (array-reduce x2x2-multiply A_5)
+ (array-fold x2x2-multiply (matrix 1 0 0 1) A_5)))
+ (test-not (equal? (array-reduce x2x2-multiply A_5)
+ (array-reduce x2x2-multiply (array-rotate A_5 1)))))
+
+ (test-error (array-curry 'a 1))
+ (test-error
+ (array-curry (make-array (make-interval '#(0) '#(1)) list) 'a))
+ (test-error
+ (array-curry (make-array (make-interval '#(0 0) '#(1 1)) list) 0))
+ (test-error
+ (array-curry (make-array (make-interval '#(0 0) '#(1 1)) list) 2))
+
+ ;; (let ((array-builders
+ ;; (vector
+ ;; (list u1-storage-class (lambda indices (random (expt 2 1))))
+ ;; (list u8-storage-class (lambda indices (random (expt 2 8))))
+ ;; (list u16-storage-class (lambda indices (random (expt 2 16))))
+ ;; (list u32-storage-class (lambda indices (random (expt 2 32))))
+ ;; (list u64-storage-class (lambda indices (random (expt 2 64))))
+ ;; (list s8-storage-class
+ ;; (lambda indices (random (- (expt 2 7)) (expt 2 7))))
+ ;; (list s16-storage-class
+ ;; (lambda indices (random (- (expt 2 15)) (expt 2 15))))
+ ;; (list s32-storage-class
+ ;; (lambda indices (random (- (expt 2 31)) (expt 2 31))))
+ ;; (list s64-storage-class
+ ;; (lambda indices (random (- (expt 2 63)) (expt 2 63))))
+ ;; (list f32-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list f64-storage-class
+ ;; (lambda indices (random-real)))
+ ;; (list c64-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list c128-storage-class
+ ;; (lambda indices (make-rectangular (random-real) (random-real))))
+ ;; (list generic-storage-class
+ ;; (lambda indices indices)))))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain
+ ;; (random-interval 2 7))
+ ;; (lower-bounds
+ ;; (interval-lower-bounds->list domain))
+ ;; (upper-bounds
+ ;; (interval-upper-bounds->list domain))
+ ;; (array-builder
+ ;; (vector-ref array-builders
+ ;; (random (vector-length array-builders))))
+ ;; (random-array-element
+ ;; (cadr array-builder))
+ ;; (storage-class
+ ;; (car array-builder))
+ ;; (Array
+ ;; (array-copy (make-array domain
+ ;; random-array-element)
+ ;; storage-class))
+ ;; (copied-array
+ ;; (array-copy Array
+ ;; storage-class))
+ ;; (inner-dimension
+ ;; (random 1 (interval-dimension domain)))
+ ;; (domains
+ ;; (call-with-values
+ ;; (lambda () (interval-projections domain inner-dimension))
+ ;; list))
+ ;; (outer-domain
+ ;; (car domains))
+ ;; (inner-domain
+ ;; (cadr domains))
+ ;; (immutable-curry
+ ;; (array-curry (make-array (array-domain Array)
+ ;; (array-getter Array))
+ ;; inner-dimension))
+ ;; (mutable-curry
+ ;; (array-curry (make-array (array-domain Array)
+ ;; (array-getter Array)
+ ;; (array-setter Array))
+ ;; inner-dimension))
+ ;; (specialized-curry
+ ;; (array-curry Array inner-dimension))
+ ;; (immutable-curry-from-definition
+ ;; (call-with-values
+ ;; (lambda () (interval-projections (array-domain Array)
+ ;; inner-dimension))
+ ;; (lambda (outer-interval inner-interval)
+ ;; (make-array
+ ;; outer-interval
+ ;; (lambda outer-multi-index
+ ;; (make-array
+ ;; inner-interval
+ ;; (lambda inner-multi-index
+ ;; (apply (array-getter Array)
+ ;; (append outer-multi-index
+ ;; inner-multi-index)))))))))
+ ;; (mutable-curry-from-definition
+ ;; (call-with-values
+ ;; (lambda () (interval-projections (array-domain Array)
+ ;; inner-dimension))
+ ;; (lambda (outer-interval inner-interval)
+ ;; (make-array
+ ;; outer-interval
+ ;; (lambda outer-multi-index
+ ;; (make-array
+ ;; inner-interval
+ ;; (lambda inner-multi-index
+ ;; (apply (array-getter Array)
+ ;; (append outer-multi-index
+ ;; inner-multi-index)))
+ ;; (lambda (v . inner-multi-index)
+ ;; (apply (array-setter Array) v
+ ;; (append outer-multi-index
+ ;; inner-multi-index)))))))))
+ ;; (specialized-curry-from-definition
+ ;; (call-with-values
+ ;; (lambda () (interval-projections (array-domain Array)
+ ;; inner-dimension))
+ ;; (lambda (outer-interval inner-interval)
+ ;; (make-array
+ ;; outer-interval
+ ;; (lambda outer-multi-index
+ ;; (specialized-array-share
+ ;; Array
+ ;; inner-interval
+ ;; (lambda inner-multi-index
+ ;; (apply values
+ ;; (append outer-multi-index
+ ;; inner-multi-index))))))))))
+ ;; ;; mutate the curried array
+ ;; (for-each
+ ;; (lambda (curried-array)
+ ;; (let ((outer-getter
+ ;; (array-getter curried-array)))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i 50)) ;; used to be tests, not 50, but 50 will do fine
+ ;; (call-with-values
+ ;; (lambda ()
+ ;; (random-multi-index outer-domain))
+ ;; (lambda outer-multi-index
+ ;; (let ((inner-setter
+ ;; (array-setter (apply outer-getter
+ ;; outer-multi-index))))
+ ;; (call-with-values
+ ;; (lambda ()
+ ;; (random-multi-index inner-domain))
+ ;; (lambda inner-multi-index
+ ;; (let ((new-element
+ ;; (random-array-element)))
+ ;; (apply inner-setter
+ ;; new-element
+ ;; inner-multi-index)
+ ;; ;; mutate the copied array without currying
+ ;; (apply (array-setter copied-array)
+ ;; new-element
+ ;; (append outer-multi-index
+ ;; inner-multi-index)))))))))))
+ ;; (list mutable-curry
+ ;; specialized-curry
+ ;; mutable-curry-from-definition
+ ;; specialized-curry-from-definition
+ ;; ))
+
+ ;; (and (or (myarray= Array copied-array) (error "Arggh"))
+ ;; (or (array-every array? immutable-curry) (error "Arggh"))
+ ;; (or (array-every (lambda (a) (not (mutable-array? a)))
+ ;; immutable-curry)
+ ;; (error "Arggh"))
+ ;; (or (array-every mutable-array? mutable-curry) (error "Arggh"))
+ ;; (or (array-every (lambda (a) (not (specialized-array? a)))
+ ;; mutable-curry)
+ ;; (error "Arggh"))
+ ;; (or (array-every specialized-array? specialized-curry)
+ ;; (error "Arggh"))
+ ;; (or (array-every
+ ;; (lambda (xy) (apply myarray= xy))
+ ;; (array-map list immutable-curry
+ ;; immutable-curry-from-definition))
+ ;; (error "Arggh"))
+ ;; (or (array-every
+ ;; (lambda (xy) (apply myarray= xy))
+ ;; (array-map list mutable-curry
+ ;; mutable-curry-from-definition))
+ ;; (error "Arggh"))
+ ;; (or (array-every
+ ;; (lambda (xy) (apply myarray= xy))
+ ;; (array-map list specialized-curry
+ ;; specialized-curry-from-definition))
+ ;; (error "Arggh"))))))
+
+ (test-error (specialized-array-share 1 1 1))
+ (test-error (specialized-array-share
+ (make-specialized-array (make-interval '#(1) '#(2)))
+ 1 1))
+ ;; (test-error (specialized-array-share
+ ;; (make-specialized-array (make-interval '#(1) '#(2)))
+ ;; (make-interval '#(0) '#(1))
+ ;; 1))
+
+ (test-assert
+ (myarray= (list->array (reverse (local-iota 0 10))
+ (make-interval '#(0) '#(10)))
+ (specialized-array-share
+ (list->array (local-iota 0 10)
+ (make-interval '#(0) '#(10)))
+ (make-interval '#(0) '#(10))
+ (lambda (i)
+ (- 9 i)))))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((n (random 1 11))
+ ;; (permutation (random-permutation n))
+ ;; (input-vec
+ ;; (list->vector (f64vector->list (random-f64vector n)))))
+ ;; (test (%%vector-permute input-vec permutation)
+ ;; (vector-permute input-vec permutation))
+ ;; (test (vector-permute input-vec permutation)
+ ;; (list->vector (%%vector-permute->list input-vec permutation)))))
+
+ (specialized-array-default-safe? #t)
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((interval (random-interval))
+ ;; (axes (local-iota 0 (interval-dimension interval)))
+ ;; (lower-bounds (interval-lower-bounds->vector interval))
+ ;; (upper-bounds (interval-upper-bounds->vector interval))
+ ;; (a (array-copy (make-array interval list)))
+ ;; (new-axis-order
+ ;; (vector-permute (list->vector axes)
+ ;; (random-permutation (length axes))))
+ ;; (reverse-order?
+ ;; (list->vector (map (lambda (x) (zero? (random 2))) axes))))
+ ;; (let ((b (make-array
+ ;; (make-interval (vector-permute lower-bounds new-axis-order)
+ ;; (vector-permute upper-bounds new-axis-order))
+ ;; (lambda multi-index
+ ;; (apply
+ ;; (array-getter a)
+ ;; (let* ((n (vector-length new-axis-order))
+ ;; (multi-index-vector
+ ;; (list->vector multi-index))
+ ;; (result (make-vector n)))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i n) (vector->list result))
+ ;; (vector-set!
+ ;; result
+ ;; (vector-ref new-axis-order i)
+ ;; (if (vector-ref reverse-order?
+ ;; (vector-ref new-axis-order i))
+ ;; (+ (vector-ref lower-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (- (vector-ref upper-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (vector-ref multi-index-vector i)
+ ;; 1))
+ ;; (vector-ref multi-index-vector i)))))))))
+ ;; (c (specialized-array-share
+ ;; a
+ ;; (make-interval (vector-permute lower-bounds new-axis-order)
+ ;; (vector-permute upper-bounds new-axis-order))
+ ;; (lambda multi-index
+ ;; (apply
+ ;; values
+ ;; (let* ((n (vector-length new-axis-order))
+ ;; (multi-index-vector (list->vector multi-index))
+ ;; (result (make-vector n)))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i n) (vector->list result))
+ ;; (vector-set!
+ ;; result
+ ;; (vector-ref new-axis-order i)
+ ;; (if (vector-ref reverse-order?
+ ;; (vector-ref new-axis-order i))
+ ;; (+ (vector-ref lower-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (- (vector-ref upper-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (vector-ref multi-index-vector i)
+ ;; 1))
+ ;; (vector-ref multi-index-vector i))))))))))
+ ;; (test-assert (myarray= b c)))))
+
+ (specialized-array-default-safe? #f)
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((interval (random-interval))
+ ;; (axes (local-iota 0 (interval-dimension interval)))
+ ;; (lower-bounds (interval-lower-bounds->vector interval))
+ ;; (upper-bounds (interval-upper-bounds->vector interval))
+ ;; (a (array-copy (make-array interval list)))
+ ;; (new-axis-order
+ ;; (vector-permute (list->vector axes)
+ ;; (random-permutation (length axes))))
+ ;; (reverse-order?
+ ;; (list->vector (map (lambda (x) (zero? (random 2))) axes))))
+ ;; (let ((b (make-array
+ ;; (make-interval (vector-permute lower-bounds new-axis-order)
+ ;; (vector-permute upper-bounds new-axis-order))
+ ;; (lambda multi-index
+ ;; (apply
+ ;; (array-getter a)
+ ;; (let* ((n (vector-length new-axis-order))
+ ;; (multi-index-vector (list->vector multi-index))
+ ;; (result (make-vector n)))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i n) (vector->list result))
+ ;; (vector-set!
+ ;; result
+ ;; (vector-ref new-axis-order i)
+ ;; (if (vector-ref reverse-order?
+ ;; (vector-ref new-axis-order i))
+ ;; (+ (vector-ref lower-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (- (vector-ref upper-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (vector-ref multi-index-vector i)
+ ;; 1))
+ ;; (vector-ref multi-index-vector i)))))))))
+ ;; (c (specialized-array-share
+ ;; a
+ ;; (make-interval
+ ;; (vector-permute lower-bounds new-axis-order)
+ ;; (vector-permute upper-bounds new-axis-order))
+ ;; (lambda multi-index
+ ;; (apply
+ ;; values
+ ;; (let* ((n (vector-length new-axis-order))
+ ;; (multi-index-vector (list->vector multi-index))
+ ;; (result (make-vector n)))
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i n) (vector->list result))
+ ;; (vector-set!
+ ;; result
+ ;; (vector-ref new-axis-order i)
+ ;; (if (vector-ref reverse-order?
+ ;; (vector-ref new-axis-order i))
+ ;; (+ (vector-ref lower-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (- (vector-ref upper-bounds
+ ;; (vector-ref new-axis-order i))
+ ;; (vector-ref multi-index-vector i)
+ ;; 1))
+ ;; (vector-ref multi-index-vector i))))))))))
+ ;; (test-assert (myarray= b c)))))
+
+ (let ((int (make-interval '#(0 0) '#(10 10)))
+ (translation '#(10 -2)))
+ (test-error (interval-translate 'a 10))
+ (test-error (interval-translate int 10))
+ (test-error (interval-translate int '#(a b)))
+ (test-error (interval-translate int '#(1. 2.)))
+ (test-error (interval-translate int '#(1)))
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((int (random-interval))
+ (lower-bounds (interval-lower-bounds->vector int))
+ (upper-bounds (interval-upper-bounds->vector int))
+ (translation
+ (list->vector
+ (map (lambda (x)
+ (random -10 10))
+ (local-iota 0 (vector-length lower-bounds))))))
+ (interval= (interval-translate int translation)
+ (make-interval
+ (vector-map + lower-bounds translation)
+ (vector-map + upper-bounds translation)))))
+ )
+
+ (let* ((specialized-array
+ (array-copy (make-array (make-interval '#(0 0) '#(10 12))
+ list)))
+ (mutable-array (let ((temp (array-copy specialized-array)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp))))
+ (immutable-array (make-array (array-domain mutable-array)
+ (array-getter mutable-array)))
+ (translation '#(10 -2)))
+
+ (test-error (array-translate 'a 1))
+ (test-error (array-translate immutable-array '#(1.)))
+ (test-error (array-translate immutable-array '#(0 2 3)))
+ (let ((specialized-result
+ (array-translate specialized-array translation)))
+ (test-assert (specialized-array? specialized-result)))
+ (let ((mutable-result (array-translate mutable-array translation)))
+ (test-assert (and (mutable-array? mutable-array)
+ (not (specialized-array? mutable-array))
+ (mutable-array? mutable-result)
+ (not (specialized-array? mutable-result)))))
+ (let ((immutable-result (array-translate immutable-array translation)))
+ (test-assert (and (array? immutable-array)
+ (not (mutable-array? immutable-array))
+ (array? immutable-result)
+ (not (mutable-array? immutable-result)))))
+
+ ;; (do ((i 0 (+ i 1)))
+ ;; ((= i tests))
+ ;; (let* ((domain (random-interval))
+ ;; (Array (let ((temp (make-array domain list)))
+ ;; (case (random-integer 3)
+ ;; ((0) temp)
+ ;; ((1) (array-copy temp))
+ ;; ((2) (let ((temp (array-copy temp)))
+ ;; (make-array (array-domain temp)
+ ;; (array-getter temp)
+ ;; (array-setter temp)))))))
+ ;; (translation
+ ;; (list->vector
+ ;; (map (lambda (x) (random -10 10))
+ ;; (vector->list (%%interval-lower-bounds domain))))))
+ ;; (let ((translated-array (array-translate Array translation))
+ ;; (my-translated-array (my-array-translate Array translation)))
+ ;; (if (mutable-array? Array)
+ ;; (let ((translated-domain
+ ;; (interval-translate domain translation)))
+ ;; (do ((j 0 (+ j 1)))
+ ;; ((= j 50))
+ ;; (call-with-values
+ ;; (lambda ()
+ ;; (random-multi-index translated-domain))
+ ;; (lambda multi-index
+ ;; (let ((value (random-integer 10000)))
+ ;; (apply (array-setter translated-array)
+ ;; value multi-index)
+ ;; (apply (array-setter my-translated-array)
+ ;; value multi-index)))))))
+ ;; (test-assert
+ ;; (myarray= (array-translate Array translation)
+ ;; (my-array-translate Array translation))))))
+ )
+ )
+
+ (test-group "permutation tests"
+ (let* ((specialized
+ (make-specialized-array (make-interval '#(0 0 0 0 0)
+ '#(1 1 1 1 1))))
+ (mutable (make-array (array-domain specialized)
+ (array-getter specialized)
+ (array-setter specialized)))
+ (A (array-translate mutable '#(0 0 0 0 0))))
+ (test-error ((array-getter A) 0 0))
+ (test-error ((array-setter A) 'a 0 0)))
+
+ (let ((int (make-interval '#(0 0) '#(10 10)))
+ (permutation '#(1 0)))
+ (test-error (interval-permute 'a 10))
+ (test-error (interval-permute int 10))
+ (test-error (interval-permute int '#(a b)))
+ (test-error (interval-permute int '#(1. 2.)))
+ (test-error (interval-permute int '#(10 -2)))
+ (test-error (interval-permute int '#(0)))
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((int (random-interval))
+ (lower-bounds (interval-lower-bounds->vector int))
+ (upper-bounds (interval-upper-bounds->vector int))
+ (permutation
+ (random-permutation (vector-length lower-bounds))))
+ (interval=
+ (interval-permute int permutation)
+ (make-interval (vector-permute lower-bounds permutation)
+ (vector-permute upper-bounds permutation))))))
+
+ (let* ((specialized-array
+ (array-copy (make-array (make-interval '#(0 0) '#(10 12))
+ list)))
+ (mutable-array (let ((temp (array-copy specialized-array)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp))))
+ (immutable-array (make-array (array-domain mutable-array)
+ (array-getter mutable-array)))
+ (permutation '#(1 0)))
+
+ (test-error (array-permute 'a 1))
+ (test-error (array-permute immutable-array '#(1.)))
+ (test-error (array-permute immutable-array '#(2)))
+ (test-error (array-permute immutable-array '#(0 1 2)))
+ (let ((specialized-result
+ (array-permute specialized-array permutation)))
+ (test-assert (specialized-array? specialized-result)))
+ (let ((mutable-result (array-permute mutable-array permutation)))
+ (test-assert (and (mutable-array? mutable-array)
+ (not (specialized-array? mutable-array))
+ (mutable-array? mutable-result)
+ (not (specialized-array? mutable-result)))))
+ (let ((immutable-result (array-permute immutable-array permutation)))
+ (test-assert (and (array? immutable-array)
+ (not (mutable-array? immutable-array))
+ (array? immutable-result)
+ (not (mutable-array? immutable-result)))))
+
+ (specialized-array-default-safe? #t)
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-interval))
+ (Array (let ((temp (make-array domain list)))
+ (case (random-integer 3)
+ ((0) temp)
+ ((1) (array-copy temp))
+ ((2) (let ((temp (array-copy temp)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp)))))))
+ (permutation
+ (random-permutation (interval-dimension domain))))
+ (let* ((permuted-array (array-permute Array permutation))
+ (my-permuted-array (my-array-permute Array permutation)))
+ (let ((permuted-domain (interval-permute domain permutation)))
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda ()
+ (random-multi-index permuted-domain))
+ (lambda multi-index
+ (test (apply (array-getter my-permuted-array)
+ multi-index)
+ (apply (array-getter permuted-array)
+ multi-index))))))
+ (if (mutable-array? Array)
+ (let ((permuted-domain
+ (interval-permute domain permutation)))
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda ()
+ (random-multi-index permuted-domain))
+ (lambda multi-index
+ (let ((value (random-integer 10000)))
+ (apply (array-setter permuted-array) value
+ multi-index)
+ (apply (array-setter my-permuted-array) value
+ multi-index)))))))
+ (test-assert (myarray= permuted-array
+ my-permuted-array)))))
+
+ (specialized-array-default-safe? #f)
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-interval))
+ (Array (let ((temp (make-array domain list)))
+ (case (random-integer 3)
+ ((0) temp)
+ ((1) (array-copy temp))
+ ((2) (let ((temp (array-copy temp)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp)))))))
+ (permutation
+ (random-permutation (interval-dimension domain)))
+ (permuted-array (array-permute Array permutation))
+ (my-permuted-array (my-array-permute Array permutation))
+ (permuted-domain (interval-permute domain permutation)))
+ ;;(write `(permuted: ,permuted-array my-permuted: ,my-permuted-array)) (newline)
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda () (random-multi-index permuted-domain))
+ (lambda multi-index
+ ;;(write `(multi-index: ,multi-index domain: ,permuted-domain)) (newline)
+ (test (apply (array-getter my-permuted-array) multi-index)
+ (apply (array-getter permuted-array) multi-index)))))
+ (if (mutable-array? Array)
+ (let ((permuted-domain
+ (interval-permute domain permutation)))
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda ()
+ (random-multi-index permuted-domain))
+ (lambda multi-index
+ (let ((value (random-integer 10000)))
+ (apply (array-setter permuted-array) value
+ multi-index)
+ (apply (array-setter my-permuted-array) value
+ multi-index)))))))
+ (test-assert (myarray= permuted-array
+ my-permuted-array))))
+ )
+
+ ;; because array-rotate is built using the array-permute
+ ;; infrastructure, we won't test as much
+
+ (test-error (array-rotate 1 1))
+ (test-error
+ (array-rotate (make-array (make-interval '#(0 0) '#(2 3)) list) 'a))
+ (test-error
+ (array-rotate (make-array (make-interval '#(0 0) '#(2 3)) list) 1.))
+ (test-error
+ (array-rotate (make-array (make-interval '#(0 0) '#(2 3)) list) 1/2))
+ (test-error
+ (array-rotate (make-array (make-interval '#(0 0) '#(2 3)) list) -1))
+ (test-error
+ (array-rotate (make-array (make-interval '#(0 0) '#(2 3)) list) 4))
+ (test-error (interval-rotate 1 1))
+ (test-error (interval-rotate (make-interval '#(0 0) '#(2 3)) 'a))
+ (test-error (interval-rotate (make-interval '#(0 0) '#(2 3)) 1.))
+ (test-error (interval-rotate (make-interval '#(0 0) '#(2 3)) 37))
+
+ (for-each
+ (lambda (n)
+ (let* ((upper-bounds (make-vector n 2))
+ (lower-bounds (make-vector n 0))
+ (domain (make-interval lower-bounds upper-bounds))
+ (A (array-copy (make-array domain list)))
+ (immutable-A
+ (let ((A (array-copy A))) ;; copy A
+ (make-array domain
+ (array-getter A))))
+ (mutable-A
+ (let ((A (array-copy A))) ;; copy A
+ (make-array domain
+ (array-getter A)
+ (array-setter A)))))
+ (for-each (lambda (dim)
+ (let ((permutation
+ (list->vector
+ (append
+ (local-iota dim n)
+ (local-iota 0 dim)))))
+ (let ((rA
+ (array-rotate A dim))
+ (pA
+ (array-permute A permutation)))
+ (if (not (and (specialized-array? rA)
+ (specialized-array? pA)
+ (myarray= rA pA)))
+ (error "blah rotate specialized")))
+ (let ((rA
+ (array-rotate immutable-A dim))
+ (pA
+ (array-permute immutable-A permutation)))
+ (if (not (and (array? rA)
+ (array? pA)
+ (myarray= rA pA)))
+ (error "blah rotate immutable")))
+ (let ((rA
+ (array-rotate mutable-A dim))
+ (pA
+ (array-permute mutable-A permutation)))
+ (if (not (and (mutable-array? rA)
+ (mutable-array? pA)
+ (myarray= rA pA)))
+ (error "blah rotate mutable")))
+ (test (array-domain (array-rotate mutable-A dim))
+ (interval-rotate (array-domain A) dim))))
+ (iota n))))
+ (iota 5 1))
+ )
+
+ (test-group "intersect/scale/sample"
+ (let ((a (make-interval '#(0 0) '#(10 10)))
+ (b (make-interval '#(0) '#(10)))
+ (c (make-interval '#(10 10) '#(20 20))))
+ (test-error (interval-intersect 'a))
+ (test-error (interval-intersect a 'a))
+ (test-error (interval-intersect a b)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((dimension (random 1 6))
+ (number-of-intervals (random 1 4))
+ (intervals (map (lambda (x)
+ (random-interval dimension (+ dimension 1)))
+ (local-iota 0 number-of-intervals))))
+ (test (apply interval-intersect intervals)
+ (apply my-interval-intersect intervals))))
+
+ (test-error (interval-scale 1 'a))
+ (test-error (interval-scale (make-interval '#(1) '#(2)) 'a))
+ (test-error (interval-scale (make-interval '#(0) '#(1)) 'a))
+ (test-error (interval-scale (make-interval '#(0) '#(1)) '#(a)))
+ (test-error (interval-scale (make-interval '#(0) '#(1)) '#(0)))
+ (test-error (interval-scale (make-interval '#(0) '#(1)) '#(1.)))
+ (test-error (interval-scale (make-interval '#(0) '#(1)) '#(1 2)))
+
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i tests))
+ (let* ((interval (random-nonnegative-interval))
+ (scales (random-positive-vector (interval-dimension interval))))
+ (test (my-interval-scale interval scales)
+ (interval-scale interval scales))))
+
+ (test-error (array-sample 'a 'a))
+ (test-error
+ (array-sample (make-array (make-interval '#(1) '#(2)) list) 'a))
+ (test-error
+ (array-sample (make-array (make-interval '#(0) '#(2)) list) 'a))
+ (test-error
+ (array-sample (make-array (make-interval '#(0) '#(2)) list) '#(1.)))
+ (test-error
+ (array-sample (make-array (make-interval '#(0) '#(2)) list) '#(0)))
+ (test-error
+ (array-sample (make-array (make-interval '#(0) '#(2)) list) '#(2 1)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-nonnegative-interval 1 6))
+ (Array (let ((temp (make-array domain list)))
+ (case (random-integer 3)
+ ((0) temp)
+ ((1) (array-copy temp))
+ ((2) (let ((temp (array-copy temp)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp)))))))
+ (scales (random-positive-vector (interval-dimension domain)))
+ (sampled-array (array-sample Array scales))
+ (my-sampled-array (myarray-sample Array scales)))
+
+ (if (mutable-array? Array)
+ (let ((scaled-domain (interval-scale domain scales)))
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda ()
+ (random-multi-index scaled-domain))
+ (lambda multi-index
+ (let ((value (random-integer 10000)))
+ (apply (array-setter sampled-array) value multi-index)
+ (apply (array-setter my-sampled-array) value
+ multi-index)))))))
+ (test-assert (myarray= sampled-array
+ my-sampled-array))))
+
+ (test-error
+ (array-extract (make-array (make-interval '#(0 0) '#(1 1)) list)
+ 'a))
+ (test-error (array-extract 'a (make-interval '#(0 0) '#(1 1))))
+ (test-error
+ (array-extract (make-array (make-interval '#(0 0) '#(1 1)) list)
+ (make-interval '#(0) '#(1))))
+ (test-error
+ (array-extract (make-array (make-interval '#(0 0) '#(1 1)) list)
+ (make-interval '#(0 0) '#(1 3))))
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i tests))
+ (let* ((domain (random-interval))
+ (subdomain (random-subinterval domain))
+ (spec-A (array-copy (make-array domain list)))
+ (spec-A-extract (array-extract spec-A subdomain))
+ (mut-A (let ((A-prime (array-copy spec-A)))
+ (make-array domain
+ (array-getter A-prime)
+ (array-setter A-prime))))
+ (mut-A-extract (array-extract mut-A subdomain))
+ (immutable-A (let ((A-prime (array-copy spec-A)))
+ (make-array domain
+ (array-getter A-prime))))
+ (immutable-A-extract (array-extract immutable-A subdomain))
+ (spec-B (array-copy (make-array domain list)))
+ (spec-B-extract (array-extract spec-B subdomain))
+ (mut-B (let ((B-prime (array-copy spec-B)))
+ (make-array domain
+ (array-getter B-prime)
+ (array-setter B-prime))))
+ (mut-B-extract (array-extract mut-B subdomain)))
+ ;; test that the extracts are the same kind of arrays as the original
+ (if (not (and (specialized-array? spec-A)
+ (specialized-array? spec-A-extract)
+ (mutable-array? mut-A)
+ (mutable-array? mut-A-extract)
+ (not (specialized-array? mut-A))
+ (not (specialized-array? mut-A-extract))
+ (array? immutable-A)
+ (array? immutable-A-extract)
+ (not (mutable-array? immutable-A))
+ (not (mutable-array? immutable-A-extract))
+ (equal? (array-domain spec-A-extract) subdomain)
+ (equal? (array-domain mut-A-extract) subdomain)
+ (equal? (array-domain immutable-A-extract) subdomain)))
+ (error "extract: Aargh!"))
+ ;; test that applying the original setter to arguments in
+ ;; the subdomain gives the same answer as applying the
+ ;; setter of the extracted array to the same arguments.
+ (for-each (lambda (A B A-extract B-extract)
+ (let ((A-setter (array-setter A))
+ (B-extract-setter (array-setter B-extract)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i 100)
+ (test-assert (myarray= spec-A spec-B))
+ (test-assert
+ (myarray= spec-A-extract spec-B-extract)))
+ (call-with-values
+ (lambda ()
+ (random-multi-index subdomain))
+ (lambda multi-index
+ (let ((val (random-real)))
+ (apply A-setter val multi-index)
+ (apply B-extract-setter val multi-index)))))))
+ (list spec-A mut-A)
+ (list spec-B mut-B)
+ (list spec-A-extract mut-A-extract)
+ (list spec-B-extract mut-B-extract))))
+ )
+
+ (test-group "tile/reverse/flip"
+ (test-error (array-tile 'a '#(10)))
+ (test-error
+ (array-tile (make-array (make-interval '#(0 0) '#(10 10)) list)
+ 'a))
+ (test-error
+ (array-tile (make-array (make-interval '#(0 0) '#(10 10)) list)
+ '#(a a)))
+ (test-error
+ (array-tile (make-array (make-interval '#(0 0) '#(10 10)) list)
+ '#(-1 1)))
+ (test-error
+ (array-tile (make-array (make-interval '#(0 0) '#(10 10)) list)
+ '#(10)))
+
+ (do ((d 1 (fx+ d 1)))
+ ((fx=? d 6))
+ (let* ((A (make-array (make-interval (make-vector d 100)) list))
+ (B (array-tile A (make-vector d 10)))
+ (index (make-list d 12)))
+ (test-error (apply (array-getter B) index))))
+
+ ;; (do ((i 0 (fx+ i 1)))
+ ;; ((fx=? i tests))
+ ;; (let* ((domain
+ ;; (random-interval))
+ ;; (array
+ ;; (let ((res (make-array domain list)))
+ ;; (case (random-integer 3)
+ ;; ;; immutable
+ ;; ((0) res)
+ ;; ;; specialized
+ ;; ((1) (array-copy res))
+ ;; (else
+ ;; ;; mutable, but not specialized
+ ;; (let ((res (array-copy res)))
+ ;; (make-array domain
+ ;; (array-getter res)
+ ;; (array-setter res)))))))
+ ;; (lowers
+ ;; (%%interval-lower-bounds domain))
+ ;; (uppers
+ ;; (%%interval-upper-bounds domain))
+ ;; (sidelengths
+ ;; (vector-map (lambda (l u)
+ ;; (let ((dim (- u l)))
+ ;; (random 1 (ceiling-quotient (* dim 7) 5))))
+ ;; lowers uppers))
+ ;; (result
+ ;; (array-tile array sidelengths))
+ ;; (test-result
+ ;; (my-array-tile array sidelengths)))
+
+ ;; ;; extract-array is tested independently, so we just make a few tests.
+
+ ;; ;; test all the subdomain tiles are the same
+ ;; (test-assert
+ ;; (array-every (lambda (r t)
+ ;; (equal? (array-domain r) (array-domain t)))
+ ;; result test-result))
+ ;; ;; test that the subarrays are the same type
+ ;; (test-assert
+ ;; (array-every
+ ;; (lambda (r t)
+ ;; (and
+ ;; (eq? (mutable-array? r) (mutable-array? t))
+ ;; (eq? (mutable-array? r) (mutable-array? array))
+ ;; (eq? (specialized-array? r) (specialized-array? t))
+ ;; (eq? (specialized-array? r) (specialized-array? array))))
+ ;; result test-result))
+ ;; ;; test that the first tile has the right values
+ ;; (test-assert
+ ;; (myarray= (apply (array-getter result)
+ ;; (make-list (vector-length lowers) 0))
+ ;; (apply (array-getter test-result)
+ ;; (make-list (vector-length lowers) 0))))
+ ;; ))
+
+ (test-error (array-reverse 'a 'a))
+ (test-error
+ (array-reverse (make-array (make-interval '#(0 0) '#(2 2)) list)
+ 'a))
+ (test-error
+ (array-reverse (make-array (make-interval '#(0 0) '#(2 2)) list)
+ '#(1 0)))
+ (test-error
+ (array-reverse (make-array (make-interval '#(0 0) '#(2 2)) list)
+ '#(#t)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-interval))
+ (Array (let ((temp (make-array domain list)))
+ (case (random-integer 3)
+ ((0) temp)
+ ((1) (array-copy temp))
+ ((2) (let ((temp (array-copy temp)))
+ (make-array (array-domain temp)
+ (array-getter temp)
+ (array-setter temp)))))))
+ (flips (vector-map (lambda (x) (random-boolean))
+ (make-vector (interval-dimension domain))))
+ (reversed-array (array-reverse Array flips))
+ (my-reversed-array (myarray-reverse Array flips)))
+
+ (if (mutable-array? Array)
+ (do ((j 0 (+ j 1)))
+ ((= j 50))
+ (call-with-values
+ (lambda ()
+ (random-multi-index domain))
+ (lambda multi-index
+ (let ((value (random-integer 10000)))
+ (apply (array-setter reversed-array) value multi-index)
+ (apply (array-setter my-reversed-array) value
+ multi-index))))))
+ (test-assert (myarray= reversed-array
+ my-reversed-array))))
+
+ ;; next test that the optional flip? argument is computed correctly.
+
+ (for-each
+ (lambda (n)
+ (let* ((upper-bounds (make-vector n 2))
+ (lower-bounds (make-vector n 0))
+ (domain (make-interval lower-bounds upper-bounds))
+ (A (array-copy (make-array domain list)))
+ (immutable-A
+ (let ((A (array-copy A))) ;; copy A
+ (make-array domain
+ (array-getter A))))
+ (mutable-A
+ (let ((A (array-copy A))) ;; copy A
+ (make-array domain
+ (array-getter A)
+ (array-setter A))))
+ (flip? (make-vector n #t)))
+ (let ((r1 (array-reverse A))
+ (r2 (array-reverse A flip?)))
+ (test-assert (and (specialized-array? r1)
+ (specialized-array? r2)
+ (myarray= r1 r2))))
+ (let ((r1 (array-reverse mutable-A))
+ (r2 (array-reverse mutable-A flip?)))
+ (test-assert (and (mutable-array? r1)
+ (mutable-array? r2)
+ (myarray= r1 r2))))
+ (let ((r1 (array-reverse immutable-A))
+ (r2 (array-reverse immutable-A flip?)))
+ (test-assert (and (array? r1)
+ (array? r2)
+ (myarray= r1 r2))))))
+ (iota 5 1))
+
+ (test-error (array-assign! 'a 'a))
+ (test-error
+ (array-assign! (make-array (make-interval '#(0 0) '#(1 1)) values) 'a))
+ (test-error
+ (array-assign! (array-copy (make-array (make-interval '#(0 0) '#(1 1))
+ values))
+ 'a))
+ (test-error
+ (array-assign! (array-copy (make-array (make-interval '#(0 0) '#(1 1))
+ values))
+ (make-array (make-interval '#(0 0) '#(2 1)) values)))
+ (test-error
+ (array-assign! (make-array (make-interval '#(1 2)) list list) ; invalid
+ (make-array (make-interval '#(0 0) '#(2 1)) values)))
+ (test-error
+ (array-assign! (array-rotate
+ (array-copy (make-array (make-interval '#(2 3))
+ list ))
+ 1)
+ (make-array (make-interval '#(2 3)) list)))
+
+ (let ( ;; elements in order
+ (destination (make-specialized-array (make-interval '#(3 2))))
+ ;; not the same interval, but same volume
+ (source (array-rotate (make-array (make-interval '#(3 2)) list)
+ 1)))
+ (array-assign! destination source)
+ (test (array->list destination)
+ (array->list source)))
+ )
+
+ (test-group "assign/product"
+ (do ((d 1 (fx+ d 1)))
+ ((= d 6))
+ (let* ((unsafe-specialized-destination
+ (make-specialized-array (make-interval (make-vector d 10))
+ u1-storage-class))
+ (safe-specialized-destination
+ (make-specialized-array (make-interval (make-vector d 10))
+ u1-storage-class
+ #t))
+ (mutable-destination
+ (make-array (array-domain safe-specialized-destination)
+ (array-getter safe-specialized-destination)
+ (array-setter safe-specialized-destination)))
+ (source
+ (make-array (array-domain safe-specialized-destination)
+ (lambda args 100)))) ;; not 0 or 1
+ (test-error (array-assign! unsafe-specialized-destination source))
+ (test-error (array-assign! safe-specialized-destination source))
+ (test-error (array-assign! mutable-destination source))))
+
+ (do ((i 0 (fx+ i 1)))
+ ((fx=? i tests))
+ (let* ((interval
+ (random-interval))
+ (subinterval
+ (random-subinterval interval))
+ (storage-class-and-initializer
+ (random-storage-class-and-initializer))
+ (storage-class
+ (car storage-class-and-initializer))
+ (initializer
+ (cadr storage-class-and-initializer))
+ (specialized-array
+ (array-copy
+ (make-array interval initializer)
+ storage-class))
+ (mutable-array
+ (let ((specialized-array
+ (array-copy
+ (make-array interval initializer)
+ storage-class)))
+ (make-array interval
+ (array-getter specialized-array)
+ (array-setter specialized-array))))
+ (specialized-subarray
+ (array-extract specialized-array subinterval))
+ (mutable-subarray
+ (array-extract mutable-array subinterval))
+ (new-subarray
+ (array-copy
+ (make-array subinterval initializer)
+ storage-class)))
+ (array-assign! specialized-subarray new-subarray)
+ (array-assign! mutable-subarray new-subarray)
+ (test-assert
+ (myarray=
+ specialized-array
+ (make-array
+ interval
+ (lambda multi-index
+ (if (apply interval-contains-multi-index? subinterval
+ multi-index)
+ (apply (array-getter new-subarray) multi-index)
+ (apply (array-getter specialized-array) multi-index))))))
+ (test-assert
+ (myarray=
+ mutable-array
+ (make-array
+ interval
+ (lambda multi-index
+ (if (apply interval-contains-multi-index? subinterval
+ multi-index)
+ (apply (array-getter new-subarray) multi-index)
+ (apply (array-getter mutable-array) multi-index)))))
+ )))
+
+ (test-error (make-array (make-interval '#(0 0) '#(10 10)) list 'a))
+ (test-error (array-dimension 'a))
+ (test-assert
+ (array-safe?
+ (array-copy (make-array (make-interval '#(0 0) '#(10 10)) list)
+ generic-storage-class
+ #f
+ #t
+ #t)))
+ (test-not
+ (array-safe?
+ (array-copy (make-array (make-interval '#(0 0) '#(10 10)) list)
+ generic-storage-class
+ #f
+ #t
+ #f)))
+
+ (let ((array-builders
+ (vector
+ (list u1-storage-class
+ (lambda indices (let ((res (random (expt 2 1)))) res))
+ '(a -1))
+ (list u8-storage-class
+ (lambda indices (random (expt 2 8)))
+ '(a -1))
+ (list u16-storage-class
+ (lambda indices (random (expt 2 16)))
+ '(a -1))
+ (list u32-storage-class
+ (lambda indices (random (expt 2 32)))
+ '(a -1))
+ (list u64-storage-class
+ (lambda indices (random (expt 2 64)))
+ '(a -1))
+ (list s8-storage-class
+ (lambda indices (random (- (expt 2 7)) (expt 2 7)))
+ `(a ,(expt 2 8)))
+ (list s16-storage-class
+ (lambda indices (random (- (expt 2 15)) (expt 2 15)))
+ `(a ,(expt 2 16)))
+ (list s32-storage-class
+ (lambda indices (random (- (expt 2 31)) (expt 2 31)))
+ `(a ,(expt 2 32)))
+ (list s64-storage-class
+ (lambda indices (random (- (expt 2 63)) (expt 2 63)))
+ `(a ,(expt 2 64)))
+ (list f32-storage-class
+ (lambda indices (random-real))
+ `(a 1))
+ (list f64-storage-class
+ (lambda indices (random-real))
+ `(a 1))
+ (list c64-storage-class
+ (lambda indices (make-rectangular (random-real) (random-real)))
+ `(a 1))
+ (list c128-storage-class
+ (lambda indices (make-rectangular (random-real) (random-real)))
+ `(a 1))
+ )))
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-interval))
+ (builders (vector-ref array-builders
+ 0
+ #; (random-integer
+ (vector-length array-builders))
+ ))
+ (storage-class (car builders))
+ (random-entry (cadr builders))
+ (invalid-entry (list-ref (caddr builders) (random 2)))
+ (Array (array-copy (make-array domain random-entry)
+ storage-class
+ #f
+ #t ; mutable
+ #t)) ; safe
+ (getter (array-getter Array))
+ (setter (array-setter Array))
+ (dimension (interval-dimension domain))
+ (valid-args (call-with-values
+ (lambda ()
+ (random-multi-index domain))
+ list)))
+ (test-error (apply setter invalid-entry valid-args))
+ (set-car! valid-args 'a)
+ (test-error (apply getter valid-args))
+ (test-error (apply setter 10 valid-args))
+ ;; outside the range of any random-interval
+ (set-car! valid-args 10000)
+ (test-error (apply getter valid-args))
+ (test-error (apply setter 10 valid-args))
+ (if (< 4 dimension)
+ (begin
+ (set! valid-args (cons 1 valid-args))
+ (test-error (apply getter valid-args))
+ (test-error (apply setter 10 valid-args)))))))
+
+ (test-error (array->list 'a))
+ (test-error (list->array 'a 'b))
+ (test-error (list->array '(0) 'b))
+ (test-error (list->array '(0) (make-interval '#(0) '#(1)) 'a))
+ (test-error (list->array '(0) (make-interval '#(0) '#(1))
+ generic-storage-class 'a))
+ (test-error (list->array '(0) (make-interval '#(0) '#(1))
+ generic-storage-class #t 'a))
+
+ ;; (list->array '(0) (make-interval '#(0) '#(10)))
+
+ (test-error (list->array '(0) (make-interval '#(0) '#(10))))
+ (test-error
+ (list->array '(a) (make-interval '#(0) '#(1)) u1-storage-class))
+ (test-error (list->array '(a) (make-interval '#(10))))
+
+ (let ((array-builders
+ (vector
+ (list u1-storage-class (lambda indices (random 0 (expt 2 1))))
+ (list u8-storage-class (lambda indices (random 0 (expt 2 8))))
+ (list u16-storage-class (lambda indices (random 0 (expt 2 16))))
+ (list u32-storage-class (lambda indices (random 0 (expt 2 32))))
+ (list u64-storage-class (lambda indices (random 0 (expt 2 64))))
+ (list s8-storage-class
+ (lambda indices (random (- (expt 2 7)) (expt 2 7))))
+ (list s16-storage-class
+ (lambda indices (random (- (expt 2 15)) (expt 2 15))))
+ (list s32-storage-class
+ (lambda indices (random (- (expt 2 31)) (expt 2 31))))
+ (list s64-storage-class
+ (lambda indices (random (- (expt 2 63)) (expt 2 63))))
+ (list f32-storage-class
+ (lambda indices (random-real)))
+ (list f64-storage-class
+ (lambda indices (random-real)))
+ (list c64-storage-class
+ (lambda indices (make-rectangular (random-real) (random-real))))
+ (list c128-storage-class
+ (lambda indices (make-rectangular (random-real) (random-real))))
+ (list generic-storage-class (lambda indices indices)))))
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((domain (random-interval))
+ (builders
+ (vector-ref array-builders
+ (random-integer (vector-length array-builders))))
+ (storage-class (car builders))
+ (random-entry (cadr builders))
+ (Array (array-copy (make-array domain random-entry)
+ storage-class
+ #f
+ #t)) ; safe
+ (l (array->list Array))
+ (new-array
+ (list->array l domain storage-class
+ (zero? (random-integer 2)))))
+ (test-assert (myarray= Array new-array)))))
+
+ (test-error (interval-cartesian-product 'a))
+ (test-error (interval-cartesian-product (make-interval '#(0) '#(1)) 'a))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((intervals
+ (map (lambda (ignore)
+ (random-interval 1 4))
+ (make-list (random 1 3)))))
+ (test (apply my-interval-cartesian-product intervals)
+ (apply interval-cartesian-product intervals))))
+
+ (let ((test-array (make-array (make-interval '#(0) '#(1)) list)))
+ (test-error (array-outer-product 'a test-array test-array))
+ (test-error (array-outer-product append 'a test-array))
+ (test-error (array-outer-product append test-array 'a)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i tests))
+ (let* ((arrays
+ (map (lambda (ignore)
+ (make-array (random-interval 1 5) list))
+ (make-list 2))))
+ (test-assert
+ (myarray= (apply array-outer-product append arrays)
+ (make-array (apply my-interval-cartesian-product
+ (map array-domain arrays))
+ list))))))
+
+ (test-group "reshape tests"
+ (specialized-array-default-safe? #t)
+ (let ((A-ref
+ (array-copy
+ (make-array (make-interval '#(10 10))
+ (lambda (i j) (if (= i j) 1 0)))))
+ (B-set!
+ (array-copy
+ (make-array (make-interval '#(10 10))
+ (lambda (i j) (if (= i j) 1 0)))
+ u1-storage-class)))
+ (do ((i 1 (+ i 1)))
+ ((= i 6))
+ (test-error (apply array-ref 1 (make-list i 0))))
+ (test-error (array-ref A-ref 1))
+ (test-error (array-ref A-ref 1 1001))
+ (test 1 (array-ref A-ref 4 4))
+ (test 0 (array-ref A-ref 4 5))
+
+ (test-error (array-set! 1 1 1))
+ (test-error (array-set! B-set!))
+ (test-error (array-set! B-set! 2))
+ (test-error (array-set! B-set! 2 1))
+ (test-error (array-set! B-set! 2 1 1))
+ (array-set! B-set! 1 1 2)
+ (array-set! B-set! 0 2 2)
+ ;;(array-display B-set!)
+
+ (test-error (specialized-array-reshape 'a 1))
+ (test-error (specialized-array-reshape A-ref 'a))
+ (test-error (specialized-array-reshape A-ref (make-interval '#(5))))
+ )
+
+ (let ((array (array-copy (make-array (make-interval '#(2 1 3 1)) list))))
+ (test (array->list array)
+ (array->list
+ (specialized-array-reshape array (make-interval '#(6))))))
+
+ (let ((array (array-copy (make-array (make-interval '#(2 1 3 1)) list))))
+ (test (array->list array)
+ (array->list
+ (specialized-array-reshape array (make-interval '#(3 2))))))
+
+ (let ((array
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list)))))
+ (test (array->list array)
+ (array->list
+ (specialized-array-reshape array (make-interval '#(6))))))
+
+ (let ((array
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list)))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 2))))
+ (array->list array)))
+
+ (let ((array
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 2))))
+ (array->list array)))
+
+ (let ((array (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 1 2))))
+ (array->list array)))
+
+ (let ((array (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(1 1 1 3 2))))
+ (array->list array)))
+
+ (let ((array (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 2 1 1 1))))
+ (array->list array)))
+
+ (let ((array (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 1 1 2))))
+ (array->list array)))
+
+ (let ((array (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(3 1 2 1))))
+ (array->list array)))
+
+ (let ((array
+ (array-sample
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 4 1)) list))
+ '#(#f #f #f #t))
+ '#(1 1 2 1))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(4))))
+ (array->list array)))
+
+ (let ((array
+ (array-sample
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 4 1)) list))
+ '#(#t #f #t #t))
+ '#(1 1 2 1))))
+ (test (array->list
+ (specialized-array-reshape array (make-interval '#(4))))
+ (array->list array)))
+
+ (test-error
+ (specialized-array-reshape
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#t #f #f #f))
+ (make-interval '#(6))))
+
+ (test-error
+ (specialized-array-reshape
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#t #f #f #f))
+ (make-interval '#(3 2))))
+
+ (test-error
+ (specialized-array-reshape
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #t #f))
+ (make-interval '#(6))))
+
+ (test-error
+ (specialized-array-reshape
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #t #t))
+ (make-interval '#(3 2))))
+
+ (test-error
+ (specialized-array-reshape
+ (array-sample
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 3 1)) list))
+ '#(#f #f #f #t))
+ '#(1 1 2 1))
+ (make-interval '#(4))))
+
+ (test-error
+ (specialized-array-reshape
+ (array-sample
+ (array-reverse
+ (array-copy (make-array (make-interval '#(2 1 4 1)) list))
+ '#(#f #f #t #t))
+ '#(1 1 2 1))
+ (make-interval '#(4))))
+ )
+
+ (test-group "curry tests"
+ (test-assert
+ (interval=
+ (interval-dilate (make-interval '#(100 100)) '#(1 1) '#(1 1))
+ (make-interval '#(1 1) '#(101 101))))
+
+ (test-assert
+ (interval=
+ (interval-dilate (make-interval '#(100 100)) '#(-1 -1) '#(1 1))
+ (make-interval '#(-1 -1) '#(101 101))))
+
+ (test-assert
+ (interval=
+ (interval-dilate (make-interval '#(100 100)) '#(0 0) '#(-50 -50))
+ (make-interval '#(50 50))))
+
+ (test-error
+ (interval-dilate (make-interval '#(100 100)) '#(0 0) '#(-500 -50)))
+
+ (let ((a (make-array (make-interval '#(1 1) '#(11 11))
+ (lambda (i j)
+ (if (= i j)
+ 1
+ 0)))))
+ (test 1
+ ((array-getter a) 3 3))
+ (test 0
+ ((array-getter a) 2 3)))
+
+ (let ((a (make-array (make-interval '#(0 0) '#(10 10))
+ list)))
+ (test '(3 4)
+ ((array-getter a) 3 4))
+ (let ((curried-a (array-curry a 1)))
+ (test '(3 4)
+ ((array-getter ((array-getter curried-a) 3)) 4))))
+
+ (test 0.
+ ((array-getter sparse-array) 12345 6789))
+
+ (test 0.
+ ((array-getter sparse-array) 0 0))
+
+ ((array-setter sparse-array) 1.0 0 0)
+
+ (test 0.
+ ((array-getter sparse-array) 12345 6789))
+
+ (test 1.
+ ((array-getter sparse-array) 0 0))
+ )
+
+ (test-group "misc"
+ (let ()
+ (define a
+ (array-copy
+ (make-array (make-interval '#(5 10))
+ list)))
+ (define b
+ (specialized-array-share
+ a
+ (make-interval '#(5 5))
+ (lambda (i j)
+ (values i (+ i j)))))
+ ;; Print the \"rows\" of b
+ ;; (array-for-each (lambda (row)
+ ;; (pretty-print (array->list row)))
+ ;; (array-curry b 1))
+
+ ;; which prints
+ ;; ((0 0) (0 1) (0 2) (0 3) (0 4))
+ ;; ((1 1) (1 2) (1 3) (1 4) (1 5))
+ ;; ((2 2) (2 3) (2 4) (2 5) (2 6))
+ ;; ((3 3) (3 4) (3 5) (3 6) (3 7))
+ ;; ((4 4) (4 5) (4 6) (4 7) (4 8))
+ )
+
+ '(let ()
+ (define (palindrome? s)
+ (let ((n (string-length s)))
+ (or (< n 2)
+ (let* ((a
+ ;; an array accessing the characters of s
+ (make-array (make-interval (vector n))
+ (lambda (i)
+ (string-ref s i))))
+ (ra
+ ;; the array in reverse order
+ (array-reverse a))
+ (half-domain
+ (make-interval (vector (quotient n 2)))))
+ (array-every
+ char=?
+ ;; the first half of s
+ (array-extract a half-domain)
+ ;; the second half of s
+ (array-extract ra half-domain))))))
+ (for-each
+ (lambda (s)
+ (for-each display
+ (list "(palindrome? \""
+ s
+ "\") => "
+ (palindrome? s)
+ #\newline)))
+ '("" "a" "aa" "ab" "aba" "abc" "abba" "abca" "abbc")))
+
+ ;; (let ((greys (pgm-greys test-pgm)))
+ ;; (write-pgm
+ ;; (make-pgm
+ ;; greys
+ ;; (array-map (lambda (p)
+ ;; (round-and-clip p greys))
+ ;; (array-convolve
+ ;; (pgm-pixels test-pgm)
+ ;; sharpen-filter)))
+ ;; "sharper-test.pgm"))
+
+ ;; (let* ((greys (pgm-greys test-pgm))
+ ;; (edge-array
+ ;; (array-copy
+ ;; (array-map
+ ;; abs
+ ;; (array-convolve
+ ;; (pgm-pixels test-pgm)
+ ;; edge-filter))))
+ ;; (max-pixel
+ ;; (array-fold max 0 edge-array))
+ ;; (normalizer
+ ;; (inexact (/ greys max-pixel))))
+ ;; (write-pgm
+ ;; (make-pgm
+ ;; greys
+ ;; (array-map (lambda (p)
+ ;; (- greys
+ ;; (round-and-clip (* p normalizer) greys)))
+ ;; edge-array))
+ ;; "edge-test.pgm"))
+
+
+ (let ((m
+ (array-copy (make-array (make-interval '#(0 0) '#(40 30))
+ (lambda (i j) (inexact (+ i j)))))))
+ (test 1940. (operator-max-norm m))
+ (test 1605. (operator-one-norm m)))
+
+ (let ((image
+ (array-copy
+ (make-array (make-interval '#(4 4))
+ (lambda (i j)
+ (case i
+ ((0) 1.)
+ ((1) -1.)
+ (else 0.)))))))
+ ;; (display "\nInitial image: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image)))
+ ;; (hyperbolic-Haar-transform image)
+ ;; (display "\nArray of hyperbolic Haar wavelet coefficients: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image)))
+ ;; (hyperbolic-Haar-inverse-transform image)
+ ;; (display "\nReconstructed image: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image)))
+ #f)
+
+
+ ;; (let ((image
+ ;; (array-copy
+ ;; (make-array (make-interval '#(4 4))
+ ;; (lambda (i j)
+ ;; (case i
+ ;; ((0) 1.)
+ ;; ((1) -1.)
+ ;; (else 0.)))))))
+ ;; (display "\nInitial image: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image)))
+ ;; (Haar-transform image)
+ ;; (display "\nArray of Haar wavelet coefficients: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image)))
+ ;; (Haar-inverse-transform image)
+ ;; (display "\nReconstructed image: \n")
+ ;; (pretty-print (list (array-domain image)
+ ;; (array->list image))))
+
+ ;; (define A
+ ;; ;; A Hilbert matrix
+ ;; (array-copy
+ ;; (make-array (make-interval '#(4 4))
+ ;; (lambda (i j)
+ ;; (/ (+ 1 i j))))))
+
+ ;; (display "\nHilbert matrix:\n\n")
+ ;; (array-display A)
+
+ ;; (LU-decomposition A)
+
+ ;; (display "\nLU decomposition of Hilbert matrix:\n\n")
+
+ ;; (array-display A)
+
+ ;; Functions to extract the lower- and upper-triangular
+ ;; matrices of the LU decomposition of A.
+
+ ;; (define (L a)
+ ;; (let ((a_ (array-getter a))
+ ;; (d (array-domain a)))
+ ;; (make-array
+ ;; d
+ ;; (lambda (i j)
+ ;; (cond ((= i j) 1) ;; diagonal
+ ;; ((> i j) (a_ i j)) ;; below diagonal
+ ;; (else 0)))))) ;; above diagonal
+
+ ;; (define (U a)
+ ;; (let ((a_ (array-getter a))
+ ;; (d (array-domain a)))
+ ;; (make-array
+ ;; d
+ ;; (lambda (i j)
+ ;; (cond ((<= i j) (a_ i j)) ;; diagonal and above
+ ;; (else 0)))))) ;; below diagonal
+
+ ;; ;; Lower triangular matrix of decomposition of Hilbert matrix
+ ;; (array-display (L A))
+
+ ;; ;; Upper triangular matrix of decomposition of Hilbert matrix
+ ;; (array-display (U A))
+
+ ;; We'll check that the product of the result of LU
+ ;; decomposition of A is again A.
+
+ ;; (define product (matrix-multiply (L A) (U A)))
+
+ ;; (display "\nProduct of lower and upper triangular matrices ")
+ ;; (display "of LU decomposition of Hilbert matrix:\n\n")
+ ;; (array-display product)
+
+ ;; Examples from
+ ;; http://microapl.com/apl_help/ch_020_020_880.htm
+
+ (let ((TABLE1
+ (list->array
+ '(1 2
+ 5 4
+ 3 0)
+ (make-interval '#(3 2))))
+ (TABLE2
+ (list->array
+ '(6 2 3 4
+ 7 0 1 8)
+ (make-interval '#(2 4)))))
+ (test '(20 2 5 20
+ 58 10 19 52
+ 18 6 9 12)
+ (array->list (inner-product TABLE1 + * TABLE2))))
+
+ (let ((X ;; a "row vector"
+ (list->array '(1 3 5 7) (make-interval '#(1 4))))
+ (Y ;; a "column vector"
+ (list->array '(2 3 6 7) (make-interval '#(4 1)))))
+ (test '(2)
+ (array->list (inner-product X + (lambda (x y) (if (= x y) 1 0)) Y))))
+
+ ;; (let* ((A (array-copy (make-array (make-interval '#(3 4)) list)))
+ ;; (B (array-sample A '#(2 1))))
+ ;; (test-error
+ ;; (specialized-array-reshape B (make-interval '#(8)))))
+
+ '(let* ((interval-flat (make-interval '#(100 100 4)))
+ (interval-2x2 (make-interval '#(100 100 2 2)))
+ (A (array-copy (make-array interval-flat
+ (lambda args (random-integer 5)))))
+ (B (array-copy (make-array interval-flat
+ (lambda args (random-integer 5)))))
+ (C (array-copy (make-array interval-flat
+ (lambda args 0)))))
+ (array-for-each
+ x2x2-matrix-multiply-into!
+ (array-curry (specialized-array-reshape A interval-2x2) 2)
+ (array-curry (specialized-array-reshape B interval-2x2) 2)
+ (array-curry (specialized-array-reshape C interval-2x2) 2))
+ (array-for-each
+ (lambda (A B C)
+ (array-assign! C (matrix-multiply A B)))
+ (array-curry (specialized-array-reshape A interval-2x2) 2)
+ (array-curry (specialized-array-reshape B interval-2x2) 2)
+ (array-curry (specialized-array-reshape C interval-2x2) 2))
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape A interval-2x2)
+ 2))
+ 0 0))
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape B interval-2x2)
+ 2))
+ 0 0))
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape C interval-2x2)
+ 2))
+ 0 0))
+
+ (let ((a2x2 (make-interval '#(2 2))))
+ (array-for-each (lambda (A B C)
+ (x2x2-matrix-multiply-into!
+ (specialized-array-reshape A a2x2)
+ (specialized-array-reshape B a2x2)
+ (specialized-array-reshape C a2x2)))
+ (array-curry A 1)
+ (array-curry B 1)
+ (array-curry C 1))
+ (array-for-each (lambda (A B C)
+ (array-assign!
+ (specialized-array-reshape C a2x2)
+ (matrix-multiply
+ (specialized-array-reshape A a2x2)
+ (specialized-array-reshape B a2x2))))
+ (array-curry A 1)
+ (array-curry B 1)
+ (array-curry C 1)))
+
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape A interval-2x2)
+ 2))
+ 0 0))
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape B interval-2x2)
+ 2))
+ 0 0))
+ '(array-display ((array-getter
+ (array-curry
+ (specialized-array-reshape C interval-2x2)
+ 2))
+ 0 0))
+ )
+ )
+
+ (test-end)
+ )))
diff --git a/lib/srfi/179/transforms.scm b/lib/srfi/179/transforms.scm
new file mode 100644
index 00000000..b9495ab0
--- /dev/null
+++ b/lib/srfi/179/transforms.scm
@@ -0,0 +1,459 @@
+
+;; Homogeneous storage classes
+
+;; Define a storage class with an optimized -copy!
+(define-syntax define-storage-class
+ (syntax-rules ()
+ ((define-storage-class name ref set elt? make len default)
+ (define name
+ (make-storage-class
+ ref set elt? make
+ (lambda (to at from start end)
+ (let ((limit (min end (+ start (- (len to) at)))))
+ (if (<= at start)
+ (do ((i at (+ i 1)) (j start (+ j 1)))
+ ((>= j limit))
+ (set to i (ref from j)))
+ (do ((i (+ at (- end start 1)) (- i 1)) (j (- limit 1) (- j 1)))
+ ((< j start))
+ (set to i (ref from j))))))
+ len default)))))
+
+(define-storage-class s8-storage-class
+ s8vector-ref s8vector-set! s8? make-s8vector s8vector-length 0)
+
+(define-storage-class s16-storage-class
+ s16vector-ref s16vector-set! s16? make-s16vector s16vector-length 0)
+
+(define-storage-class s32-storage-class
+ s32vector-ref s32vector-set! s32? make-s32vector s32vector-length 0)
+
+(define-storage-class s64-storage-class
+ s64vector-ref s64vector-set! s64? make-s64vector s64vector-length 0)
+
+(define-storage-class u1-storage-class
+ u1vector-ref u1vector-set! u1? make-u1vector u1vector-length 0)
+
+(define-storage-class u8-storage-class
+ u8vector-ref u8vector-set! u8? make-u8vector u8vector-length 0)
+
+(define-storage-class u16-storage-class
+ u16vector-ref u16vector-set! u16? make-u16vector u16vector-length 0)
+
+(define-storage-class u32-storage-class
+ u32vector-ref u32vector-set! u32? make-u32vector u32vector-length 0)
+
+(define-storage-class u64-storage-class
+ u64vector-ref u64vector-set! u64? make-u64vector u64vector-length 0)
+
+(define-storage-class f32-storage-class
+ f32vector-ref f32vector-set! f32? make-f32vector f32vector-length 0)
+
+(define-storage-class f64-storage-class
+ f64vector-ref f64vector-set! f64? make-f64vector f64vector-length 0)
+
+(define-storage-class c64-storage-class
+ c64vector-ref c64vector-set! c64? make-c64vector c64vector-length 0)
+
+(define-storage-class c128-storage-class
+ c128vector-ref c128vector-set! c128? make-c128vector c128vector-length 0)
+
+;; TODO: implement
+(define f8-storage-class #f)
+(define f16-storage-class #f)
+
+;; Array transformations
+
+(define (array-copy array . o)
+ (assert (array? array))
+ (let* ((storage (if (pair? o) (car o) generic-storage-class))
+ (o (if (pair? o) (cdr o) '()))
+ (new-domain (or (and (pair? o) (car o)) (array-domain array)))
+ (o (if (pair? o) (cdr o) '()))
+ (mutable? (if (pair? o) (car o) (specialized-array-default-mutable?)))
+ (o (if (pair? o) (cdr o) '()))
+ (safe? (if (pair? o) (car o) (specialized-array-default-safe?))))
+ (assert (and (storage-class? storage) (interval? new-domain)
+ (boolean? mutable?) (boolean? safe?)))
+ (let* ((body ((storage-class-maker storage)
+ (interval-volume new-domain)
+ (storage-class-default storage)))
+ (coeffs (default-coeffs new-domain))
+ (indexer (coeffs->indexer coeffs new-domain))
+ (getter (specialized-getter body indexer
+ (storage-class-getter storage)))
+ (setter (specialized-setter body indexer
+ (storage-class-setter storage)))
+ (res (%make-specialized new-domain storage body coeffs indexer
+ safe? #t #t)))
+ (array-assign! res array)
+ (unless mutable?
+ (%array-setter-set! res #f))
+ res)))
+
+(define (array-curry array inner-dimension)
+ (call-with-values
+ (lambda () (interval-projections (array-domain array) inner-dimension))
+ (lambda (outer-domain inner-domain)
+ (cond
+ ((specialized-array? array)
+ (make-array
+ outer-domain
+ (lambda outer-index
+ (specialized-array-share
+ array
+ inner-domain
+ (lambda inner-index
+ (apply values (append outer-index inner-index)))))))
+ (else
+ (make-array
+ outer-domain
+ (lambda outer-index
+ (make-array
+ inner-domain
+ (lambda inner-index
+ (apply array-ref array (append outer-index inner-index)))
+ (and
+ (mutable-array? array)
+ (lambda (val . inner-index)
+ (apply array-set! array val (append outer-index inner-index))
+ ))))))))))
+
+(define (array-extract array new-domain)
+ (assert (and (array? array)
+ (interval? new-domain)
+ (interval-subset? new-domain (array-domain array))))
+ (if (specialized-array? array)
+ (specialized-array-share array new-domain values)
+ (make-array new-domain (array-getter array) (array-setter array))))
+
+(define (array-tile array sizes)
+ (assert (and (array? array)
+ (vector? sizes)
+ (= (array-dimension array) (vector-length sizes))
+ (vector-every exact-integer? sizes)
+ (vector-every >= sizes (interval-lower-bounds->vector
+ (array-domain array)))
+ (vector-every < sizes (interval-upper-bounds->vector
+ (array-domain array)))))
+ (let ((domain (make-interval
+ (vector-map
+ (lambda (lo hi s) (exact (ceiling (/ (- hi lo) s))))
+ (interval-lower-bounds->vector (array-domain array))
+ (interval-upper-bounds->vector (array-domain array))
+ sizes))))
+ (make-array
+ domain
+ (lambda multi-index
+ (array-extract
+ array
+ (make-interval
+ (vector-map
+ (lambda (i lo s) (+ lo (* i s)))
+ multi-index
+ (interval-lower-bound (array-domain array))
+ sizes)
+ (vector-map
+ (lambda (i lo hi s)
+ (min hi (+ lo (* (+ i 1) s))))
+ multi-index
+ (interval-lb (array-domain array))
+ (interval-ub (array-domain array))
+ sizes)))))))
+
+(define (array-translate array translation)
+ (let ((new-domain (interval-translate (array-domain array) translation))
+ (translation-ls (vector->list translation)))
+ (if (specialized-array? array)
+ (specialized-array-share
+ array
+ new-domain
+ (lambda multi-index
+ (apply values (map - multi-index translation-ls))))
+ (make-array
+ new-domain
+ (lambda multi-index
+ (apply array-ref array (map - multi-index translation-ls)))
+ (and (mutable-array? array)
+ (lambda (val . multi-index)
+ (apply array-set! array val
+ (map - multi-index translation-ls))))))))
+
+(define (permute ls permutation)
+ (let ((vec (list->vector ls))
+ (len (vector-length permutation)))
+ (do ((i (- len 1) (- i 1))
+ (res '() (cons (vector-ref vec (vector-ref permutation i)) res)))
+ ((< i 0) res))))
+
+(define (inverse-permutation permutation)
+ (list->vector
+ (map car
+ (list-sort (lambda (a b) (< (cdr a) (cdr b)))
+ (map cons
+ (iota (vector-length permutation))
+ (vector->list permutation))))))
+
+(define (array-permute array permutation)
+ (assert (permutation? permutation))
+ (let ((new-domain (interval-permute (array-domain array) permutation))
+ (perm^-1 (inverse-permutation permutation)))
+ (if (specialized-array? array)
+ (specialized-array-share
+ array
+ new-domain
+ (lambda multi-index
+ (let ((perm-index (permute multi-index perm^-1)))
+ (apply values perm-index))))
+ (make-array
+ new-domain
+ (lambda multi-index
+ (let ((perm-index (permute multi-index perm^-1)))
+ (apply array-ref array perm-index)))
+ (and (mutable-array? array)
+ (lambda (val . multi-index)
+ (apply array-set! array val (permute multi-index perm^-1))))))))
+
+(define (array-rotate array dim)
+ (let ((left (iota (- (array-dimension array) dim) dim))
+ (right (iota dim)))
+ (array-permute array (list->vector (append left right)))))
+
+(define (array-reverse array . o)
+ (assert (array? array))
+ (let ((flip? (if (pair? o) (car o) (make-vector (array-dimension array) #t))))
+ (assert (and (vector? flip?)
+ (= (array-dimension array) (vector-length flip?))
+ (vector-every boolean? flip?)))
+ (let* ((flips (vector->list flip?))
+ (domain (array-domain array))
+ (lowers (interval-lower-bounds->list domain))
+ (uppers (interval-upper-bounds->list domain))
+ (flip-multi-index
+ (lambda (multi-index)
+ (map (lambda (i flip-i? lo hi)
+ (if flip-i? (- (+ lo hi -1) i) i))
+ multi-index
+ flips
+ lowers
+ uppers))))
+ (if (specialized-array? array)
+ (specialized-array-share array
+ domain
+ (lambda multi-index
+ (apply values
+ (flip-multi-index multi-index))))
+ (make-array
+ domain
+ (lambda multi-index
+ (apply array-ref array (flip-multi-index multi-index)))
+ (and
+ (mutable-array? array)
+ (lambda (val . multi-index)
+ (apply array-set! array val (flip-multi-index multi-index))
+ )))))))
+
+(define (array-sample array scales)
+ (unless (vector-every zero?
+ (interval-lower-bounds->vector (array-domain array)))
+ (error "can only sample an array with zero lower bounds" array))
+ (let ((scales-ls (vector->list scales))
+ (new-domain (interval-scale (array-domain array) scales)))
+ (if (specialized-array? array)
+ (specialized-array-share
+ array
+ new-domain
+ (lambda multi-index
+ (apply values (map * multi-index scales-ls))))
+ (make-array
+ new-domain
+ (lambda multi-index
+ (apply array-ref array (map * multi-index scales-ls)))
+ (and
+ (mutable-array? array)
+ (lambda (val . multi-index)
+ (apply array-set! array val (map * multi-index scales-ls))))))))
+
+(define (array-outer-product op array1 array2)
+ (assert (and (procedure? op) (array? array1) (array? array2)))
+ (make-array (interval-cartesian-product (array-domain array1)
+ (array-domain array2))
+ (let ((getter1 (array-getter array1))
+ (getter2 (array-getter array2))
+ (dim1 (array-dimension array1)))
+ (lambda multi-index
+ (op (apply getter1 (take multi-index dim1))
+ (apply getter2 (drop multi-index dim1)))))))
+
+(define (same-dimensions? ls)
+ (or (null? ls)
+ (null? (cdr ls))
+ (and (equal? (array-dimension (car ls)) (array-dimension (cadr ls)))
+ (same-dimensions? (cdr ls)))))
+
+(define (array-map f array . arrays)
+ (make-array (array-domain array)
+ (let* ((ls (cons array arrays))
+ (getters (map array-getter ls)))
+ (assert (same-dimensions? ls))
+ (lambda multi-index
+ (apply f (map (lambda (g) (apply g multi-index)) getters))))))
+
+(define (array-for-each f array . arrays)
+ (interval-for-each
+ (let* ((ls (cons array arrays))
+ (getters (map array-getter ls)))
+ (assert (same-dimensions? ls))
+ (lambda multi-index
+ (apply f (map (lambda (g) (apply g multi-index)) getters))))
+ (array-domain array)))
+
+(define (array-fold kons knil array)
+ (interval-fold (lambda (acc . multi-index)
+ (kons (apply array-ref array multi-index) acc))
+ knil
+ (array-domain array)))
+
+(define (array-fold-right kons knil array)
+ (fold-right kons knil (array->list array)))
+
+(define (array-reduce op array)
+ (let* ((domain (array-domain array))
+ (init-index (interval-lower-bounds->list domain))
+ (knil (list 'first-element)))
+ (interval-fold
+ (lambda (acc . multi-index)
+ (if (eq? acc knil)
+ (apply array-ref array multi-index)
+ (op acc (apply array-ref array multi-index))))
+ knil
+ domain)))
+
+(define (array-any pred array . arrays)
+ (assert (same-dimensions? (cons array arrays)))
+ (call-with-current-continuation
+ (lambda (return)
+ (apply array-for-each
+ (lambda args (cond ((apply pred args) => return)))
+ #f
+ array
+ arrays)
+ #f)))
+
+(define (array-every pred array . arrays)
+ (assert (same-dimensions? (cons array arrays)))
+ (call-with-current-continuation
+ (lambda (return)
+ (interval-fold
+ (let ((getters (map array-getter (cons array arrays))))
+ (lambda (acc . multi-index)
+ (or (apply pred (map (lambda (g) (apply g multi-index)) getters))
+ (return #f))))
+ #t
+ (array-domain array)))))
+
+(define (array->list array)
+ (reverse (array-fold cons '() array)))
+
+(define (list->array ls domain . o)
+ (let* ((storage (if (pair? o) (car o) generic-storage-class))
+ (mutable? (if (and (pair? o) (pair? (cdr o)))
+ (cadr o)
+ (specialized-array-default-mutable?)))
+ (safe? (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+ (car (cddr o))
+ (specialized-array-default-safe?)))
+ (res (make-specialized-array domain storage safe?)))
+ (assert (and (interval? domain) (storage-class? storage)
+ (boolean? mutable?) (boolean? safe?)))
+ (interval-fold
+ (lambda (ls . multi-index)
+ (apply array-set! res (car ls) multi-index)
+ (cdr ls))
+ ls
+ domain)
+ res))
+
+(define (array-assign! destination source)
+ (assert (and (mutable-array? destination) (array? source)))
+ (let ((getter (array-getter source))
+ (setter (array-setter destination)))
+ (cond
+ ((interval= (array-domain destination) (array-domain source))
+ (interval-for-each
+ (case (array-dimension destination)
+ ((1) (lambda (i) (setter (getter i) i)))
+ ((2) (lambda (i j) (setter (getter i j) i j)))
+ ((3) (lambda (i j k) (setter (getter i j k) i j k)))
+ (else
+ (lambda multi-index
+ (apply setter (apply getter multi-index) multi-index))))
+ (array-domain source)))
+ (else
+ (assert (and (array-elements-in-order? destination)
+ (equal? (interval-volume (array-domain destination))
+ (interval-volume (array-domain source)))))
+ (let* ((ivc (interval-cursor (array-domain destination)))
+ (dst-index (interval-cursor-get ivc)))
+ (interval-for-each
+ (lambda multi-index
+ (apply setter (apply getter multi-index) dst-index)
+ (interval-cursor-next! ivc))
+ (array-domain source)))))
+ destination))
+
+(define (reshape-without-copy array new-domain)
+ (let* ((domain (array-domain array))
+ (orig-indexer (array-indexer array))
+ (tmp-indexer (default-indexer new-domain))
+ (new-indexer
+ (lambda multi-index
+ (apply orig-indexer
+ (invert-default-index domain
+ (apply tmp-indexer multi-index)))))
+ (new-coeffs (indexer->coeffs new-indexer new-domain #t))
+ (flat-indexer (coeffs->indexer new-coeffs new-domain))
+ (new-indexer (coeffs->indexer new-coeffs new-domain))
+ (body (array-body array))
+ (storage (array-storage-class array))
+ (res
+ (%make-specialized new-domain storage body new-coeffs flat-indexer
+ (array-safe? array) (array-setter array)
+ (array-adjacent? array))))
+ (let ((multi-index (interval-lower-bounds->list domain))
+ (orig-default-indexer (default-indexer domain)))
+ (let lp ((i 0)
+ (ls multi-index))
+ (let ((reshaped-index
+ (invert-default-index
+ new-domain
+ (apply orig-default-indexer multi-index))))
+ (cond
+ ((not (equal? (apply flat-indexer reshaped-index)
+ (apply orig-indexer multi-index)))
+ #f)
+ ((null? ls)
+ res)
+ ((= (+ 1 (interval-lower-bound domain i))
+ (interval-upper-bound domain i))
+ (lp (+ i 1) (cdr ls)))
+ (else
+ (set-car! ls (+ 1 (car ls)))
+ (lp (+ i 1) (cdr ls)))))))))
+
+(define (specialized-array-reshape array new-domain . o)
+ (assert (and (specialized-array? array)
+ (= (interval-volume (array-domain array))
+ (interval-volume new-domain))))
+ (let ((copy-on-failure? (and (pair? o) (car o))))
+ (cond
+ ((reshape-without-copy array new-domain))
+ (copy-on-failure?
+ (let ((res (make-specialized-array
+ new-domain
+ (array-storage-class array)
+ (array-safe? array))))
+ (array-assign! res array)
+ res))
+ (else
+ (error "can't reshape" array new-domain)))))
diff --git a/lib/srfi/193.sld b/lib/srfi/193.sld
new file mode 100644
index 00000000..9e4610ea
--- /dev/null
+++ b/lib/srfi/193.sld
@@ -0,0 +1,23 @@
+
+(define-library (srfi 193)
+ (export command-line command-name command-args script-file script-directory)
+ (import (scheme base) (chibi filesystem) (chibi pathname)
+ (only (meta) command-line raw-script-file))
+ (begin
+
+ (define (command-name)
+ (let ((filename (car (command-line))))
+ (and (not (= 0 (string-length filename)))
+ (path-strip-extension (path-strip-directory filename)))))
+
+ (define (command-args)
+ (cdr (command-line)))
+
+ (define (script-file)
+ (and raw-script-file
+ (path-normalize
+ (path-resolve raw-script-file (current-directory)))))
+
+ (define (script-directory)
+ (let ((filename (script-file)))
+ (and filename (string-append (path-directory filename) "/"))))))
diff --git a/lib/srfi/219.sld b/lib/srfi/219.sld
new file mode 100644
index 00000000..e8d2a752
--- /dev/null
+++ b/lib/srfi/219.sld
@@ -0,0 +1,9 @@
+(define-library (srfi 219)
+ (export define)
+ (import (rename (scheme base) (define native-define)))
+ (begin (define-syntax define
+ (syntax-rules ()
+ ((define ((name . outer-args) . args) . body)
+ (define (name . outer-args) (lambda args . body)))
+ ((define head . body)
+ (native-define head . body))))))
diff --git a/lib/srfi/219/test.sld b/lib/srfi/219/test.sld
new file mode 100644
index 00000000..8d19d49c
--- /dev/null
+++ b/lib/srfi/219/test.sld
@@ -0,0 +1,27 @@
+(define-library (srfi 219 test)
+ (export run-tests)
+ (import (chibi) (chibi test) (rename (srfi 219) (define define-219)))
+ (begin
+ (define (run-tests)
+ (test-group
+ "srfi-219: define higher-order lambda"
+
+ (let ()
+ (define-219 ((greet/prefix prefix) suffix)
+ (string-append prefix " " suffix))
+ (let ((greet (greet/prefix "Hello")))
+ (test "Hello there!" (greet "there!"))))
+
+ (let ()
+ (define-219 ((append-to . a) . b)
+ (apply append (append a b)))
+ (test '()
+ ((append-to '()) '()))
+ (test '(1 2 3 4 5 6 7 8)
+ ((append-to '(1 2) '(3 4)) '(5 6) '(7 8))))
+
+ (let ()
+ (define-219 (((jenga a b) c d))
+ (list a b c d))
+ (test '(1 2 3 4)
+ (((jenga 1 2) 3 4))))))))
diff --git a/main.c b/main.c
index 1374d45e..9c59957e 100644
--- a/main.c
+++ b/main.c
@@ -9,7 +9,8 @@
#include "chibi/eval.h"
#include "chibi/gc_heap.h"
-#define sexp_argv_symbol "command-line"
+#define sexp_command_line_symbol "command-line"
+#define sexp_raw_script_file_symbol "raw-script-file"
#define sexp_import_prefix "(import ("
#define sexp_import_suffix "))"
@@ -58,6 +59,9 @@ void sexp_usage(int err) {
#if SEXP_USE_IMAGE_LOADING
" -d <file> - dump an image file and exit\n"
" -i <file> - load an image file\n"
+#endif
+#if SEXP_USE_GREEN_THREADS
+ " -b - Make stdio nonblocking\n"
#endif
);
if (err == 0) exit_success();
@@ -211,7 +215,7 @@ static sexp check_exception (sexp ctx, sexp res) {
if (! sexp_oportp(err))
err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_print_exception(ctx, res, err);
- sexp_stack_trace(ctx, err);
+ sexp_print_exception_stack_trace(ctx, res, err);
#if SEXP_USE_MAIN_ERROR_ADVISE
if (sexp_envp(sexp_global(ctx, SEXP_G_META_ENV))) {
advise = sexp_eval_string(ctx, sexp_advice_environment, -1, sexp_global(ctx, SEXP_G_META_ENV));
@@ -316,7 +320,7 @@ sexp run_main (int argc, char **argv) {
main_symbol = "main";
/* skip option parsing since we can't pass `--` before the name of script */
/* to avoid misinterpret the name as options when the interpreter is */
- /* executed via `#!/usr/env/bin scheme-r7rs` shebang. */
+ /* executed via `#!/usr/bin/env scheme-r7rs` shebang. */
i = 1;
goto done_options;
}
@@ -516,6 +520,10 @@ sexp run_main (int argc, char **argv) {
#if SEXP_USE_MODULES
check_nonull_arg('t', arg);
suffix = strrchr(arg, '.');
+ if (suffix == NULL) {
+ fprintf(stderr, "trace expected: -t module.name.binding, e.g. srfi.1.iota, but got %s\n", arg);
+ break;
+ }
sym = sexp_intern(ctx, suffix + 1, -1);
*(char*)suffix = '\0';
impmod = make_import(sexp_trace_prefix, arg, sexp_trace_suffix);
@@ -545,15 +553,22 @@ sexp run_main (int argc, char **argv) {
done_options:
if (!quit || main_symbol != NULL) {
init_context();
- /* build argument list */
- if (i < argc)
- for (j=argc-1; j>=i; j--)
- args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
- /* if no script name, use interpreter name */
- if (i >= argc || main_module != NULL)
- args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
load_init(i < argc || main_symbol != NULL);
- sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args);
+ tmp = SEXP_FALSE;
+ if ((i < argc) && !main_symbol)
+ tmp = sexp_c_string(ctx,argv[i],-1);
+ sexp_env_define(
+ ctx, sexp_meta_env(ctx),
+ sym=sexp_intern(ctx, sexp_raw_script_file_symbol, -1), tmp);
+ for (j=argc-1; j>=i; j--)
+ args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
+ if (main_symbol)
+ args = sexp_cons(ctx, tmp=sexp_c_string(ctx,main_symbol,-1), args);
+ if (args == SEXP_NULL)
+ args = sexp_cons(ctx, tmp=sexp_c_string(ctx,"",-1), args);
+ sexp_set_parameter(
+ ctx, sexp_meta_env(ctx),
+ sym=sexp_intern(ctx, sexp_command_line_symbol, -1), args);
if (i >= argc && main_symbol == NULL) {
/* no script or main, run interactively */
repl(ctx, env);
diff --git a/mkfile b/mkfile
index 791f949b..1ef6e48a 100644
--- a/mkfile
+++ b/mkfile
@@ -7,7 +7,7 @@ MODDIR=/sys/lib/chibi-scheme
CHIBI=./$O.out
GENSTATIC=./tools/chibi-genstatic
-CPPFLAGS= -Iinclude -DPLAN9 -DSEXP_USE_GREEN_THREADS=0
+CPPFLAGS= -Iinclude -DPLAN9 -DSEXP_USE_GREEN_THREADS=0 -D__$objtype
CFLAGS= -p $CPPFLAGS
CFLAGS_STATIC=$CFLAGS -DSEXP_USE_STATIC_LIBS
@@ -35,7 +35,7 @@ COMPILED_LIBS = $CHIBI_COMPILED_LIBS $CHIBI_IO_COMPILED_LIBS \
</sys/src/cmd/mkone
clean:
- rm -f $CLEANFILES
+ rm -f $CLEANFILES *.[$OS] [$OS].out
clibs.$O: clibs.c
diff --git a/sexp.c b/sexp.c
index 11514564..94ef3b9e 100644
--- a/sexp.c
+++ b/sexp.c
@@ -279,11 +279,11 @@ static struct sexp_type_struct _sexp_type_specs[] = {
{(sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_PORT},
{(sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_PORT},
{(sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_FILENO},
- {(sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+ {(sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
{(sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
{(sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_MACRO, sexp_offsetof(macro, proc), 4, 4, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
{(sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_SYNCLO, sexp_offsetof(synclo, env), 4, 4, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
- {(sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+ {(sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_ENV, sexp_offsetof(env, parent), 3+(SEXP_USE_STABLE_ABI||SEXP_USE_RENAME_BINDINGS), 3+(SEXP_USE_STABLE_ABI||SEXP_USE_RENAME_BINDINGS), 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
{(sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, NULL},
{(sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
#if SEXP_USE_STABLE_ABI || SEXP_USE_DL
@@ -731,6 +731,7 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
sexp_exception_irritants(exn) = irritants;
sexp_exception_procedure(exn) = procedure;
sexp_exception_source(exn) = source;
+ sexp_exception_stack_trace(exn) = SEXP_FALSE;
return exn;
}
@@ -758,6 +759,22 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) {
return res;
}
+sexp sexp_user_exception_ls (sexp ctx, sexp self, const char *msg, int n, ...) {
+ int i;
+ va_list ap;
+ sexp_gc_var2(res, ir);
+ sexp_gc_preserve2(ctx, res, ir);
+ va_start(ap, n);
+ for (i=0, ir=SEXP_NULL; i < n; ++i) {
+ ir = sexp_cons(ctx, va_arg(ap, sexp), ir);
+ }
+ ir = sexp_nreverse(ctx, ir);
+ res = sexp_user_exception(ctx, self, msg, ir);
+ sexp_gc_release2(ctx);
+ va_end(ap);
+ return res;
+}
+
sexp sexp_file_exception (sexp ctx, sexp self, const char *ms, sexp ir) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
@@ -1799,7 +1816,9 @@ sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp v
}
return res;
}
+#endif /* SEXP_USE_WEAK_REFERENCES */
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
static sexp* sexp_fileno_cell(sexp ctx, sexp vec, int fd) {
sexp *data;
sexp_sint_t i, cell, len;
@@ -1809,7 +1828,9 @@ static sexp* sexp_fileno_cell(sexp ctx, sexp vec, int fd) {
if (len == 0)
return NULL;
data = sexp_vector_data(vec);
- for (i = 0, cell = (fd * FNV_PRIME) % len; i < len; i++, cell=(cell+1)%len)
+ cell = (fd * FNV_PRIME) % len;
+ if (cell < 0) cell += len;
+ for (i = 0; i < len; i++, cell=(cell+1)%len)
if (!sexp_ephemeronp(data[cell])
|| (sexp_filenop(sexp_ephemeron_key(data[cell]))
&& sexp_fileno_fd(sexp_ephemeron_key(data[cell])) == fd))
@@ -1820,8 +1841,11 @@ static sexp* sexp_fileno_cell(sexp ctx, sexp vec, int fd) {
static sexp sexp_lookup_fileno(sexp ctx, int fd) {
sexp* cell = sexp_fileno_cell(ctx, sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS), fd);
if (cell && sexp_ephemeronp(*cell)
- && sexp_fileno_fd(sexp_ephemeron_key(*cell)) == fd)
- return sexp_ephemeron_key(*cell);
+ && sexp_filenop(sexp_ephemeron_key(*cell))
+ && sexp_fileno_fd(sexp_ephemeron_key(*cell)) == fd) {
+ if (sexp_fileno_openp(sexp_ephemeron_key(*cell)))
+ return sexp_ephemeron_key(*cell);
+ }
return SEXP_FALSE;
}
@@ -1856,13 +1880,13 @@ static void sexp_insert_fileno(sexp ctx, sexp fileno) {
n++;
sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS) = sexp_make_fixnum(n);
}
-#endif
+#endif /* SEXP_USE_UNIFY_FILENOS_BY_NUMBER */
sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_closep) {
sexp_gc_var1(res);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, fd);
if (sexp_unbox_fixnum(fd) < 0) return SEXP_FALSE;
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
res = sexp_lookup_fileno(ctx, sexp_unbox_fixnum(fd));
if (sexp_filenop(res)) {
sexp_fileno_no_closep(res) = sexp_truep(no_closep);
@@ -1876,7 +1900,7 @@ sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_c
sexp_fileno_fd(res) = sexp_unbox_fixnum(fd);
sexp_fileno_openp(res) = 1;
sexp_fileno_no_closep(res) = sexp_truep(no_closep);
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
sexp_insert_fileno(ctx, res);
#endif
}
@@ -1903,7 +1927,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
#if SEXP_USE_FOLD_CASE_SYMS
sexp_port_fold_casep(p) = sexp_truep(sexp_global(ctx, SEXP_G_FOLD_CASE_P));
#endif
-#if SEXP_USE_WEAK_REFERENCES
+#if SEXP_USE_UNIFY_FILENOS_BY_NUMBER
/* if the fd was previously opened by a non-stream port, preserve it */
/* here to avoid gc timing issues */
if (in && fileno(in) >= 0) {
@@ -3052,7 +3076,7 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex
#if SEXP_USE_UNIFORM_VECTOR_LITERALS
((sexp_uvector_prefix(et) == 'u') || (sexp_uvector_prefix(et) == 's')) ?
#endif
- !(sexp_exact_integerp(tmp) && sexp_sint_value(tmp) >= min
+ !((min == 0 && sexp_bignump(tmp) ? sexp_bignum_sign(tmp) > 0 : sexp_exact_integerp(tmp) && sexp_sint_value(tmp) >= min)
&& (sexp_sint_value(tmp) < 0 || sexp_uint_value(tmp) <= max))
#if SEXP_USE_UNIFORM_VECTOR_LITERALS
: ((sexp_uvector_prefix(et) == 'c') ? !sexp_numberp(tmp) :
diff --git a/tests/build/build-opts.txt b/tests/build/build-opts.txt
index 04e99e52..279a53d5 100644
--- a/tests/build/build-opts.txt
+++ b/tests/build/build-opts.txt
@@ -25,6 +25,7 @@ CPPFLAGS=-DSEXP_USE_2010_EPOCH=0
CPPFLAGS=-DSEXP_USE_CHECK_STACK=0
CPPFLAGS=-DSEXP_USE_EXTENDED_FCALL=0
CPPFLAGS=-DSEXP_USE_WEAK_REFERENCES=0
+CPPFLAGS=-DSEXP_USE_UNIFY_FILENOS_BY_NUMBER=1
CPPFLAGS=-DSEXP_USE_OBJECT_BRACE_LITERALS=0
CPPFLAGS=-DSEXP_USE_TAIL_JUMPS=0
CPPFLAGS=-DSEXP_USE_RESERVE_OPCODE=0
@@ -36,6 +37,7 @@ CPPFLAGS=-DSEXP_USE_MUTABLE_STRINGS=0
CPPFLAGS=-DSEXP_USE_STRING_INDEX_TABLE=1
CPPFLAGS=-DSEXP_USE_STRICT_TOPLEVEL_BINDINGS=1
CPPFLAGS=-DSEXP_USE_FIXED_CHUNK_SIZE_HEAPS=1
+CPPFLAGS=-DSEXP_USE_FULL_SOURCE_INFO=0
CPPFLAGS=-DSEXP_USE_NO_FEATURES=1
CFLAGS=-std=c89
CFLAGS=-m32;LDFLAGS=-m32
diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm
index 8a200931..e66a6480 100644
--- a/tests/lib-tests.scm
+++ b/tests/lib-tests.scm
@@ -34,7 +34,9 @@
(rename (srfi 158 test) (run-tests run-srfi-158-tests))
(rename (srfi 160 test) (run-tests run-srfi-160-tests))
(rename (srfi 166 test) (run-tests run-srfi-166-tests))
+ (rename (srfi 219 test) (run-tests run-srfi-219-tests))
(rename (scheme bytevector-test) (run-tests run-scheme-bytevector-tests))
+ (rename (chibi assert-test) (run-tests run-assert-tests))
(rename (chibi base64-test) (run-tests run-base64-tests))
(rename (chibi bytevector-test) (run-tests run-bytevector-tests))
(rename (chibi crypto md5-test) (run-tests run-md5-tests))
@@ -103,7 +105,9 @@
(run-srfi-158-tests)
(run-srfi-160-tests)
(run-srfi-166-tests)
+(run-srfi-219-tests)
(run-scheme-bytevector-tests)
+(run-assert-tests)
(run-base64-tests)
(run-bytevector-tests)
(run-doc-tests)
diff --git a/tools/chibi-ffi b/tools/chibi-ffi
index d8cd34a1..55081c12 100755
--- a/tools/chibi-ffi
+++ b/tools/chibi-ffi
@@ -1261,20 +1261,39 @@
(cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
args))
-(define (write-scheme->c expr)
+(define (string-has-prefix? str prefix)
+ (let ((prefix-len (string-length prefix)))
+ (and (>= (string-length str) prefix-len)
+ (equal? (substring str 0 prefix-len) prefix))))
+
+(define (write-scheme->c expr . o)
(define (write-numeric-arg x)
(if (symbol? x)
- (cat "sexp_unbox_fixnum(" x ")")
+ (let ((func (and (pair? o) (car o)))
+ (sym-name (symbol->string x)))
+ (if (and func
+ (string-has-prefix? sym-name "arg")
+ (unsigned-int-type?
+ (type-base
+ (list-ref (func-c-args func)
+ (string->number (substring sym-name 3))))))
+ (cat "sexp_uint_value(" x ")")
+ (cat "sexp_sint_value(" x ")")))
(write-scheme->c x)))
(if (pair? expr)
(case (car expr)
((+ - * / %)
- (write-scheme->c (cadr expr))
- (for-each
- (lambda (x)
- (cat " " (car expr) " ")
- (write-numeric-arg x))
- (cddr expr)))
+ (let ((expr (if (and (null? (cddr expr)) (memq (car expr) '(- /)))
+ `(,(car expr)
+ ,(if (eq? '- (car expr)) 0 1)
+ ,@(cdr expr))
+ expr)))
+ (write-scheme->c (cadr expr))
+ (for-each
+ (lambda (x)
+ (cat " " (car expr) " ")
+ (write-numeric-arg x))
+ (cddr expr))))
((< <= == != >= >)
(let lp ((ls (cdr expr)))
(cat "(" (lambda () (write-numeric-arg (car ls))) " " (car expr)
@@ -1284,6 +1303,15 @@
((pair? (cddr ls))
(display " && ")
(lp (cdr ls))))))
+ ((expt)
+ (if (and (integer? (cadr expr))
+ (integer? (car (cddr expr))))
+ (write-scheme->c (expt (cadr expr) (car (cddr expr))))
+ (cat "pow("
+ (lambda () (write-numeric-arg (cadr expr)))
+ ", "
+ (lambda () (write-numeric-arg (car (cddr expr))))
+ ")")))
(else
(write (scheme-procedure->c (car expr)))
(display "(")
@@ -1296,17 +1324,47 @@
(display ")")))
(write expr)))
+(define (extract-irritants expr)
+ (reverse
+ (let lp ((args (cdr expr))
+ (irr '()))
+ (cond
+ ((null? args) irr)
+ ((identifier? (car args)) (lp (cdr args) (cons (car args) irr)))
+ ((pair? (car args))
+ ;; pass length rather than vector objects to avoid huge error messages
+ (if (and (memq (caar args)
+ '(length bytevector-length u8vector-length uvector-length))
+ (pair? (cdar args))
+ (identifier? (car (cdar args))))
+ (lp (cdr args)
+ ;; sexp_length returns sexp, the others int
+ (cons (if (eq? 'length (caar args))
+ (car args)
+ (list 'sexp_make_fixnum (car args)))
+ irr))
+ (lp (cdr args) (lp (cdar args) irr))))
+ (else (lp (cdr args) irr))))))
+
(define (write-assertions func asserts)
(for-each
(lambda (assert)
- (cat " if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
- " return sexp_user_exception(ctx, self, \"assertion failed: \" "
- (call-with-output-string
- (lambda (out)
- (write (call-with-output-string
- (lambda (out) (write assert out))) out)))
- ", SEXP_NULL);\n"
- " }\n"))
+ (let ((irr-ls (extract-irritants assert)))
+ (cat " if (!(" (lambda () (write-scheme->c assert func)) ")) {\n"
+ " return sexp_user_exception_ls(ctx, self, \"assertion failed: \" "
+ (call-with-output-string
+ (lambda (out)
+ (write (call-with-output-string
+ (lambda (out) (write assert out))) out)))
+ ", " (length irr-ls)
+ (lambda ()
+ (for-each
+ (lambda (irr)
+ (cat ", ")
+ (write-scheme->c irr))
+ irr-ls))
+ ");\n"
+ " }\n")))
asserts))
(define (scheme-procedure->c name)
diff --git a/vm.c b/vm.c
index 1fbb89b4..4ce48e1b 100644
--- a/vm.c
+++ b/vm.c
@@ -41,38 +41,78 @@ static sexp sexp_lookup_source_info (sexp src, int ip) {
}
#endif
-void sexp_stack_trace (sexp ctx, sexp out) {
- int i, fp=sexp_context_last_fp(ctx);
- sexp self, bc, src, *stack=sexp_stack_data(sexp_context_stack(ctx));
- if (! sexp_oportp(out))
- out = sexp_current_error_port(ctx);
+sexp sexp_get_stack_trace (sexp ctx) {
+ sexp_sint_t i, fp=sexp_context_last_fp(ctx);
+ sexp self, bc, src, *stack = sexp_stack_data(sexp_context_stack(ctx));
+ sexp_gc_var2(res, cell);
+ sexp_gc_preserve2(ctx, res, cell);
+ res = SEXP_NULL;
for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
self = stack[i+2];
if (self && sexp_procedurep(self)) {
- sexp_write_string(ctx, " called from ", out);
bc = sexp_procedure_code(self);
- if (sexp_symbolp(sexp_bytecode_name(bc)))
- sexp_write(ctx, sexp_bytecode_name(bc), out);
- else
- sexp_write_string(ctx, "<anonymous>", out);
src = sexp_bytecode_source(bc);
#if SEXP_USE_FULL_SOURCE_INFO
if (src && sexp_vectorp(src))
src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
#endif
- if (src && sexp_pairp(src)) {
- if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
- sexp_write_string(ctx, " on line ", out);
- sexp_write(ctx, sexp_cdr(src), out);
- }
- if (sexp_stringp(sexp_car(src))) {
- sexp_write_string(ctx, " of file ", out);
- sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
- }
+ cell = sexp_cons(ctx, self, src ? src : SEXP_FALSE);
+ res = sexp_cons(ctx, cell, res);
+ }
+ }
+ res = sexp_nreverse(ctx, res);
+ sexp_gc_release2(ctx);
+ return res;
+}
+
+void sexp_print_extracted_stack_trace (sexp ctx, sexp trace, sexp out) {
+ sexp self, bc, src, ls;
+ if (! sexp_oportp(out))
+ out = sexp_current_error_port(ctx);
+ for (ls = trace; sexp_pairp(ls); ls = sexp_cdr(ls)) {
+ self = sexp_caar(ls);
+ bc = sexp_procedure_code(self);
+ src = sexp_cdar(ls);
+ sexp_write_string(ctx, " called from ", out);
+ if (sexp_symbolp(sexp_bytecode_name(bc)))
+ sexp_write(ctx, sexp_bytecode_name(bc), out);
+ else
+ sexp_write_string(ctx, "<anonymous>", out);
+ if (sexp_pairp(src)) {
+ if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
+ sexp_write_string(ctx, " on line ", out);
+ sexp_write(ctx, sexp_cdr(src), out);
+ } else {
+ sexp_write_string(ctx, " bad source line: ", out);
+ sexp_write(ctx, src, out);
+ }
+ if (sexp_stringp(sexp_car(src))) {
+ sexp_write_string(ctx, " of file ", out);
+ sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
+ } else {
+ sexp_write_string(ctx, " bad source file: ", out);
+ sexp_write(ctx, src, out);
}
- sexp_write_char(ctx, '\n', out);
}
+ sexp_write_char(ctx, '\n', out);
+ }
+}
+
+sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out) {
+ sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn);
+ sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
+ if (sexp_pairp(sexp_exception_stack_trace(exn))) {
+ sexp_print_extracted_stack_trace(ctx, sexp_exception_stack_trace(exn), out);
}
+ return SEXP_VOID;
+}
+
+void sexp_stack_trace (sexp ctx, sexp out) {
+ sexp_gc_var1(trace);
+ sexp_gc_preserve1(ctx, trace);
+ trace = sexp_get_stack_trace(ctx);
+ sexp_print_extracted_stack_trace(ctx, trace, out);
+ sexp_gc_release1(ctx);
}
sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
@@ -637,6 +677,13 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
}
sexp_context_lambda(ctx2) = lambda;
sexp_gc_preserve2(ctx, tmp, bc);
+#if SEXP_USE_FULL_SOURCE_INFO
+ tmp = sexp_cons(ctx, SEXP_NEG_ONE, sexp_lambda_source(lambda));
+ tmp = sexp_cons(ctx, tmp, SEXP_NULL);
+#else
+ tmp = sexp_lambda_source(lambda);
+#endif
+ sexp_bytecode_source(sexp_context_bc(ctx2)) = tmp;
tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
/* allocate space for local vars */
k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
@@ -678,9 +725,6 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
sexp_context_exception(ctx) = bc;
} else {
sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
-#if ! SEXP_USE_FULL_SOURCE_INFO
- sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
-#endif
if (sexp_nullp(fv)) {
/* shortcut, no free vars */
tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
@@ -1130,6 +1174,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
if (!sexp_exceptionp(_ARG1)) {
_ARG1 = sexp_make_exception(ctx, SEXP_UNCAUGHT, SEXP_FALSE, _ARG1, self, SEXP_FALSE);
}
+ sexp_context_top(ctx) = top;
+ sexp_exception_stack_trace(_ARG1) = sexp_get_stack_trace(ctx);
goto end_loop;
}
stack[top] = SEXP_ONE;
@@ -2098,18 +2144,12 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
errno = 0;
#endif
i = sexp_read_char(ctx, _ARG1);
-#if SEXP_USE_UTF8_STRINGS
- if (i >= 0x80)
- _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
- else
-#endif
if (i == EOF) {
- if (!sexp_port_openp(_ARG1))
+ if (!sexp_port_openp(_ARG1)) {
sexp_raise("read-char: port is closed", _ARG1);
- else
#if SEXP_USE_GREEN_THREADS
- if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
- && (errno == EAGAIN)) {
+ } else if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
+ && (errno == EAGAIN)) {
if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
/* TODO: block and unblock */
if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
@@ -2118,9 +2158,14 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp_poll_input(ctx, _ARG1);
fuel = 0;
ip--; /* try again */
- } else
#endif
+ } else {
_ARG1 = SEXP_EOF;
+ }
+#if SEXP_USE_UTF8_STRINGS
+ } else if (i >= 0x80) {
+ _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
+#endif
} else {
if (i == '\n') sexp_port_line(_ARG1)++;
_ARG1 = sexp_make_character(i);
Debdiff
[The following lists of changes regard files as different if they have different names, permissions or owners.]
Files in second set of .debs but not in first
-rw-r--r-- root/root /usr/lib/debug/.build-id/00/2dbc51f53cd2bc3ca0163629311d2504ec5c84.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/02/1c3fc9b6a76a5e17bcb100f4f4d3d5862476b4.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/09/d6b7fc12c294be74de62c118c145ff3d6131bc.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/0b/7a4db2070d36f817a9e2575e5b0c21e6667d97.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/19/aeca292d6cefa2caf6d6ec910c63191e819858.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/1e/7c8dd4b0c66956a83955936f5738c7d2664b04.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/1e/ecf03ba9dc019cf6946c7e8876168e6fe4207b.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/3f/2bddf885d9e8ecd4f8ba047a6a1e4a8f2eed1a.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/44/b850c1ebbbf0ea715b287dcdf91f7c6e9e30fb.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/45/23e8ec13b75e3dce70acd2a8820f59a057d2be.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/46/4298991972ab37de06b12adb76c9f049686fa4.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/4e/7d5671ec06a4170c3d2120194847e46d7cb143.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/52/bd2449776df801d488948d54438426102640de.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/6c/617283112c48bf9602908fc09f8afcef88c2a6.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/6f/838cf220e3af7eeefb517c25266334f568fd4f.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/76/857e41b55ce358c26d9b70114ebd1c12032b50.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/7d/d98944e638d9f2ce360715c71dfa9f5ace1e28.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/81/f7ecd9447453e403e39cf5d5d895413f7d1dd2.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/86/609eb771c922d70e8302fa478a1908ca7bc867.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/8c/7fe7053f634cd04a09ca086c1fac3d509875b0.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/9a/c103b9844ebd1f7b14b4d706d5be182bf394df.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/a1/79a187eca6064a10c687f3b9308352b4db06ad.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/a5/775ea91c091b0e35cf9814b682d4b3e7519362.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/b4/3ae77beb8bcdb91b632b888f8ad4a78b4a51b2.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/bf/3694992c5f31f9fd314c8ae0c365b3b1d5c02e.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/c0/5b73733eaf28616ab5fd3977f11903aa533fff.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/c2/b3c1eae4c0796772659eec56558ae2f591b000.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/c5/c08133fa5789675c5243f26d6e09ce3a1a05b0.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/e3/b6c418a3790d51c81501b8803f5a5e891cce95.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/e5/dee261013b02595eeee92e9fc7cb9074f17712.debug -rw-r--r-- root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so.0.10.0 -rw-r--r-- root/root /usr/share/chibi/chibi/assert-test.sld -rw-r--r-- root/root /usr/share/chibi/chibi/assert.sld -rw-r--r-- root/root /usr/share/chibi/srfi/179.sld -rw-r--r-- root/root /usr/share/chibi/srfi/179/base.scm -rw-r--r-- root/root /usr/share/chibi/srfi/179/base.sld -rw-r--r-- root/root /usr/share/chibi/srfi/179/test.sld -rw-r--r-- root/root /usr/share/chibi/srfi/179/transforms.scm -rw-r--r-- root/root /usr/share/chibi/srfi/193.sld -rw-r--r-- root/root /usr/share/chibi/srfi/219.sld -rw-r--r-- root/root /usr/share/doc/chibi-scheme/lib/chibi/assert.html lrwxrwxrwx root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so -> libchibi-scheme.so.0.10.0 lrwxrwxrwx root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so.0 -> libchibi-scheme.so.0.10.0
Files in first set of .debs but not in second
-rw-r--r-- root/root /usr/lib/debug/.build-id/09/43afd522158eedc1599f0b9ca2d6141e5c2864.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/0c/371a3e2415ef11237dae62e60688c316430ef3.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/17/3fa23599fba8f09154e6206b5141b5242f6d60.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/30/1966628d4fc7070e0c4ed00f50f123d3033227.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/3f/f9c0370300155400b37d900b99a1c7fdcaea98.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/45/5b13b2371482a3e78f302c7a91c8b4121445ef.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/52/e6dbd628e0c6180a58490630cf4b192c2ea211.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/5d/1e09b21e85a915dee7255fdc1600767493d20a.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/64/5052b3bf6f744d4e69b31c02de7334fe8f993e.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/6b/aca89df678b03b65fdb6ed95cf1822fa190013.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/70/bccc85636fe00d058dfa4f00f868b680cdb4d3.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/77/58701706719999071ed5ce9eed61c877139bae.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/83/1357fb4262a73306c71963e19939759b15ea57.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/85/e2d8880b2a4f986ca0deda2a6223745b382f55.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/97/0727847f3c2027e666d2ca484ca8a7b15dd5bb.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/9f/d1d94dca070834630c059f50bbe0ee29932801.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/a2/30cbf438d45006079c9f12fc8e8bac5e790886.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/a3/a37e3a1298a2a1873f4263785504b1f410eaed.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/aa/12a9ab766f082628d8806a141b43addfd544cf.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/b1/b7c9a6b1071d048c0123318ba9ff6aeb5ba592.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/b5/a5fb4e49afb6253c77e6b4fdfcdcba524d0aaa.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/db/2fd7484c1a43845b2011bcb60eec2b9d626619.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/db/6dd370da0f43ebbf71cd9d32989f23bb0dca34.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/e4/a8e37bf2474db2bf6b4bc357c2c000742c6301.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/e7/d2f5e607cdd522a633edf699df1e8a7a883572.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/f0/0240ba71bc8028b11d12f73129026452f15618.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/f0/4cb72cb8612d0a838e6b28a038a7ce4b6968e0.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/f2/7f01253257ff638ca9b1fbc9005ebe12dedff5.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/f2/87416c901f85c05f303ffbd9033f7f6c4f415d.debug -rw-r--r-- root/root /usr/lib/debug/.build-id/fe/811622270534f6f5608b2fbc0f3a6b57dbabfc.debug -rw-r--r-- root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so.0.9.1 lrwxrwxrwx root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so -> libchibi-scheme.so.0.9.1 lrwxrwxrwx root/root /usr/lib/x86_64-linux-gnu/libchibi-scheme.so.0 -> libchibi-scheme.so.0.9.1
Control files of package chibi-scheme: lines which differ (wdiff format)
Depends: libc6 (>= 2.34), libchibi-scheme0 (>= 0.8.0) 0.10-1~jan+nur1)
No differences were encountered between the control files of package chibi-scheme-common
Control files of package chibi-scheme-dbgsym: lines which differ (wdiff format)
Build-Ids: e7d2f5e607cdd522a633edf699df1e8a7a883572 1eecf03ba9dc019cf6946c7e8876168e6fe4207b
No differences were encountered between the control files of package chibi-scheme-doc
No differences were encountered between the control files of package chibi-scheme-images
No differences were encountered between the control files of package libchibi-scheme-dev
Control files of package libchibi-scheme-ffi: lines which differ (wdiff format)
Depends: libc6 (>= 2.34), libchibi-scheme0 (>= 0.9.0) 0.10-1~jan+nur1)
Control files of package libchibi-scheme-ffi-dbgsym: lines which differ (wdiff format)
Build-Ids: 0943afd522158eedc1599f0b9ca2d6141e5c2864 0c371a3e2415ef11237dae62e60688c316430ef3 173fa23599fba8f09154e6206b5141b5242f6d60 301966628d4fc7070e0c4ed00f50f123d3033227 3ff9c0370300155400b37d900b99a1c7fdcaea98 455b13b2371482a3e78f302c7a91c8b4121445ef 52e6dbd628e0c6180a58490630cf4b192c2ea211 5d1e09b21e85a915dee7255fdc1600767493d20a 645052b3bf6f744d4e69b31c02de7334fe8f993e 6baca89df678b03b65fdb6ed95cf1822fa190013 70bccc85636fe00d058dfa4f00f868b680cdb4d3 7758701706719999071ed5ce9eed61c877139bae 831357fb4262a73306c71963e19939759b15ea57 85e2d8880b2a4f986ca0deda2a6223745b382f55 970727847f3c2027e666d2ca484ca8a7b15dd5bb 9fd1d94dca070834630c059f50bbe0ee29932801 a230cbf438d45006079c9f12fc8e8bac5e790886 a3a37e3a1298a2a1873f4263785504b1f410eaed aa12a9ab766f082628d8806a141b43addfd544cf b1b7c9a6b1071d048c0123318ba9ff6aeb5ba592 b5a5fb4e49afb6253c77e6b4fdfcdcba524d0aaa db2fd7484c1a43845b2011bcb60eec2b9d626619 db6dd370da0f43ebbf71cd9d32989f23bb0dca34 e4a8e37bf2474db2bf6b4bc357c2c000742c6301 f00240ba71bc8028b11d12f73129026452f15618 f27f01253257ff638ca9b1fbc9005ebe12dedff5 f287416c901f85c05f303ffbd9033f7f6c4f415d fe811622270534f6f5608b2fbc0f3a6b57dbabfc 002dbc51f53cd2bc3ca0163629311d2504ec5c84 021c3fc9b6a76a5e17bcb100f4f4d3d5862476b4 09d6b7fc12c294be74de62c118c145ff3d6131bc 0b7a4db2070d36f817a9e2575e5b0c21e6667d97 19aeca292d6cefa2caf6d6ec910c63191e819858 1e7c8dd4b0c66956a83955936f5738c7d2664b04 3f2bddf885d9e8ecd4f8ba047a6a1e4a8f2eed1a 44b850c1ebbbf0ea715b287dcdf91f7c6e9e30fb 4523e8ec13b75e3dce70acd2a8820f59a057d2be 464298991972ab37de06b12adb76c9f049686fa4 4e7d5671ec06a4170c3d2120194847e46d7cb143 52bd2449776df801d488948d54438426102640de 6c617283112c48bf9602908fc09f8afcef88c2a6 6f838cf220e3af7eeefb517c25266334f568fd4f 76857e41b55ce358c26d9b70114ebd1c12032b50 81f7ecd9447453e403e39cf5d5d895413f7d1dd2 86609eb771c922d70e8302fa478a1908ca7bc867 8c7fe7053f634cd04a09ca086c1fac3d509875b0 9ac103b9844ebd1f7b14b4d706d5be182bf394df a179a187eca6064a10c687f3b9308352b4db06ad a5775ea91c091b0e35cf9814b682d4b3e7519362 b43ae77beb8bcdb91b632b888f8ad4a78b4a51b2 bf3694992c5f31f9fd314c8ae0c365b3b1d5c02e c05b73733eaf28616ab5fd3977f11903aa533fff c2b3c1eae4c0796772659eec56558ae2f591b000 c5c08133fa5789675c5243f26d6e09ce3a1a05b0 e3b6c418a3790d51c81501b8803f5a5e891cce95 e5dee261013b02595eeee92e9fc7cb9074f17712
No differences were encountered between the control files of package libchibi-scheme0
Control files of package libchibi-scheme0-dbgsym: lines which differ (wdiff format)
Build-Ids: f04cb72cb8612d0a838e6b28a038a7ce4b6968e0 7dd98944e638d9f2ce360715c71dfa9f5ace1e28