From cb6e423dcf816bbe992d5e664b85d3ba6af4d3f0 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 23 Oct 2019 00:29:52 -0700
Subject: [PATCH] Create a new directory src/libraries, to hold R7RS libraries.
Initially populate this with (srfi 133) and (mit inline-testing), plus unit
tests for the former.
---
src/Makefile.in | 14 +-
src/Setup.sh | 3 +-
src/Tags.sh | 1 +
src/configure.ac | 5 +-
src/etc/create-makefiles.sh | 2 +-
src/libraries/Makefile-fragment | 6 +
src/libraries/compile.scm | 32 ++
src/libraries/inline-testing.scm | 450 ++++++++++++++++++++++++
src/libraries/srfi-133.scm | 562 ++++++++++++++++++++++++++++++
tests/libraries/test-srfi-133.scm | 219 ++++++++++++
10 files changed, 1289 insertions(+), 5 deletions(-)
create mode 100644 src/libraries/Makefile-fragment
create mode 100644 src/libraries/compile.scm
create mode 100644 src/libraries/inline-testing.scm
create mode 100644 src/libraries/srfi-133.scm
create mode 100644 tests/libraries/test-srfi-133.scm
diff --git a/src/Makefile.in b/src/Makefile.in
index 2e966f312..39d140d18 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -68,7 +68,7 @@ LIARC_BOOT_BUNDLES = compiler cref sf star-parser
LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) ffi sos ssp xml
SUBDIRS = $(INSTALLED_SUBDIRS) win32 xdoc
-INSTALLED_SUBDIRS = microcode runtime $(OPTION_SUBDIRS) $(LIARC_BUNDLES)
+INSTALLED_SUBDIRS = microcode runtime libraries $(OPTION_SUBDIRS) $(LIARC_BUNDLES)
BASICS_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
OPTION_SUBDIRS = @OPTION_SUBDIRS@
@@ -557,6 +557,17 @@ ssp/ssp-unx.pkd: $(SSP_CREF_TARGETS)
### cross-compiler. We should have a way to do that, and eliminate
### these.
+################
+# Libraries
+################
+
+.PHONY: compile-libraries
+compile-libraries: lib/all.com
+compile-libraries: microcode/scheme
+ (echo '(with-working-directory-pathname "libraries"' && \
+ echo ' (lambda () (load "compile")))') \
+ | ./run-build --batch-mode --no-init-file
+
################
# blowfish
################
@@ -772,6 +783,7 @@ cross-target: $(X11_SCREEN_BUILD_TARGETS)
cross-target: lib/all.com
cross-target: lib/runtime.com
cross-target: microcode/scheme
+cross-target: compile-libraries
################
# Microcode
diff --git a/src/Setup.sh b/src/Setup.sh
index 204ce6af4..b8f9e1bed 100755
--- a/src/Setup.sh
+++ b/src/Setup.sh
@@ -78,7 +78,7 @@ fi
. etc/functions.sh
-INSTALLED_SUBDIRS="cref ffi sf sos ssp star-parser xml"
+INSTALLED_SUBDIRS="cref ffi libraries sf sos ssp star-parser xml"
PLUGIN_SUBDIRS="blowfish edwin gdbm imail pgsql mcrypt x11 x11-screen"
OTHER_SUBDIRS="6001 compiler runtime win32 xdoc microcode"
@@ -93,6 +93,7 @@ maybe_link lib/cref ../cref
maybe_link lib/edwin ../edwin
maybe_link lib/ffi ../ffi
maybe_link lib/imail ../imail
+maybe_link lib/libraries ../libraries
maybe_link lib/runtime ../runtime
maybe_link lib/sf ../sf
maybe_link lib/sos ../sos
diff --git a/src/Tags.sh b/src/Tags.sh
index 94c15a329..cda90aff2 100755
--- a/src/Tags.sh
+++ b/src/Tags.sh
@@ -37,6 +37,7 @@ DEFAULT_SUBDIRS=( \
ffi \
gdbm \
imail \
+ libraries \
mcrypt \
microcode \
pgsql \
diff --git a/src/configure.ac b/src/configure.ac
index 5a4f75450..4e150b2ff 100644
--- a/src/configure.ac
+++ b/src/configure.ac
@@ -1,6 +1,6 @@
dnl Process this file with autoconf to produce a configure script.
-AC_INIT([MIT/GNU Scheme], [10.1.2], [bug-mit-scheme@gnu.org], [mit-scheme])
+AC_INIT([MIT/GNU Scheme], [10.90], [bug-mit-scheme@gnu.org], [mit-scheme])
AC_CONFIG_SRCDIR([microcode/boot.c])
AC_CONFIG_AUX_DIR([microcode])
AC_PROG_MAKE_SET
@@ -441,6 +441,7 @@ Makefile.tools
compiler/Makefile
cref/Makefile
ffi/Makefile
+libraries/Makefile
runtime/Makefile
sf/Makefile
sos/Makefile
@@ -464,7 +465,7 @@ if test x"${mit_scheme_native_code}" = xc; then
(cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
done
mkdir -p lib/lib
- for BUNDLE in 6001 compiler cref ffi sf sos ssp star-parser \
+ for BUNDLE in 6001 compiler cref ffi libraries sf sos ssp star-parser \
xdoc xml; do
SO=${BUNDLE}.so
(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh
index 37ef90bf0..06408a314 100755
--- a/src/etc/create-makefiles.sh
+++ b/src/etc/create-makefiles.sh
@@ -57,7 +57,7 @@ EOF
run_cmd rm -f compiler/machine compiler/compiler.pkg
-for SUBDIR in ${BUNDLES} runtime win32; do
+for SUBDIR in ${BUNDLES} runtime libraries win32; do
echo "creating ${SUBDIR}/Makefile.in"
rm -f ${SUBDIR}/Makefile.in
cat etc/std-makefile-prefix ${SUBDIR}/Makefile-fragment \
diff --git a/src/libraries/Makefile-fragment b/src/libraries/Makefile-fragment
new file mode 100644
index 000000000..07bcfb2ff
--- /dev/null
+++ b/src/libraries/Makefile-fragment
@@ -0,0 +1,6 @@
+TARGET_DIR = $(AUXDIR)/libraries
+
+install:
+ $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
+ $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
diff --git a/src/libraries/compile.scm b/src/libraries/compile.scm
new file mode 100644
index 000000000..0579e390d
--- /dev/null
+++ b/src/libraries/compile.scm
@@ -0,0 +1,32 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(for-each (lambda (pn)
+ (if (not (string=? "compile" (pathname-name pn)))
+ (compile-file pn)))
+ (directory-read
+ (merge-pathnames "*.scm"
+ (directory-pathname (current-load-pathname)))))
\ No newline at end of file
diff --git a/src/libraries/inline-testing.scm b/src/libraries/inline-testing.scm
new file mode 100644
index 000000000..064342e00
--- /dev/null
+++ b/src/libraries/inline-testing.scm
@@ -0,0 +1,450 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Simple in-line tests
+
+;;; The idea behind this tester is that it executes a file of expressions, in
+;;; order, except that some of the expressions will be annotated with
+;;; "expectations" that must be satisfied by the evaluation of the corresponding
+;;; expression.
+
+;;; For example,
+;;;
+;;; (fib 20)
+;;; 'expect eqv? 6765
+;;;
+;;; is a trivial example. There are also expectations involving
+;;; printed output, and others can be defined as needed.
+
+;;; This style of testing closely resembles a transcript, and has the advantage
+;;; that the code can just be loaded normally and it does the same thing without
+;;; checking the expectations.
+
+;;; This was developed as a response to GJS's dislike of the standard testing
+;;; framework. Gerry prefers to just type at the interpreter and keep a
+;;; transcript of the results around; this closely mirrors his testing style.
+
+(define-library (mit inline-testing)
+ (import (scheme base)
+ (scheme char)
+ (scheme cxr)
+ (scheme eval)
+ (scheme read)
+ (scheme write)
+ (srfi 1)
+ (srfi 6)
+ (mit library)
+ (only (mit legacy runtime)
+ ->namestring
+ alist->bundle
+ bundle
+ call-with-output-string
+ call-with-truncated-output-string
+ call-with-truncated-output-string
+ condition?
+ default-object
+ default-object?
+ environment?
+ fresh-line
+ keyword-option-parser
+ make-bundle-predicate
+ make-settable-parameter
+ nearest-repl/environment
+ pathname-default-type
+ pp
+ read-file
+ warn
+ with-notification
+ write-to-string))
+ (export define-error-expectation
+ define-output-expectation
+ define-value-expectation
+ run-inline-tests)
+ (begin
+
+(define (run-inline-tests filename . options)
+ (let-values (((*eval *env *notify? *summarize?)
+ (run-option-parser options 'run-inline-tests))
+ ((exprs imports) (read-test-file filename)))
+ (let ((groups (parse-expression-groups exprs)))
+ (parameterize ((test-eval *eval)
+ (test-env (if imports
+ (apply environment imports)
+ *env))
+ (notify? *notify?)
+ (summarize? *summarize?))
+ (summarize-test-results
+ (notify-filename filename
+ (lambda ()
+ (execute-expression-groups groups))))))))
+
+(define run-option-parser
+ (keyword-option-parser
+ (list (list 'eval procedure? (lambda () eval))
+ (list 'env environment? nearest-repl/environment)
+ (list 'notify? boolean? (lambda () #f))
+ (list 'summarize? boolean? (lambda () #t)))))
+
+(define test-eval (make-parameter (default-object)))
+(define test-env (make-parameter (default-object)))
+(define notify? (make-parameter (default-object)))
+(define summarize? (make-parameter (default-object)))
+
+(define (notify-filename filename thunk)
+ (if (notify?)
+ (with-notification
+ (lambda (port)
+ (display "loading test: " port)
+ (write (->namestring filename) port))
+ thunk)
+ (thunk)))
+
+(define (read-test-file filename)
+ (let ((pn (pathname-default-type filename "scm")))
+ (let ((source (read-r7rs-source pn)))
+ (if source
+ (let ((program (r7rs-source-program source)))
+ (if (not program)
+ (error "Inline testing requires a program:" source))
+ (if (not (null? (r7rs-source-libraries source)))
+ (error "Inline testing doesn't support inline libraries:"
+ source))
+ (values (cdr (car (library-parsed-contents program)))
+ (library-parsed-imports program)))
+ (values (read-file pn) #f)))))
+
+(define (parse-expression-groups exprs)
+ (if (pair? exprs)
+ (let ((to-eval (car exprs)))
+ (let ((r (parse-expectations (cdr exprs))))
+ (cons (make-group to-eval (reverse (car r)))
+ (parse-expression-groups (cdr r)))))
+ '()))
+
+(define make-group cons)
+(define group-expression car)
+(define group-expectations cdr)
+
+(define (parse-expectations exprs)
+ (let ((expectation
+ (and (pair? exprs)
+ (parse-expectation (car exprs)))))
+ (if expectation
+ (let ((r (parse-expectations (cdr exprs))))
+ (cons (cons expectation (car r))
+ (cdr r)))
+ (cons (list) exprs))))
+
+(define (parse-expectation expr)
+ (and (is-quotation? expr)
+ (let ((text (quotation-text expr)))
+ (let loop ((rules expectation-rules))
+ (if (pair? rules)
+ (or (match-rule (car rules) text)
+ (loop (cdr rules)))
+ (begin
+ (warn "Unrecognized expectation:" text)
+ #f))))))
+
+(define (match-rule rule text)
+ (let ((keyword (expectation-rule-keyword rule))
+ (n-args (expectation-rule-n-args rule))
+ (handler (expectation-rule-handler rule)))
+ (cond ((and (pair? text)
+ (eq? (car text) keyword)
+ (list? (cdr text))
+ (= (length (cdr text)) n-args))
+ (cons handler (cdr text)))
+ ((and (eq? text keyword)
+ (= n-args 0))
+ (list handler))
+ (else #f))))
+
+(define (is-quotation? object)
+ (and (pair? object)
+ (eq? (car object) 'quote)
+ (pair? (cdr object))
+ (null? (cddr object))))
+
+(define (quotation-text expr)
+ (cadr expr))
+
+;;; Lots or hair here to let the test driver deal with "interesting" uses of
+;;; continuations. In particular, the state of the driver is moved outside of
+;;; the control structure, so that if there are multiple returns from evaluating
+;;; an expression, the "current" expectations are used for each.
+
+(define groups-to-test (make-settable-parameter (default-object)))
+(define current-group (make-settable-parameter (default-object)))
+(define test-results (make-settable-parameter (default-object)))
+
+(define (execute-expression-groups groups)
+ (parameterize ((groups-to-test groups)
+ (current-group #f)
+ (test-results '()))
+ (let loop ()
+ (if (pair? (groups-to-test))
+ (begin
+ (current-group (car (groups-to-test)))
+ (groups-to-test (cdr (groups-to-test)))
+ (test-results
+ (cons (execute-expression-group (current-group))
+ (test-results)))
+ (loop))))
+ (reverse (test-results))))
+
+(define (execute-expression-group group)
+ (let ((context (eval-to-context (car group))))
+ (cons (car group)
+ (filter-map (lambda (expectation)
+ (apply (car expectation)
+ context
+ (map (lambda (expr)
+ (eval expr (test-env)))
+ (cdr expectation))))
+ (cdr group)))))
+
+(define (eval-to-context expr)
+ (let ((output-port (open-output-string)))
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (condition)
+ (k
+ (make-error-expectation-context
+ (get-output-string output-port)
+ condition)))
+ (lambda ()
+ (let ((value
+ (parameterize ((current-output-port output-port))
+ ((test-eval) expr (test-env)))))
+ (make-value-expectation-context
+ (get-output-string output-port)
+ value))))))))
+
+(define (make-error-expectation-context output condition)
+ (define (is-error?) #t)
+ (let ((port (open-input-string output)))
+ (define (get-port) port)
+ (define (get-condition) condition)
+ (bundle expectation-context? is-error? get-port get-condition)))
+
+(define (make-value-expectation-context output value)
+ (define (is-error?) #f)
+ (let ((port (open-input-string output)))
+ (define (get-port) port)
+ (define (get-value) value)
+ (bundle expectation-context? is-error? get-port get-value)))
+
+(define expectation-context?
+ (make-bundle-predicate 'expectation-context))
+
+(define (summarize-test-results results)
+ (if (summarize?)
+ (let ((failing-results (filter failing-test-result? results)))
+ (let ((failures (length failing-results))
+ (all (length results)))
+ (fresh-line)
+ (display "Ran ")
+ (write all)
+ (display " test")
+ (if (not (= 1 all))
+ (display "s"))
+ (display "; ")
+ (write failures)
+ (display " failure")
+ (if (not (= 1 failures))
+ (display "s")))
+ (for-each summarize-failing-result failing-results))))
+
+(define (failing-test-result? result)
+ (pair? (cdr result)))
+
+(define (summarize-failing-result failure)
+ (newline)
+ (newline)
+ (display "evaluating ")
+ (newline)
+ (pp (car failure))
+ (display "failed the following expectations:")
+ (newline)
+ (for-each (lambda (error)
+ (display error)
+ (newline))
+ (cdr failure)))
+
+(define (pp-to-string object)
+ (call-with-output-string
+ (lambda (port)
+ (pp object port))))
+
+;;;; Expectation rules
+
+(define (define-expectation keyword n-args handler)
+ (let ((rule (make-expectation-rule keyword n-args handler))
+ (tail
+ (find-tail (lambda (rule)
+ (eq? keyword
+ (expectation-rule-keyword rule)))
+ expectation-rules)))
+ (if tail
+ (set-car! tail rule)
+ (set! expectation-rules
+ (cons rule
+ expectation-rules)))))
+
+(define (define-error-expectation keyword n-args handler)
+ (define-expectation keyword n-args
+ (lambda (context . args)
+ (if (context 'is-error?)
+ (apply handler (context 'get-condition) args)
+ (string-append "expected error but instead got value\n"
+ (write-to-string (context 'get-value)))))))
+
+(define (define-value-expectation keyword n-args handler)
+ (define-expectation keyword n-args
+ (lambda (context . args)
+ (if (context 'is-error?)
+ (string-append "Expected non-error but instead got error: "
+ (write-to-string (context 'get-condition)))
+ (apply handler (context 'get-value) args)))))
+
+(define (define-output-expectation keyword n-args handler)
+ (define-expectation keyword n-args
+ (lambda (context . args)
+ (if (context 'is-error?)
+ (string-append "Expected non-error but instead got error: "
+ (write-to-string (context 'get-condition)))
+ (let ((objects (read-objects (context 'get-port))))
+ (if (condition? objects)
+ "Error while reading output"
+ (apply handler objects args)))))))
+
+(define (read-objects port)
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (condition)
+ (k condition))
+ (lambda ()
+ (let loop ((objects '()))
+ (let ((object (read port)))
+ (if (eof-object? object)
+ (reverse objects)
+ (loop (cons object objects))))))))))
+
+(define expectation-rules
+ '())
+
+(define (make-expectation-rule keyword n-args handler)
+ (list 'expectation-rule keyword n-args handler))
+
+(define expectation-rule-keyword cadr)
+(define expectation-rule-n-args caddr)
+(define expectation-rule-handler cadddr)
+
+(define-value-expectation 'expect 2
+ (lambda (value pred expected)
+ (if (pred expected value)
+ #f
+ (string-append "expected value\n"
+ (write-to-string expected)
+ "\nbut instead got value\n"
+ (write-to-string value)))))
+
+(define-value-expectation 'expect-not 2
+ (lambda (value pred expected)
+ (if (pred expected value)
+ (string-append "expected value different from\n"
+ (write-to-string expected)
+ "\nbut instead got value\n"
+ (write-to-string value))
+ #f)))
+
+(define-value-expectation 'expect-true 0
+ (lambda (value)
+ (if value
+ #f
+ (string-append "expected true value but got false"))))
+
+(define-value-expectation 'expect-false 0
+ (lambda (value)
+ (if value
+ (string-append "expected false value but got\n"
+ (write-to-string value))
+ #f)))
+
+(define-error-expectation 'expect-error 0
+ (lambda (condition)
+ (declare (ignore condition))
+ #f))
+
+;;; General written output expectation.
+(define-output-expectation 'expect-output 2
+ (lambda (objects pred expected)
+ (let ((v (pred expected objects)))
+ (cond ((string? v) v)
+ ((eq? #t v) #f)
+ ((eq? #f v)
+ (string-append "Output\n"
+ (pp-to-string objects)
+ "doesn't satisfy predicate\n"
+ (pp-to-string pred)
+ "with expected value\n"
+ (pp-to-string expected)))
+ (else
+ (error "illegal predicate value:" v))))))
+
+(define-output-expectation 'expect-write 1
+ (lambda (objects expected)
+ (if (and (pair? objects)
+ (null? (cdr objects))
+ (equal? (car objects) expected))
+ #f
+ (string-append "expected to see output "
+ (write-to-string expected)
+ "\nbut instead saw "
+ (write-to-string objects)))))
+
+(define-output-expectation 'expect-pp-description 1
+ (lambda (objects expected)
+ (if (and (pair? objects)
+ (equal? (cdr objects) expected))
+ #f
+ (string-append "expected to see pp description "
+ (write-to-string expected)
+ "\nbut instead saw "
+ (write-to-string objects)))))
+
+(define-output-expectation 'expect-no-output 0
+ (lambda (objects)
+ (if (null? objects)
+ #f
+ (string-append "expected no output but found "
+ objects))))
+
+;; end of library
+))
\ No newline at end of file
diff --git a/src/libraries/srfi-133.scm b/src/libraries/srfi-133.scm
new file mode 100644
index 000000000..7ed1f62cd
--- /dev/null
+++ b/src/libraries/srfi-133.scm
@@ -0,0 +1,562 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SRFI 133
+
+;;; Loosely based on the SRFI's sample implementation.
+
+(define-library (srfi 133)
+ (import (scheme base)
+ (scheme cxr)
+ (srfi 8)
+ (only (mit legacy runtime)
+ error:bad-range-argument
+ fix:+
+ fix:-
+ fix:<
+ fix:<=
+ fix:=
+ fix:>
+ fix:>=
+ fix:end-index
+ fix:min
+ fix:quotient
+ fix:start-index
+ guarantee
+ index-fixnum?
+ unspecific))
+ (export reverse-list->vector
+ reverse-vector->list
+ vector-any
+ vector-append-subvectors
+ vector-cumulate
+ vector-empty?
+ vector-every
+ vector-fold
+ vector-fold-right
+ vector-index
+ vector-index-right
+ vector-map!
+ vector-partition
+ vector-reverse!
+ vector-reverse-copy
+ vector-skip
+ vector-skip-right
+ vector-swap!
+ vector-unfold
+ vector-unfold!
+ vector-unfold-right
+ vector-unfold-right!
+ vector=
+ vector-binary-search
+ vector-concatenate
+ vector-count
+ vector-reverse-copy!)
+ (begin
+
+;;; Constructors
+
+(define (vector-unfold proc n . initial-seeds)
+ (let ((v (make-vector n)))
+ (apply vector-unfold! proc v 0 n initial-seeds)
+ v))
+
+(define (vector-unfold-right proc n . initial-seeds)
+ (let ((v (make-vector n)))
+ (apply vector-unfold-right! proc v 0 n initial-seeds)
+ v))
+
+(define (vector-copy v #!optional start end)
+ (let* ((end (fix:end-index end (vector-length v) 'vector-copy))
+ (start (fix:start-index start end 'vector-copy))
+ (n (fix:- end start))
+ (result (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) result)
+ (vector-set! result i (vector-ref v (fix:+ start i))))))
+
+(define (vector-reverse-copy v #!optional start end)
+ (let* ((end (fix:end-index end (vector-length v) 'vector-reverse-copy))
+ (start (fix:start-index start end 'vector-reverse-copy))
+ (n (fix:- end start))
+ (last (fix:- end 1))
+ (result (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) result)
+ (vector-set! result i (vector-ref v (fix:- last i))))))
+
+(define (vector-append . vs)
+ (vector-concatenate vs))
+
+(define (vector-concatenate vs)
+ (let ((result
+ (make-vector
+ (let loop ((vs vs) (n 0))
+ (if (pair? vs)
+ (loop (cdr vs)
+ (fix:+ (vector-length (car vs)) n))
+ n)))))
+ (let loop ((vs vs) (index 0))
+ (if (pair? vs)
+ (let* ((v (car vs))
+ (n (vector-length v)))
+ (do ((i 0 (fix:+ i 1))
+ (j index (fix:+ j 1)))
+ ((not (fix:< i n))
+ (loop (cdr vs) j))
+ (vector-set! result j (vector-ref v i))))
+ result))))
+
+(define (vector-append-subvectors . args)
+
+ (define (parse-specs args)
+ (let ((caller 'vector-append-subvectors))
+ (let loop ((args args) (specs '()))
+ (if (pair? args)
+ (loop (cdddr args)
+ (cons (let* ((v (car args))
+ (end
+ (fix:end-index (caddr args)
+ (vector-length v)
+ caller)))
+ (vector v
+ (fix:start-index (cadr args) end caller)
+ end))
+ specs))
+ (reverse specs)))))
+
+ (define (compute-length specs)
+ (let loop ((specs specs) (n 0))
+ (if (pair? specs)
+ (loop (cdr specs)
+ (fix:+ n
+ (fix:- (vector-ref (car specs) 2)
+ (vector-ref (car specs) 1))))
+ n)))
+
+ (define (do-copies result specs)
+ (let loop ((specs specs) (at 0))
+ (if (pair? specs)
+ (let ((v (vector-ref (car specs) 0))
+ (start (vector-ref (car specs) 1))
+ (end (vector-ref (car specs) 2)))
+ (do ((i start (fix:+ i 1))
+ (at at (fix:+ at 1)))
+ ((not (fix:< i end))
+ (loop (cdr specs) at))
+ (vector-set! result at (vector-ref v i)))))))
+
+ (let* ((specs (parse-specs args))
+ (result (make-vector (compute-length specs))))
+ (do-copies result specs)
+ result))
+
+;;; Predicates
+
+(define (vector-empty? v)
+ (fix:= 0 (vector-length v)))
+
+(define (vector= elt= . vs)
+ (or (not (pair? vs))
+ (let* ((v (car vs))
+ (n (vector-length v)))
+ ;; Check lengths first since that's fast.
+ (and (let check-lengths ((vs* (cdr vs)))
+ (or (not (pair? vs*))
+ (and (fix:= n (vector-length (car vs*)))
+ (check-lengths (cdr vs*)))))
+ (let check-elts ((vs (cdr vs)))
+ (or (not (pair? vs))
+ (let ((v* (car vs)))
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (elt= (vector-ref v i)
+ (vector-ref v* i))
+ (loop (fix:+ i 1)))
+ (check-elts (cdr vs)))))))))))
+
+;;; Iteration
+
+(define (vector-fold kons knil v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (do ((i 0 (fix:+ i 1))
+ (knil* knil (kons knil* (vector-ref v i))))
+ ((not (fix:< i n)) knil*)))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (do ((i 0 (fix:+ i 1))
+ (knil* knil (apply kons knil* (vectors-ref vs i))))
+ ((not (fix:< i n)) knil*)))))
+
+(define (vector-fold-right kons knil v . vs)
+ (if (null? vs)
+ (do ((i (fix:- (vector-length v) 1) (fix:- i 1))
+ (knil* knil (kons knil* (vector-ref v i))))
+ ((not (fix:>= i 0)) knil*))
+ (let ((vs (cons v vs)))
+ (do ((i (fix:- (vectors-length vs) 1) (fix:- i 1))
+ (knil* knil (apply kons knil* (vectors-ref vs i))))
+ ((not (fix:>= i 0)) knil*)))))
+
+(define (vector-map proc v . vs)
+ (if (null? vs)
+ (let* ((n (vector-length v))
+ (target (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) target)
+ (vector-set! target i (proc (vector-ref v i)))))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs))
+ (target (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) target)
+ (vector-set! target i (apply proc (vectors-ref v i)))))))
+
+(define (vector-map! proc v . vs)
+ (if (null? vs)
+ (let* ((n (vector-length v)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) unspecific)
+ (vector-set! v i (proc (vector-ref v i)))))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) unspecific)
+ (vector-set! v i (apply proc (vectors-ref vs i)))))))
+
+(define (vector-for-each proc v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) unspecific)
+ (proc (vector-ref v i))))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)) unspecific)
+ (apply proc (vectors-ref vs i))))))
+
+(define (vector-count pred v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (do ((i 0 (fix:+ i 1))
+ (j 0 (if (pred (vector-ref v i)) (fix:+ j 1) j)))
+ ((not (fix:< i n)) j)))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (do ((i 0 (fix:+ i 1))
+ (j 0 (if (apply pred (vectors-ref vs i)) (fix:+ j 1) j)))
+ ((not (fix:< i n)) j)))))
+
+(define (vector-cumulate proc knil v)
+ (let* ((n (vector-length v))
+ (result (make-vector n)))
+ (let loop ((i 0) (left knil))
+ (if (fix:< i n)
+ (let ((left* (proc left (vector-ref v i))))
+ (vector-set! result i left*)
+ (loop (fix:+ i 1) left*))
+ result))))
+
+;;; Searching
+
+(define (vector-index pred v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (pred (vector-ref v i))
+ i
+ (loop (fix:+ i 1))))))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (apply pred (vectors-ref vs i))
+ i
+ (loop (fix:+ i 1))))))))
+
+(define (vector-index-right pred v . vs)
+ (if (null? v)
+ (let loop ((i (fix:- (vector-length v) 1)))
+ (and (fix:>= i 0)
+ (if (pred (vector-ref v i))
+ i
+ (loop (fix:- i 1)))))
+ (let ((vs (cons v vs)))
+ (let loop ((i (fix:- (vectors-length vs) 1)))
+ (and (fix:>= i 0)
+ (if (apply pred (vectors-ref vs i))
+ i
+ (loop (fix:- i 1))))))))
+
+(define (vector-skip pred v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (pred (vector-ref v i))
+ (loop (fix:+ i 1))
+ i))))
+ (let* ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (apply pred (vectors-ref vs i))
+ (loop (fix:+ i 1))
+ i))))))
+
+(define (vector-skip-right pred v . vs)
+ (if (null? v)
+ (let loop ((i (fix:- (vector-length v) 1)))
+ (and (fix:>= i 0)
+ (if (pred (vector-ref v i))
+ (loop (fix:- i 1))
+ i)))
+ (let ((vs (cons v vs)))
+ (let loop ((i (fix:- (vectors-length vs) 1)))
+ (and (fix:>= i 0)
+ (if (apply pred (vectors-ref vs i))
+ (loop (fix:- i 1))
+ i))))))
+
+(define (vector-binary-search v value cmp)
+ (let loop ((start 0) (end (vector-length v)))
+ (and (fix:< start end)
+ (let ((midpoint (fix:quotient (fix:+ start end) 2)))
+ (let ((c (cmp (vector-ref v midpoint) value)))
+ (cond ((zero? c) midpoint)
+ ((positive? c) (loop start midpoint))
+ (else (loop (fix:+ midpoint 1) end))))))))
+
+(define (vector-any pred v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (or (pred (vector-ref v i))
+ (loop (fix:+ i 1))))))
+ (let ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (or (apply pred (vectors-ref vs i))
+ (loop (fix:+ i 1))))))))
+
+(define (vector-every pred v . vs)
+ (if (null? vs)
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (pred (vector-ref v i))
+ (loop (fix:+ i 1)))
+ #t)))
+ (let ((vs (cons v vs))
+ (n (vectors-length vs)))
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (apply pred (vectors-ref vs i))
+ (loop (fix:+ i 1)))
+ #t)))))
+
+(define (vector-partition pred v)
+ (let* ((n (vector-length v))
+ (result (make-vector n)))
+ (let loop ((i 0) (yes 0) (no (fix:- n 1)))
+ (if (fix:< i n)
+ (let ((elt (vector-ref v i)))
+ (if (pred elt)
+ (begin
+ (vector-set! result yes elt)
+ (loop (fix:+ i 1) (fix:+ yes 1) no))
+ (begin
+ (vector-set! result no elt)
+ (loop (fix:+ i 1) yes (fix:- no 1)))))
+ (begin
+ (%vector-reverse! result yes n)
+ (values result yes))))))
+
+;;; Mutators
+
+(define (vector-swap! v i1 i2)
+ (let ((x (vector-ref v i1)))
+ (vector-set! v i1 (vector-ref v i2))
+ (vector-set! v i2 x)))
+
+(define (vector-reverse! v #!optional start end)
+ (let ((end (fix:end-index end (vector-length v) 'vector-reverse!)))
+ (%vector-reverse! v
+ (fix:start-index start end 'vector-reverse!)
+ end)))
+
+(define (%vector-reverse! v start end)
+ (let loop ((i start) (j (fix:- end 1)))
+ (if (fix:< i j)
+ (let ((elt (vector-ref v i)))
+ (vector-set! v i (vector-ref v j))
+ (vector-set! v j elt)
+ (loop (fix:+ i 1) (fix:- j 1))))))
+
+(define (vector-copy! to at from #!optional start end)
+ (let* ((end (fix:end-index end (vector-length from) 'vector-copy!))
+ (start (fix:start-index start end 'vector-copy!)))
+ (let ((tend
+ (to-end-index at
+ (fix:- end start)
+ (vector-length to)
+ 'vector-copy!)))
+ (cond ((or (not (eq? to from)) (fix:< at start))
+ (do ((i start (fix:+ i 1))
+ (j at (fix:+ j 1)))
+ ((not (fix:< i end)) unspecific)
+ (vector-set! to j (vector-ref from i))))
+ ((fix:> at start)
+ (do ((i (fix:- end 1) (fix:- i 1))
+ (j (fix:- tend 1) (fix:- j 1)))
+ ((not (fix:>= i start)) unspecific)
+ (vector-set! to j (vector-ref from i))))))))
+
+(define (vector-reverse-copy! to at from #!optional start end)
+ (let* ((end (fix:end-index end (vector-length from) 'vector-reverse-copy!))
+ (start (fix:start-index start end 'vector-reverse-copy!)))
+ (let ((tend
+ (to-end-index at
+ (fix:- end start)
+ (vector-length to)
+ 'vector-copy!)))
+
+ (define (do-copy tend start end)
+ (do ((i start (fix:+ i 1))
+ (j (fix:- tend 1) (fix:- j 1)))
+ ((not (fix:< i end)) unspecific)
+ (vector-set! to j (vector-ref from i))))
+
+ (cond ((or (not (eq? to from)) (fix:<= end at) (fix:<= tend start))
+ (do-copy tend start end))
+ ((fix:< at start)
+ (do-copy at tend end)
+ (%vector-reverse! to start tend))
+ ((fix:> at start)
+ (do-copy start end tend)
+ (%vector-reverse! to at end))))))
+
+(define (vector-unfold! proc v start end . initial-seeds)
+ (let* ((end (fix:end-index end (vector-length v) 'vector-unfold!))
+ (start (fix:start-index start end 'vector-unfold!)))
+ (cond ((null? initial-seeds)
+ (do ((i start (fix:+ i 1)))
+ ((not (fix:< i end)) unspecific)
+ (vector-set! v i (proc i))))
+ ((null? (cdr initial-seeds))
+ (let loop ((i start) (seed (car initial-seeds)))
+ (if (fix:< i end)
+ (receive (elt seed*) (proc i seed)
+ (vector-set! v i elt)
+ (loop (fix:+ i 1) seed*)))))
+ (else
+ (let loop ((i start) (seeds initial-seeds))
+ (if (fix:< i end)
+ (receive (elt . seeds*) (apply proc i seeds)
+ (vector-set! v i elt)
+ (loop (fix:+ i 1) seeds*))))))))
+
+(define (vector-unfold-right! proc v start end . initial-seeds)
+ (let* ((end (fix:end-index end (vector-length v) 'vector-unfold!))
+ (start (fix:start-index start end 'vector-unfold!)))
+ (cond ((null? initial-seeds)
+ (do ((i (fix:- end 1) (fix:- i 1)))
+ ((not (fix:>= i start)) unspecific)
+ (vector-set! v i (proc i))))
+ ((null? (cdr initial-seeds))
+ (let loop ((i (fix:- end 1)) (seed (car initial-seeds)))
+ (if (fix:>= i start)
+ (receive (elt seed*) (proc i seed)
+ (vector-set! v i elt)
+ (loop (fix:- i 1) seed*)))))
+ (else
+ (let loop ((i (fix:- end 1)) (seeds initial-seeds))
+ (if (fix:>= i start)
+ (receive (elt . seeds*) (apply proc i seeds)
+ (vector-set! v i elt)
+ (loop (fix:- i 1) seeds*))))))))
+
+;;; Conversion
+
+(define (vector->list v #!optional start end)
+ (let* ((end (fix:end-index end (vector-length v) 'vector->list))
+ (start (fix:start-index start end 'vector->list)))
+ (do ((i (fix:- end 1) (fix:- i 1))
+ (result '() (cons (vector-ref v i) result)))
+ ((not (fix:>= i start)) result))))
+
+(define (reverse-vector->list v #!optional start end)
+ (let* ((end (fix:end-index end (vector-length v) 'reverse-vector->list))
+ (start (fix:start-index start end 'reverse-vector->list)))
+ (do ((i start (fix:+ i 1))
+ (result '() (cons (vector-ref v i) result)))
+ ((not (fix:< i end)) result))))
+
+(define (list->vector l)
+ (let* ((n (length l))
+ (result (make-vector n)))
+ (do ((i 0 (fix:+ i 1))
+ (l l (cdr l)))
+ ((not (fix:< i n)) result)
+ (vector-set! result i (car l)))))
+
+(define (reverse-list->vector l)
+ (let* ((n (length l))
+ (result (make-vector n)))
+ (do ((i (fix:- n 1) (fix:- i 1))
+ (l l (cdr l)))
+ ((not (fix:>= i 0)) result)
+ (vector-set! result i (car l)))))
+
+;;; Internal
+
+(define (vectors-ref vs i)
+ (let loop ((vs vs))
+ (if (pair? vs)
+ (cons (vector-ref (car vs) i)
+ (loop (cdr vs)))
+ '())))
+
+(define (vectors-length vs)
+ (let loop ((vs (cdr vs)) (n (vector-length (car vs))))
+ (if (pair? vs)
+ (loop (cdr vs) (fix:min n (vector-length (car vs))))
+ n)))
+
+(define (to-end-index start n limit caller)
+ (guarantee index-fixnum? start caller)
+ (let ((end (fix:+ start n)))
+ (if (not (fix:<= n limit))
+ (error:bad-range-argument start caller))
+ end))
+
+;; end of library
+))
\ No newline at end of file
diff --git a/tests/libraries/test-srfi-133.scm b/tests/libraries/test-srfi-133.scm
new file mode 100644
index 000000000..c597eb3aa
--- /dev/null
+++ b/tests/libraries/test-srfi-133.scm
@@ -0,0 +1,219 @@
+(import (scheme base)
+ (srfi 133))
+
+(define v (make-vector 3 3))
+
+(vector? #(1 2 3)) 'expect-true
+(vector? (make-vector 10)) 'expect-true
+(vector-ref v 0) '(expect eqv? 3)
+(vector-ref v 1) '(expect eqv? 3)
+(vector-ref v 2) '(expect eqv? 3)
+(vector-ref v -1) 'expect-error
+(vector-ref v 3) 'expect-error
+
+(vector-set! v 0 -32)
+(vector-ref v 0) '(expect eqv? -32)
+(vector-length v) '(expect = 3)
+(vector-length '#()) '(expect = 0)
+
+(define a2i '#(a b c d e f g h i))
+
+(vector 0 1 2 3 4) '(expect equal? '#(0 1 2 3 4))
+(vector-copy a2i) '(expect equal? a2i)
+(vector-copy a2i) '(expect-not eqv? a2i)
+
+(vector-unfold (lambda (i x) (declare (ignore i)) (values x (- x 1))) 10 0)
+'(expect equal? '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))
+(vector-unfold values 7)
+'(expect equal? '#(0 1 2 3 4 5 6))
+(vector-unfold-right (lambda (i x) (values (cons i x) (+ x 1))) 5 0)
+'(expect equal? '#((0 . 4) (1 . 3) (2 . 2) (3 . 1) (4 . 0)))
+
+(vector-copy a2i 6) '(expect equal? '#(g h i))
+(vector-copy a2i 3 6) '(expect equal? '#(d e f))
+(vector-reverse-copy '#(5 4 3 2 1 0) 1 5) '(expect equal? '#(1 2 3 4))
+
+(vector-append '#(x) '#(y)) '(expect equal? '#(x y))
+(vector-append '#(a) '#(b c d)) '(expect equal? '#(a b c d))
+(vector-append '#(a #(b)) '#(#(c))) '(expect equal? '#(a #(b) #(c)))
+(vector-concatenate '(#(a b) #(c d))) '(expect equal? '#(a b c d))
+
+(vector-append-subvectors '#(a b c d e) 0 2 '#(f g h i j) 2 4)
+'(expect equal? '#(a b h i))
+
+(vector-empty? '#(a)) 'expect-false
+(vector-empty? '#(())) 'expect-false
+(vector-empty? '#(#())) 'expect-false
+(vector-empty? '#()) 'expect-true
+(vector= eq? '#(a b c d) '#(a b c d)) 'expect-true
+(vector= eq? '#(a b c d) '#(a b d c)) 'expect-false
+(vector= = '#(1 2 3 4 5) '#(1 2 3 4)) 'expect-false
+(vector= = '#(+nan.0) '#(+nan.0)) 'expect-false
+(let ((nan '+nan.0)) (vector= = (vector nan) (vector nan))) 'expect-false
+(let ((nanvec '#(+nan.0))) (vector= = nanvec nanvec)) 'expect-false
+(vector= eq?) 'expect-true
+(vector= eq? '#(a)) 'expect-true
+(vector= eq? (vector (vector 'a)) (vector (vector 'a))) 'expect-false
+(vector= equal? (vector (vector 'a)) (vector (vector 'a))) 'expect-true
+
+(define vos '#("abc" "abcde" "abcd"))
+(define vec '#(0 1 2 3 4 5))
+(define vec2 (vector 0 1 2 3 4))
+(define vec3 (vector 1 2 3 4 5))
+(define result '())
+(define (sqr x) (* x x))
+(vector-fold (lambda (len str) (max (string-length str) len)) 0 vos)
+'(expect eqv? 5)
+(vector-fold (lambda (tail elt) (cons elt tail)) '() vec)
+'(expect equal? '(5 4 3 2 1 0))
+(vector-fold (lambda (ctr n) (if (even? n) (+ ctr 1) ctr)) 0 vec)
+'(expect eqv? 3)
+(vector-fold-right (lambda (tail elt) (cons elt tail)) '() '#(a b c d))
+'(expect equal? '(a b c d))
+(vector-map sqr '#(1 2 3 4))
+'(expect equal? '#(1 4 9 16))
+(vector-map * '#(1 2 3 4 5) '#(5 4 3 2 1))
+'(expect equal? '#(5 8 9 8 5))
+(vector-map! sqr vec2)
+(vector-copy vec2)
+'(expect equal? '#(0 1 4 9 16))
+(vector-map! * vec2 vec3)
+(vector-copy vec2)
+'(expect equal? '#(0 2 12 36 80))
+(vector-for-each (lambda (x) (set! result (cons x result))) vec)
+(cons (car result) (cdr result))
+'(expect equal? '(5 4 3 2 1 0))
+(vector-count even? '#(3 1 4 1 5 9 2 5 6))
+'(expect eqv? 3)
+(vector-count < '#(1 3 6 9) '#(2 4 6 8 10 12))
+'(expect eqv? 2)
+(vector-cumulate + 0 '#(3 1 4 1 5 9 2 5 6))
+'(expect equal? '#(3 4 8 9 14 23 25 30 36))
+
+(define (cmp a b)
+ (cond
+ ((< a b) -1)
+ ((= a b) 0)
+ (else 1)))
+(define v '#(0 2 4 6 8 10 12))
+(vector-index even? '#(3 1 4 1 5 9 6)) '(expect eqv? 2)
+(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) '(expect eqv? 1)
+(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) 'expect-false
+(vector-index-right odd? '#(3 1 4 1 5 9 6)) '(expect eqv? 5)
+(vector-index-right < '#(3 1 4 1 5) '#(2 7 1 8 2)) '(expect eqv? 3)
+(vector-skip number? '#(1 2 a b 3 4 c d)) '(expect eqv? 2)
+(vector-skip = '#(1 2 3 4 5) '#(1 2 -3 4)) '(expect eqv? 2)
+(vector-skip-right number? '#(1 2 a b 3 4 c d)) '(expect eqv? 7)
+(vector-skip-right = '#(1 2 3 4 5) '#(1 2 -3 -4 5)) '(expect eqv? 3)
+(vector-binary-search v 0 cmp) '(expect eqv? 0)
+(vector-binary-search v 6 cmp) '(expect eqv? 3)
+(vector-binary-search v 1 cmp) 'expect-false
+(vector-any number? '#(1 2 x y z)) 'expect-true
+(vector-any < '#(1 2 3 4 5) '#(2 1 3 4 5)) 'expect-true
+(vector-any number? '#(a b c d e)) 'expect-false
+(vector-any > '#(1 2 3 4 5) '#(1 2 3 4 5)) 'expect-false
+(vector-every number? '#(1 2 x y z)) 'expect-false
+(vector-every number? '#(1 2 3 4 5)) 'expect-true
+(vector-every < '#(1 2 3) '#(2 3 3)) 'expect-false
+(vector-every < '#(1 2 3) '#(2 3 4)) 'expect-true
+(vector-any (lambda (x) (if (number? x) 'yes #f)) '#(1 2 x y z))
+ '(expect eqv? 'yes)
+
+(define vp
+ (let-values (((new off) (vector-partition number? '#(1 x 2 y 3 z))))
+ (cons new off)))
+(vector-copy (car vp)) '(expect equal? '#(1 2 3 x y z))
+(cdr vp) '(expect eqv? 3)
+
+(define vs (vector 1 2 3))
+(define vf0 (vector 1 2 3))
+(define vf1 (vector 1 2 3))
+(define vf2 (vector 1 2 3))
+(define vr0 (vector 1 2 3))
+(define vr1 (vector 1 2 3))
+(define vr2 (vector 1 2 3))
+(define vc0 (vector 1 2 3 4 5))
+(define vc1 (vector 1 2 3 4 5))
+(define vc2 (vector 1 2 3 4 5))
+(define vrc0 (vector 1 2 3 4 5))
+(define vrc1 (vector 1 2 3 4 5))
+(define vrc2 (vector 1 2 3 4 5))
+(define vu0 (vector 1 2 3 4 5))
+(define vu1 (vector 1 2 3 4 5))
+(define vu2 (vector 1 2 3 4 5))
+(define vur0 (vector 1 2 3 4 5))
+(define vur1 (vector 1 2 3 4 5))
+(define vur2 (vector 1 2 3 4 5))
+(vector-swap! vs 0 1)
+(vector-copy vs)
+'(expect equal? '#(2 1 3))
+(vector-fill! vf0 0)
+(vector-copy vf0)
+'(expect equal? '#(0 0 0))
+(vector-fill! vf1 0 1)
+(vector-copy vf1)
+'(expect equal? '#(1 0 0))
+(vector-fill! vf2 0 0 1)
+(vector-copy vf2)
+'(expect equal? '#(0 2 3))
+(vector-reverse! vr0)
+(vector-copy vr0)
+'(expect equal? '#(3 2 1))
+(vector-reverse! vr1 1)
+(vector-copy vr1)
+'(expect equal? '#(1 3 2))
+(vector-reverse! vr2 0 2)
+(vector-copy vr2)
+'(expect equal? '#(2 1 3))
+(vector-copy! vc0 1 '#(10 20 30))
+(vector-copy vc0)
+'(expect equal? '#(1 10 20 30 5))
+(vector-copy! vc1 1 '#(0 10 20 30 40) 1)
+(vector-copy vc1)
+'(expect equal? '#(1 10 20 30 40))
+(vector-copy! vc2 1 '#(0 10 20 30 40) 1 4)
+(vector-copy vc2)
+'(expect equal? '#(1 10 20 30 5))
+(vector-reverse-copy! vrc0 1 '#(10 20 30))
+(vector-copy vrc0)
+'(expect equal? '#(1 30 20 10 5))
+(vector-reverse-copy! vrc1 1 '#(0 10 20 30 40) 1)
+(vector-copy vrc1)
+'(expect equal? '#(1 40 30 20 10))
+(vector-reverse-copy! vrc2 1 '#(0 10 20 30 40) 1 4)
+(vector-copy vrc2)
+'(expect equal? '#(1 30 20 10 5))
+(vector-unfold! (lambda (i) (+ 10 i)) vu0 1 4)
+(vector-copy vu0)
+'(expect equal? '#(1 11 12 13 5))
+(vector-unfold! (lambda (i x) (values (+ i x) (+ x 1))) vu1 1 4 0)
+(vector-copy vu1)
+'(expect equal? '#(1 1 3 5 5))
+(vector-unfold! (lambda (i x y) (values (+ i x y) (+ x 1) (+ x 1))) vu2 1 4 0 0)
+(vector-copy vu2)
+'(expect equal? '#(1 1 4 7 5))
+(vector-unfold-right! (lambda (i) (+ 10 i)) vur0 1 4)
+(vector-copy vur0)
+'(expect equal? '#(1 11 12 13 5))
+(vector-unfold-right! (lambda (i x) (values (+ i x) (+ x 1))) vur1 1 4 0)
+(vector-copy vur1)
+'(expect equal? '#(1 3 3 3 5))
+(vector-unfold-right! (lambda (i x y) (values (+ i x y) (+ x 1) (+ x 1)))
+ vur2 1 4 0 0)
+(vector-copy vur2)
+'(expect equal? '#(1 5 4 3 5))
+
+(vector->list '#(1 2 3)) '(expect equal? '(1 2 3))
+(vector->list '#(1 2 3) 1) '(expect equal? '(2 3))
+(vector->list '#(1 2 3) 0 2) '(expect equal? '(1 2))
+(list->vector '(1 2 3)) '(expect equal? '#(1 2 3))
+(reverse-vector->list '#(1 2 3)) '(expect equal? '(3 2 1))
+(reverse-vector->list '#(1 2 3) 1) '(expect equal? '(3 2))
+(reverse-vector->list '#(1 2 3) 0 2) '(expect equal? '(2 1))
+(reverse-list->vector '(1 2 3)) '(expect equal? '#(3 2 1))
+(vector->string '#(#\a #\b #\c)) '(expect equal? "abc")
+(vector->string '#(#\a #\b #\c) 1) '(expect equal? "bc")
+(vector->string '#(#\a #\b #\c) 0 2) '(expect equal? "ab")
+(string->vector "abc") '(expect equal? '#(#\a #\b #\c))
+(string->vector "abc" 1) '(expect equal? '#(#\b #\c))
+(string->vector "abc" 0 2) '(expect equal? '#(#\a #\b))
--
2.25.1