From cb6e423dcf816bbe992d5e664b85d3ba6af4d3f0 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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