* On adding Kawa/Chibi R7RS test-suite to the r7rs-wip branch
@ 2017-06-18 11:14 Freja Nordsiek
2017-06-19 5:25 ` Mark H Weaver
0 siblings, 1 reply; 3+ messages in thread
From: Freja Nordsiek @ 2017-06-18 11:14 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 799 bytes --]
On Mark Weaver's suggestion, I looked up the Kawa and Chibi R7RS-small test
suites. Kawa uses Chibi's test-suite, though it is wrapped in a bit of
extra code at the top. Kawa's license is not likely to be a problem, as it
is a MIT license ( https://www.gnu.org/software/kawa/Software-License.html
). But, Chibi's license is a modified BSD license (
http://synthcode.com/license.txt ), which is compatible with the GPL (
https://www.gnu.org/licenses/license-list.html#ModifiedBSD ).
So, we could realistically take the Chibi test-suite (possibly with the
Kawa modifications) and incorporate it into the r7rs-wip branch. The only
question is whether to incorporate them as is or to modify them to use the
same unit testing code as the rest of the unit tests in the guile test
suite.
Freja Nordsiek
[-- Attachment #2: Type: text/html, Size: 1068 bytes --]
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: On adding Kawa/Chibi R7RS test-suite to the r7rs-wip branch
2017-06-18 11:14 On adding Kawa/Chibi R7RS test-suite to the r7rs-wip branch Freja Nordsiek
@ 2017-06-19 5:25 ` Mark H Weaver
2017-06-19 6:41 ` Freja Nordsiek
0 siblings, 1 reply; 3+ messages in thread
From: Mark H Weaver @ 2017-06-19 5:25 UTC (permalink / raw)
To: Freja Nordsiek; +Cc: guile-devel
Hi Freja,
Freja Nordsiek <fnordsie@gmail.com> writes:
> On Mark Weaver's suggestion, I looked up the Kawa and Chibi R7RS-small
> test suites. Kawa uses Chibi's test-suite, though it is wrapped in a
> bit of extra code at the top. Kawa's license is not likely to be a
> problem, as it is a MIT license (
> https://www.gnu.org/software/kawa/Software-License.html ). But,
> Chibi's license is a modified BSD license (
> http://synthcode.com/license.txt ), which is compatible with the GPL (
> https://www.gnu.org/licenses/license-list.html#ModifiedBSD ).
Sounds good, thanks for checking it!
> So, we could realistically take the Chibi test-suite (possibly with
> the Kawa modifications) and incorporate it into the r7rs-wip
> branch. The only question is whether to incorporate them as is or to
> modify them to use the same unit testing code as the rest of the unit
> tests in the guile test suite.
I would prefer to use Chibi's test suite with minimal changes. I
suppose that we will need to add some code at the top, and it is
possible that we'll need to make some other modifications.
Thanks!
Mark
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: On adding Kawa/Chibi R7RS test-suite to the r7rs-wip branch
2017-06-19 5:25 ` Mark H Weaver
@ 2017-06-19 6:41 ` Freja Nordsiek
0 siblings, 0 replies; 3+ messages in thread
From: Freja Nordsiek @ 2017-06-19 6:41 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
[-- Attachment #1.1: Type: text/plain, Size: 2514 bytes --]
Mark,
It turned out to be pretty easy to add it as a standalone test file (patch
is attached). Chibi's (chibi test) and (chibi term ansi) just had to be
copy and pasted into the top of the file, a few things added at the top to
import the modules and enable the right read and print options, and a few
modifications applied and it runs. Note that I enabled the r7rs-bytevectors
reader and print options in the patch I submitted last night (
https://lists.gnu.org/archive/html/guile-devel/2017-06/msg00035.html ).
Also note that the (test-exit) command I added at the end is commented out
so that this test failing due to some failed tests doesn't stop all the
non-standalone tests from running. Two tests have to be disabled which
cause the script to break when they are reached, which are
(test-write-syntax "|\"|" '|\"|)
and
(let ()
(define 7 1)
(let-syntax ()
(define x 2)
#f)
(test 1 x))
Overall, the test results are pretty good. They are, as printed by the
test-suite at the end,
1110 out of 1145 (96.9%) tests passed in 1.3156378269195557 seconds.
32 failures (2.8%).
3 errors (0.3%).
15 out of 18 (83.3%) subgroups passed.
Weak areas are Strings, Read Syntax, and Numeric Syntax.
Freja Nordsiek
On Mon, Jun 19, 2017 at 7:25 AM, Mark H Weaver <mhw@netris.org> wrote:
> Hi Freja,
>
> Freja Nordsiek <fnordsie@gmail.com> writes:
>
> > On Mark Weaver's suggestion, I looked up the Kawa and Chibi R7RS-small
> > test suites. Kawa uses Chibi's test-suite, though it is wrapped in a
> > bit of extra code at the top. Kawa's license is not likely to be a
> > problem, as it is a MIT license (
> > https://www.gnu.org/software/kawa/Software-License.html ). But,
> > Chibi's license is a modified BSD license (
> > http://synthcode.com/license.txt ), which is compatible with the GPL (
> > https://www.gnu.org/licenses/license-list.html#ModifiedBSD ).
>
> Sounds good, thanks for checking it!
>
> > So, we could realistically take the Chibi test-suite (possibly with
> > the Kawa modifications) and incorporate it into the r7rs-wip
> > branch. The only question is whether to incorporate them as is or to
> > modify them to use the same unit testing code as the rest of the unit
> > tests in the guile test suite.
>
> I would prefer to use Chibi's test suite with minimal changes. I
> suppose that we will need to add some code at the top, and it is
> possible that we'll need to make some other modifications.
>
> Thanks!
> Mark
>
[-- Attachment #1.2: Type: text/html, Size: 3749 bytes --]
[-- Attachment #2: 0001-Added-Chibi-s-R7RS-test-suite-as-a-standalone-test-s.patch --]
[-- Type: text/x-patch, Size: 120134 bytes --]
From 51f953cf3152a8653ed00ff66fccd9ced227551f Mon Sep 17 00:00:00 2001
From: Freja Nordsiek <fnordsie@gmail.com>
Date: Mon, 19 Jun 2017 08:26:49 +0200
Subject: [PATCH] Added Chibi's R7RS test-suite as a standalone test-suite.
* test-suite/standalone/Makefile.am: Added test-suite to the list to test.
* test-suite/standalone/test-r7rs-chibi (new file): Chibi's R7RS-small's
test-suite with Chibi's (chibi test) and (chibi term ansi) modules included
into the source along with some Guile modifications.
---
test-suite/standalone/Makefile.am | 3 +
test-suite/standalone/test-r7rs-chibi | 3715 +++++++++++++++++++++++++++++++++
2 files changed, 3718 insertions(+)
create mode 100755 test-suite/standalone/test-r7rs-chibi
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 6f676eb..fb40268 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -96,6 +96,9 @@ EXTRA_DIST += test-language.el test-language.js
check_SCRIPTS += test-guild-compile
TESTS += test-guild-compile
+check_SCRIPTS += test-r7rs-chibi
+TESTS += test-r7rs-chibi
+
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-r7rs-chibi b/test-suite/standalone/test-r7rs-chibi
new file mode 100755
index 0000000..01958e9
--- /dev/null
+++ b/test-suite/standalone/test-r7rs-chibi
@@ -0,0 +1,3715 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+;; Chibi's r7rs-tests.scm, (chibi test), and (chibi term ansi) combined into a
+;; standalone test suite for R7RS-small, with modifications to fit into Guile's
+;; tests suite.
+;;
+;;
+;; Copyright of Guile modifications are
+;;
+;;
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;
+;;
+;;
+;; The copyright of the Chibi code is
+;;
+;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. BSD-style
+;; license: http://synthcode.com/license.txt
+
+
+(read-enable 'r7rs-symbols)
+(print-enable 'r7rs-symbols)
+
+(read-enable 'r7rs-bytevectors)
+(print-enable 'r7rs-bytevectors)
+
+
+
+(import (scheme base)
+ (scheme char)
+ (scheme lazy)
+ (scheme inexact)
+ (scheme complex)
+ (scheme time)
+ (scheme file)
+ (scheme read)
+ (scheme write)
+ (scheme eval)
+ (scheme process-context)
+ (scheme case-lambda)
+ (scheme r5rs))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Chibi's (chibi term ansi) module
+;;;
+;;; Guile modifications:
+;;; * ANSI escape codes disabled
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. BSD-style
+;; license: http://synthcode.com/license.txt
+
+;;> A library to use ANSI escape codes to format text and background
+;;> color, font weigh, and underlining.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (make-simple-escape-procedure parameter)
+ (let ((code (string-append "\x1B;[" (number->string parameter) "m")))
+ (lambda () code)))
+
+(define (make-wrap-procedure start-escape end-escape)
+ (lambda (str)
+ (if (not (string? str))
+ (error "argument must be a string" str))
+ (if (ansi-escapes-enabled?)
+ (string-append start-escape str end-escape)
+ str)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Some definitions are wrapped in begin in order to avoid Scribble
+;; generating duplicate signatures.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Library}
+
+(define black-escape
+ (make-simple-escape-procedure 30))
+(define red-escape
+ (make-simple-escape-procedure 31))
+(define green-escape
+ (make-simple-escape-procedure 32))
+(define yellow-escape
+ (make-simple-escape-procedure 33))
+(define blue-escape
+ (make-simple-escape-procedure 34))
+(define magenta-escape
+ (make-simple-escape-procedure 35))
+(define cyan-escape
+ (make-simple-escape-procedure 36))
+(define white-escape
+ (make-simple-escape-procedure 37))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> specified text color.
+;;/
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> text color specified by the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments, each of which must be an exact
+;;> integer in the range [0, 5].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-escape red-level green-level blue-level)
+ (when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
+ (error "invalid red-level value" red-level))
+ (when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
+ (error "invalid green-level value" green-level))
+ (when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
+ (error "invalid blue-level value" blue-level))
+ (string-append
+ "\x1B;[38;5;"
+ (number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
+ "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> text color specified by the \var{gray-level} argument, which must
+;;> be an exact integer in the range [0, 23].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-escape gray-level)
+ (when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
+ (error "invalid gray-level value" gray-level))
+ (string-append "\x1B;[38;5;"
+ (number->string (+ gray-level 232))
+ "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> default text color.
+
+(define reset-color-escape
+ (make-simple-escape-procedure 39))
+
+(define black
+ (make-wrap-procedure (black-escape)
+ (reset-color-escape)))
+(define red
+ (make-wrap-procedure (red-escape)
+ (reset-color-escape)))
+(define green
+ (make-wrap-procedure (green-escape)
+ (reset-color-escape)))
+(define yellow
+ (make-wrap-procedure (yellow-escape)
+ (reset-color-escape)))
+(define blue
+ (make-wrap-procedure (blue-escape)
+ (reset-color-escape)))
+(define magenta
+ (make-wrap-procedure (magenta-escape)
+ (reset-color-escape)))
+(define cyan
+ (make-wrap-procedure (cyan-escape)
+ (reset-color-escape)))
+(define white
+ (make-wrap-procedure (white-escape)
+ (reset-color-escape)))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects specified text color
+;;> and a suffix that selects the default text color.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+;;/
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> text color (obtained by calling the \scheme{rgb-escape} procedure
+;;> with the values of the \var{red-level}, \var{green-level}, and
+;;> \var{blue-level} arguments) and a suffix that selects the default
+;;> text color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb red-level green-level blue-level)
+ (make-wrap-procedure (rgb-escape red-level green-level blue-level)
+ (reset-color-escape)))
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> text color (obtained by calling the \scheme{gray-escape} procedure
+;;> with the values of the \var{gray-level} argument) and a suffix
+;;> that selects the default text color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray gray-level)
+ (make-wrap-procedure (gray-escape gray-level)
+ (reset-color-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define black-background-escape
+ (make-simple-escape-procedure 40))
+(define red-background-escape
+ (make-simple-escape-procedure 41))
+(define green-background-escape
+ (make-simple-escape-procedure 42))
+(define yellow-background-escape
+ (make-simple-escape-procedure 43))
+(define blue-background-escape
+ (make-simple-escape-procedure 44))
+(define magenta-background-escape
+ (make-simple-escape-procedure 45))
+(define cyan-background-escape
+ (make-simple-escape-procedure 46))
+(define white-background-escape
+ (make-simple-escape-procedure 47))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> specified background color.
+;;/
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> background color specified by the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments, each of which must be an exact
+;;> integer in the range [0, 5].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-background-escape red-level green-level blue-level)
+ (when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
+ (error "invalid red-level value" red-level))
+ (when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
+ (error "invalid green-level value" green-level))
+ (when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
+ (error "invalid blue-level value" blue-level))
+ (string-append
+ "\x1B;[48;5;"
+ (number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
+ "m"))
+
+;;> Return a string consisting of an ANSI escape code to select the
+;;> background color specified by the \var{gray-level} argument, which
+;;> must be an exact integer in the range [0, 23].
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-background-escape gray-level)
+ (when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
+ (error "invalid gray-level value" gray-level))
+ (string-append "\x1B;[48;5;"
+ (number->string (+ gray-level 232))
+ "m"))
+
+;;> \procedure{(reset-background-color-escape)}
+;;>
+;;> Return a string consisting of an ANSI escape code to select the
+;;> default background color.
+
+(define reset-background-color-escape
+ (make-simple-escape-procedure 49))
+
+(define black-background
+ (make-wrap-procedure (black-background-escape)
+ (reset-background-color-escape)))
+(define red-background
+ (make-wrap-procedure (red-background-escape)
+ (reset-background-color-escape)))
+(define green-background
+ (make-wrap-procedure (green-background-escape)
+ (reset-background-color-escape)))
+(define yellow-background
+ (make-wrap-procedure (yellow-background-escape)
+ (reset-background-color-escape)))
+(define blue-background
+ (make-wrap-procedure (blue-background-escape)
+ (reset-background-color-escape)))
+(define magenta-background
+ (make-wrap-procedure (magenta-background-escape)
+ (reset-background-color-escape)))
+(define cyan-background
+ (make-wrap-procedure (cyan-background-escape)
+ (reset-background-color-escape)))
+(define white-background
+ (make-wrap-procedure (white-background-escape)
+ (reset-background-color-escape)))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects specified background
+;;> color and a suffix that selects the default background color.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+;;/
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> background color (obtained by calling the \scheme{rgb-background-escape}
+;;> procedure with the values of the \var{red-level}, \var{green-level},
+;;> and \var{blue-level} arguments) and a suffix that selects the
+;;> default background color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (rgb-background red-level green-level blue-level)
+ (make-wrap-procedure (rgb-background-escape red-level green-level blue-level)
+ (reset-background-color-escape)))
+
+;;> Returns a procedure which takes a single argument, a string, and
+;;> which when called behaves as follows.
+;;>
+;;> If ANSI escapes are enabled, the procedure returns a string
+;;> consisting of its argument with a prefix that selects specified
+;;> background color (obtained by calling the \scheme{gray-background-escape}
+;;> procedure with the values of the \var{gray-level} argument) and a
+;;> suffix that selects the default background color.
+;;>
+;;> If ANSI escapes are not enabled, the procedure returns its argument.
+;;>
+;;> The caller is resonsible for verifying that the terminal supports
+;;> 256 colors.
+
+(define (gray-background gray-level)
+ (make-wrap-procedure (gray-background-escape gray-level)
+ (reset-background-color-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select bold
+;;> style.
+
+(define bold-escape
+ (make-simple-escape-procedure 1))
+
+;;> Return a string consisting of an ANSI escape code to select non-bold
+;;> style.
+
+(define reset-bold-escape
+ (make-simple-escape-procedure 22))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects bold style and a suffix
+;;> that selects non-bold style.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define bold (make-wrap-procedure (bold-escape)
+ (reset-bold-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select
+;;> underlined style.
+
+(define underline-escape
+ (make-simple-escape-procedure 4))
+
+;;> Return a string consisting of an ANSI escape code to select
+;;> non-underlined style.
+
+(define reset-underline-escape
+ (make-simple-escape-procedure 24))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects underlined style and
+;;> a suffix that selects non-underlined style.
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define underline (make-wrap-procedure (underline-escape)
+ (reset-underline-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> Return a string consisting of an ANSI escape code to select negative
+;;> style (text in the background color and background in the text
+;;> color).
+
+(define negative-escape
+ (make-simple-escape-procedure 7))
+
+;;> Return a string consisting of an ANSI escape code to select positive
+;;> style (text in the text color and background in the background
+;;> color).
+
+(define reset-negative-escape
+ (make-simple-escape-procedure 27))
+
+;;> If ANSI escapes are enabled, return a string consisting of the
+;;> string \var{str} with a prefix that selects negative style (text
+;;> in the background color and background in the text color) and a
+;;> suffix that selects positive style (text in the text color and
+;;> background in the background color).
+;;>
+;;> If ANSI escapes are not enabled, return \var{str}.
+
+(define negative (make-wrap-procedure (negative-escape)
+ (reset-negative-escape)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> A parameter object that determines whether ANSI escapes are enabled
+;;> in some of the preceding procedures. They are disabled if
+;;> \scheme{(ansi-escapes-enabled?)} returns \scheme{#f}, and otherwise
+;;> they are enabled.
+;;>
+;;> The initial value returned by \scheme{(ansi-escapes-enabled?)} is
+;;> determined by the environment.
+;;>
+;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is set,
+;;> its value determines the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)}. If the value of
+;;> \scheme{ANSI_ESCAPES_ENABLED} is \scheme{"0"}, the initial value
+;;> is \scheme{#f}, otherwise the initial value is \scheme{#t}.
+;;>
+;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is not
+;;> set, but the environment variable \scheme{TERM} is set, the value
+;;> of the latter determines the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)}. If the value of \scheme{TERM}
+;;> is \scheme{"xterm"}, \scheme{"xterm-color"}, \scheme{"xterm-256color"},
+;;> \scheme{"rxvt"}, \scheme{"rxvt-unicode-256color"}, \scheme{"kterm"},
+;;> \scheme{"linux"}, \scheme{"screen"}, \scheme{"screen-256color"},
+;;> or \scheme{"vt100"}, the initial value is \scheme{#t}, otherwise
+;;> the initial value is \scheme{#f}.
+;;>
+;;> If neither of the environment variables \scheme{ANSI_ESCAPES_ENABLED}
+;;> and \scheme{TERM} are set, the initial value returned by
+;;> \scheme{(ansi-escapes-enabled?)} is \scheme{#f}.
+
+(define ansi-escapes-enabled?
+ (make-parameter #f))
+ ;; (cond
+ ;; ((get-environment-variable "ANSI_ESCAPES_ENABLED")
+ ;; => (lambda (s) (not (equal? s "0"))))
+ ;; (else
+ ;; (member (get-environment-variable "TERM")
+ ;; '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
+ ;; "linux" "screen" "screen-256color" "vt100"
+ ;; "rxvt-unicode-256color"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{Notes}
+;;>
+;;> It is important to remember that the formatting procedures apply
+;;> a prefix to set a particular graphics parameter and a suffix to
+;;> reset the parameter to its default value. This can lead to surprises.
+;;> For example, on an ANSI terminal, one might mistakenly expect the
+;;> following to display GREEN in green text and then RED in red text:
+;;>
+;;> \codeblock{(display (red (string-append (green "GREEN") "RED")))}
+;;>
+;;> However, it will actually display GREEN in green text and then RED
+;;> in the default text color. This is a limitation of ANSI control
+;;> codes; graphics attributes are not saved to and restored from a
+;;> stack, but instead are simply set. One way to display GREEN in
+;;> green text and then RED in red text is:
+;;>
+;;> \codeblock{(display (string-append (green "GREEN") (red "RED")))}
+;;>
+;;> On the other hand, text color, background color, font weight (bold
+;;> or default), underline (on or off), image (positive or negative)
+;;> are orthogonal. So, for example, on an ANSI terminal the following
+;;> should display GREEN in green text and then RED in red text, with
+;;> both in bold and GREEN underlined.
+;;>
+;;> \codeblock{(display (bold (string-append (underline (green "GREEN")) (red "RED"))))}
+;;>
+
+
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Chibi's (chibi test) module.
+;;;
+;;; Guile modifications:
+;;; * current-column-width's default changed from 78 to 72
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(define (pair-source x) #f)
+(define print-exception write)
+
+;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Simple testing framework adapted from the Chicken \scheme{test}
+;;> module.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utilities
+
+;; Simplified version of SRFI-1 every.
+(define (every pred ls)
+ (or (null? ls)
+ (if (null? (cdr ls))
+ (pred (car ls))
+ (if (pred (car ls)) (every pred (cdr ls)) #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exception utilities
+
+(define (warning msg . args)
+ (display msg (current-error-port))
+ (for-each (lambda (x)
+ (write-char #\space (current-error-port))
+ (write x (current-error-port)))
+ args)
+ (newline (current-error-port)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utilities
+
+(define (string-search pat str)
+ (let* ((pat-len (string-length pat))
+ (limit (- (string-length str) pat-len)))
+ (let lp1 ((i 0))
+ (cond
+ ((>= i limit) #f)
+ (else
+ (let lp2 ((j i) (k 0))
+ (cond ((>= k pat-len) #t)
+ ((not (eqv? (string-ref str j) (string-ref pat k)))
+ (lp1 (+ i 1)))
+ (else (lp2 (+ j 1) (+ k 1))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test interface
+
+;;> \macro{(test [name] expect expr)}
+
+;;> Evaluate \var{expr} and check that it is \scheme{equal?}
+;;> to \var{expect}. \var{name} is used in reporting, and
+;;> defaults to a printed summary of \var{expr}.
+
+(define-syntax test
+ (syntax-rules (quote)
+ ((test expect expr)
+ (test #f expect expr))
+ ((test name expect (expr ...))
+ (test-propagate-info name expect (expr ...) ()))
+ ((test name 'expect expr)
+ (test-propagate-info name 'expect expr ()))
+ ((test name (expect ...) expr)
+ (test-syntax-error
+ 'test
+ "the test expression should come last: (test <expected> (<expr> ...)) "
+ (test name (expect ...) expr)))
+ ((test name expect expr)
+ (test-propagate-info name expect expr ()))
+ ((test a ...)
+ (test-syntax-error 'test "test requires 2 or 3 arguments" (test a ...)))))
+
+;;> \macro{(test-equal equal [name] expect expr)}
+
+;;> Equivalent to test, using \var{equal} for comparison instead of
+;;> \scheme{equal?}.
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((test-equal equal . args)
+ (parameterize ((current-test-comparator equal))
+ (test . args)))))
+
+;;> \macro{(test-assert [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's true.
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ expr)
+ (test-assert #f expr))
+ ((_ name expr)
+ (test-propagate-info name #f expr ((assertion . #t))))
+ ((test a ...)
+ (test-syntax-error 'test-assert "1 or 2 arguments required"
+ (test a ...)))))
+
+;;> \macro{(test-not [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's false.
+
+(define-syntax test-not
+ (syntax-rules ()
+ ((_ expr) (test-assert (not expr)))
+ ((_ name expr) (test-assert name (not expr)))))
+
+;;> \macro{(test-values [name] expect expr)}
+
+;;> Like \scheme{test} but \var{expect} and \var{expr} can both
+;;> return multiple values.
+
+(define-syntax test-values
+ (syntax-rules ()
+ ((_ expect expr)
+ (test-values #f expect expr))
+ ((_ name expect expr)
+ (test name (call-with-values (lambda () expect) (lambda results results))
+ (call-with-values (lambda () expr) (lambda results results))))))
+
+;;> \macro{(test-error [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it
+;;> raises an error.
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ expr)
+ (test-error #f expr))
+ ((_ name expr)
+ (test-propagate-info name #f expr ((expect-error . #t))))
+ ((test a ...)
+ (test-syntax-error 'test-error "1 or 2 arguments required"
+ (test a ...)))))
+
+;; TODO: Extract interesting variables so we can show their values on
+;; failure.
+(define-syntax test-propagate-info
+ (syntax-rules ()
+ ((test-propagate-info name expect expr info)
+ (test-vars () name expect expr info))))
+
+(define-syntax test-vars
+ (syntax-rules ()
+ ((_ (vars ...) n expect expr ((key . val) ...))
+ (test-run (lambda () expect)
+ (lambda () expr)
+ `((name . ,n)
+ (source . expr)
+ (var-names . (vars ...))
+ (var-values . ,(list vars ...))
+ (key . val) ...)))))
+
+;;> \macro{(test-exit)}
+
+;;> Exits with a failure status if any tests have failed,
+;;> and a successful status otherwise.
+
+(define (test-exit)
+ (exit (zero? (test-failure-count))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; group interface
+
+;;> Wraps \var{body} as a single test group, which can be filtered
+;;> and summarized separately.
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ name-expr body ...)
+ (let ((name name-expr)
+ (old-group (current-test-group)))
+ (if (not (string? name))
+ (error "a name is required, got " 'name-expr name))
+ (test-begin name)
+ (guard
+ (exn
+ (else
+ (warning "error in group outside of tests")
+ (print-exception exn (current-error-port))
+ (test-group-inc! (current-test-group) 'count)
+ (test-group-inc! (current-test-group) 'ERROR)
+ (test-failure-count (+ 1 (test-failure-count)))))
+ body ...)
+ (test-end name)
+ (current-test-group old-group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define-syntax test-syntax-error
+ (syntax-rules ()
+ ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test-group representation
+
+;; (name (prop value) ...)
+(define (make-test-group name . o)
+ (let ((parent (and (pair? o) (car o)))
+ (group (list name (cons 'start-time (current-second)))))
+ (test-group-set! group 'parent parent)
+ (test-group-set! group 'verbose
+ (if parent
+ (test-group-ref parent 'verbose)
+ (current-test-verbosity)))
+ (test-group-set! group 'level
+ (if parent
+ (+ 1 (test-group-ref parent 'level 0))
+ 0))
+ (test-group-set!
+ group
+ 'skip-group?
+ (or (and parent (test-group-ref parent 'skip-group?))
+ (not (every (lambda (f) (f group)) (current-test-group-filters)))))
+ group))
+
+(define test-group-name car)
+
+(define (test-group-ref group field . o)
+ (if group
+ (apply assq-ref (cdr group) field o)
+ (and (pair? o) (car o))))
+
+(define (test-group-set! group field value)
+ (cond
+ ((assq field (cdr group))
+ => (lambda (x) (set-cdr! x value)))
+ (else (set-cdr! group (cons (cons field value) (cdr group))))))
+
+(define (test-group-inc! group field . o)
+ (let ((amount (if (pair? o) (car o) 1)))
+ (cond
+ ((assq field (cdr group))
+ => (lambda (x) (set-cdr! x (+ amount (cdr x)))))
+ (else (set-cdr! group (cons (cons field amount) (cdr group)))))))
+
+(define (test-group-push! group field value)
+ (cond
+ ((assq field (cdr group))
+ => (lambda (x) (set-cdr! x (cons value (cdr x)))))
+ (else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (assq-ref ls key . o)
+ (cond ((assq key ls) => cdr)
+ ((pair? o) (car o))
+ (else #f)))
+
+(define (approx-equal? a b epsilon)
+ (cond
+ ((> (abs a) (abs b))
+ (approx-equal? b a epsilon))
+ ((zero? a)
+ (< (abs b) epsilon))
+ (else
+ (< (abs (/ (- a b) b)) epsilon))))
+
+(define (call-with-output-string proc)
+ (let ((out (open-output-string)))
+ (proc out)
+ (get-output-string out)))
+
+;; partial pretty printing to abbreviate `quote' forms and the like
+(define (write-to-string x)
+ (call-with-output-string
+ (lambda (out)
+ (let wr ((x x))
+ (if (pair? x)
+ (cond
+ ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
+ (assq (car x)
+ '((quote . "'") (quasiquote . "`")
+ (unquote . ",") (unquote-splicing . ",@"))))
+ => (lambda (s) (display (cdr s) out) (wr (cadr x))))
+ (else
+ (display "(" out)
+ (wr (car x))
+ (let lp ((ls (cdr x)))
+ (cond ((pair? ls)
+ (display " " out)
+ (wr (car ls))
+ (lp (cdr ls)))
+ ((not (null? ls))
+ (display " . " out)
+ (write ls out))))
+ (display ")" out)))
+ (write x out))))))
+
+(define (display-to-string x)
+ (if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
+
+;; if we need to truncate, try first dropping let's to get at the
+;; heart of the expression
+(define (truncate-source x width . o)
+ (let* ((str (write-to-string x))
+ (len (string-length str)))
+ (cond
+ ((<= len width)
+ str)
+ ((and (pair? x) (eq? 'let (car x)))
+ (if (and (pair? o) (car o))
+ (truncate-source (car (reverse x)) width #t)
+ (string-append "..."
+ (truncate-source (car (reverse x)) (- width 3) #t))))
+ ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
+ (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
+ ((and (pair? x) (eq? 'call-with-values (car x)))
+ (string-append
+ "..."
+ (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
+ (car (reverse (cadr x)))
+ (cadr x))
+ (- width 3)
+ #t)))
+ (else
+ (string-append
+ (substring str 0 (min (max 0 (- width 3)) (string-length str)))
+ "...")))))
+
+(define (test-get-name! info)
+ (or
+ (assq-ref info 'name)
+ (assq-ref info 'gen-name)
+ (let ((name
+ (cond
+ ((assq 'source info)
+ => (lambda (src)
+ (truncate-source (cdr src) (- (current-column-width) 12))))
+ ((current-test-group)
+ => (lambda (g)
+ (display "no source in: " (current-error-port))
+ (write info (current-error-port))
+ (display "\n" (current-error-port))
+ (string-append
+ "test-"
+ (number->string (test-group-ref g 'count 0)))))
+ (else ""))))
+ (if (pair? info)
+ (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
+ name)))
+
+(define (test-print-name info . indent)
+ (let ((width (- (current-column-width)
+ (or (and (pair? indent) (car indent)) 0)))
+ (name (test-get-name! info)))
+ (display name)
+ (display " ")
+ (let ((diff (- width 9 (string-length name))))
+ (cond
+ ((positive? diff)
+ (display (make-string diff #\.)))))
+ (display " ")
+ (flush-output-port)))
+
+(define (test-group-indent-width group)
+ (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
+ (test-first-indentation))))))
+ (* 4 (min level (test-max-indentation)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-expand-info info)
+ (let ((expr (assq-ref info 'source)))
+ (if (and (pair? expr)
+ (pair-source expr)
+ (not (assq-ref info 'line-number)))
+ `((file-name . ,(car (pair-source expr)))
+ (line-number . ,(cdr (pair-source expr)))
+ ,@info)
+ info)))
+
+(define (test-run expect expr info)
+ (let ((info (test-expand-info info)))
+ (if (and (cond ((current-test-group)
+ => (lambda (g) (not (test-group-ref g 'skip-group?))))
+ (else #t))
+ (every (lambda (f) (f info)) (current-test-filters)))
+ ((current-test-applier) expect expr info)
+ ((current-test-skipper) info))))
+
+(define (test-default-applier expect expr info)
+ (let* ((group (current-test-group))
+ (indent (and group (test-group-indent-width group))))
+ (cond
+ ((test-group-ref group 'verbose)
+ (if (and indent (positive? indent))
+ (display (make-string indent #\space)))
+ (test-print-name info indent)))
+ (let ((expect-val
+ (guard
+ (exn
+ (else
+ (warning "bad expect value")
+ (print-exception exn (current-error-port))
+ #f))
+ (expect))))
+ (guard
+ (exn
+ (else
+ ((current-test-handler)
+ (if (assq-ref info 'expect-error) 'PASS 'ERROR)
+ (append `((exception . ,exn)) info))))
+ (let ((res (expr)))
+ (let ((status
+ (if (and (not (assq-ref info 'expect-error))
+ (if (assq-ref info 'assertion)
+ res
+ ((current-test-comparator) expect-val res)))
+ 'PASS
+ 'FAIL))
+ (info `((result . ,res) (expected . ,expect-val) ,@info)))
+ ((current-test-handler) status info)))))))
+
+(define (test-default-skipper info)
+ ((current-test-handler) 'SKIP info))
+
+(define (test-status-color status)
+ (case status
+ ((ERROR) (lambda (x) (underline (red x))))
+ ((FAIL) red)
+ ((SKIP) yellow)
+ (else (lambda (x) x))))
+
+(define (test-status-message status)
+ ((test-status-color status) status))
+
+(define (test-status-code status)
+ ((test-status-color status)
+ (case status
+ ((ERROR) "!")
+ ((FAIL) "x")
+ ((SKIP) "-")
+ (else "."))))
+
+(define (test-print-explanation indent status info)
+ (cond
+ ((eq? status 'ERROR)
+ (display indent)
+ (cond ((assq 'exception info)
+ => (lambda (e)
+ (print-exception (cdr e) (current-output-port))))))
+ ((and (eq? status 'FAIL) (assq-ref info 'assertion))
+ (display indent)
+ (display "assertion failed\n"))
+ ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
+ (display indent)
+ (display "expected an error but got ")
+ (write (assq-ref info 'result)) (newline))
+ ((eq? status 'FAIL)
+ (display indent)
+ (display "expected ") (write (assq-ref info 'expected))
+ (display " but got ") (write (assq-ref info 'result)) (newline)))
+ ;; print variables
+ (cond
+ ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
+ => (lambda (names)
+ (let ((values (assq-ref info 'var-values)))
+ (if (and (pair? names)
+ (pair? values)
+ (= (length names) (length values)))
+ (let ((indent2
+ (string-append indent (make-string 2 #\space))))
+ (for-each
+ (lambda (name value)
+ (display indent2) (write name) (display ": ")
+ (write value) (newline))
+ names values))))))))
+
+(define (test-print-source indent status info)
+ (case status
+ ((FAIL ERROR)
+ (cond
+ ((assq-ref info 'line-number)
+ => (lambda (line)
+ (display " on line ")
+ (write line)
+ (cond ((assq-ref info 'file-name)
+ => (lambda (file) (display " of file ") (write file))))
+ (newline))))
+ (cond
+ ((assq-ref info 'source)
+ => (lambda (s)
+ (cond
+ ((or (assq-ref info 'name)
+ (> (string-length (write-to-string s))
+ (current-column-width)))
+ (display (write-to-string s))
+ (newline))))))
+ (cond
+ ((assq-ref info 'values)
+ => (lambda (v)
+ (for-each
+ (lambda (v)
+ (display " ") (display (car v))
+ (display ": ") (write (cdr v)) (newline))
+ v)))))))
+
+(define (test-print-failure indent status info)
+ ;; display status explanation
+ (test-print-explanation indent status info)
+ ;; display line, source and values info
+ (test-print-source indent status info))
+
+(define (test-print-header-line str . indent)
+ (let* ((header (string-append
+ (make-string (if (pair? indent) (car indent) 0) #\space)
+ "-- " str " "))
+ (len (string-length header)))
+ (display (bold header))
+ (display (make-string (max 0 (- (current-column-width) len)) #\-))
+ (newline)))
+
+(define (test-default-handler status info)
+ (define indent
+ (make-string
+ (+ 4 (cond ((current-test-group)
+ => (lambda (group) (or (test-group-indent-width group) 0)))
+ (else 0)))
+ #\space))
+ ;; update group info
+ (cond
+ ((current-test-group)
+ => (lambda (group)
+ (if (not (eq? 'SKIP status))
+ (test-group-inc! group 'count))
+ (test-group-inc! group status)
+ ;; maybe wrap long status lines
+ (let ((width (max (- (current-column-width)
+ (or (test-group-indent-width group) 0))
+ 4))
+ (column
+ (+ (string-length (or (test-group-name group) ""))
+ (or (test-group-ref group 'count) 0)
+ 1)))
+ (if (and (zero? (modulo column width))
+ (not (test-group-ref group 'verbose)))
+ (display (string-append "\n" (string-copy indent 4))))))))
+ ;; update global failure count for exit status
+ (cond
+ ((or (eq? status 'FAIL) (eq? status 'ERROR))
+ (test-failure-count (+ 1 (test-failure-count)))))
+ (cond
+ ((eq? status 'SKIP))
+ ((test-group-ref (current-test-group) 'verbose)
+ ;; display status
+ (display "[")
+ (if (not (eq? status 'ERROR)) (display " ")) ; pad
+ (display (test-status-message status))
+ (display "]")
+ (newline)
+ (test-print-failure indent status info))
+ (else
+ (display (test-status-code status))
+ (cond
+ ((and (memq status '(FAIL ERROR)) (current-test-group))
+ => (lambda (group)
+ (test-group-push! group 'failures (list indent status info)))))
+ (cond ((current-test-group)
+ => (lambda (group) (test-group-set! group 'trailing #t))))))
+ (flush-output-port)
+ status)
+
+(define (test-default-group-reporter group)
+ (define (plural word n)
+ (if (= n 1) word (string-append word "s")))
+ (define (percent n d)
+ (string-append " (" (number->string (/ (round (* 1000.0 (/ n d))) 10))
+ "%)"))
+ (let* ((end-time (current-second))
+ (start-time (test-group-ref group 'start-time))
+ (duration (- end-time start-time))
+ (base-count (or (test-group-ref group 'count) 0))
+ (base-pass (or (test-group-ref group 'PASS) 0))
+ (base-fail (or (test-group-ref group 'FAIL) 0))
+ (base-err (or (test-group-ref group 'ERROR) 0))
+ (skip (or (test-group-ref group 'SKIP) 0))
+ (pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
+ (fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
+ (err (+ base-err (or (test-group-ref group 'total-error) 0)))
+ (count (+ pass fail err))
+ (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
+ (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
+ (indent (make-string (or (test-group-indent-width group) 0) #\space)))
+ (if (and (not (test-group-ref group 'verbose))
+ (test-group-ref group 'trailing))
+ (newline))
+ (cond
+ ((or (positive? count) (positive? subgroups-count))
+ (if (not (= base-count (+ base-pass base-fail base-err)))
+ (warning "inconsistent count:"
+ base-count base-pass base-fail base-err))
+ (cond
+ ((positive? count)
+ (display indent)
+ (display
+ ((if (= pass count) green (lambda (x) x))
+ (string-append
+ (number->string pass) " out of " (number->string count)
+ (percent pass count))))
+ (display
+ (string-append
+ (plural " test" pass) " passed in "
+ (number->string duration) " seconds"
+ (cond
+ ((zero? skip) "")
+ (else (string-append " (" (number->string skip)
+ (plural " test" skip) " skipped)")))
+ ".\n"))))
+ (cond ((positive? fail)
+ (display indent)
+ (display
+ (red
+ (string-append
+ (number->string fail) (plural " failure" fail)
+ (percent fail count) ".\n")))))
+ (cond ((positive? err)
+ (display indent)
+ (display
+ ((lambda (x) (underline (red x)))
+ (string-append
+ (number->string err) (plural " error" err)
+ (percent err count) ".\n")))))
+ (cond
+ ((not (test-group-ref group 'verbose))
+ (for-each
+ (lambda (failure)
+ (display indent)
+ (display (red
+ (string-append (display-to-string (cadr failure)) ": ")))
+ (display (test-get-name! (car (cddr failure))))
+ (newline)
+ (apply test-print-failure failure))
+ (reverse (or (test-group-ref group 'failures) '())))))
+ (cond
+ ((positive? subgroups-count)
+ (display indent)
+ (display
+ ((if (= subgroups-pass subgroups-count)
+ green (lambda (x) x))
+ (string-append
+ (number->string subgroups-pass) " out of "
+ (number->string subgroups-count)
+ (percent subgroups-pass subgroups-count))))
+ (display (plural " subgroup" subgroups-pass))
+ (display " passed.\n")))))
+ (cond
+ ((test-group-ref group 'verbose)
+ (test-print-header-line
+ (string-append "done testing " (or (test-group-name group) ""))
+ (or (test-group-indent-width group) 0))
+ (newline)))
+ (cond
+ ((test-group-ref group 'parent)
+ => (lambda (parent)
+ (test-group-set! parent 'trailing #f)
+ (test-group-inc! parent 'total-pass pass)
+ (test-group-inc! parent 'total-fail fail)
+ (test-group-inc! parent 'total-error err))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-equal? expect res)
+ (or (equal? expect res)
+ (if (real? expect)
+ (and (inexact? expect)
+ (real? res)
+ (inexact? res)
+ (approx-equal? expect res (current-test-epsilon)))
+ (and (complex? res)
+ (complex? expect)
+ (test-equal? (real-part expect) (real-part res))
+ (test-equal? (imag-part expect) (imag-part res))))))
+
+;;> Begin testing a new group until the closing \scheme{(test-end)}.
+
+(define (test-begin . o)
+ (let* ((name (if (pair? o) (car o) ""))
+ (parent (current-test-group))
+ (group (make-test-group name parent)))
+ (cond
+ ((and parent
+ ;; (zero? (test-group-ref parent 'count 0))
+ (zero? (test-group-ref parent 'subgroups-count 0)))
+ (newline)))
+ (cond
+ ((test-group-ref group 'verbose)
+ (test-print-header-line
+ (string-append "testing " name)
+ (or (test-group-indent-width group) 0)))
+ (else
+ (display
+ (make-string (or (test-group-indent-width group) 0)
+ #\space))
+ (display (bold (string-append name ": ")))))
+ (current-test-group group)))
+
+;;> Ends testing group introduced with \scheme{(test-begin)}, and
+;;> summarizes the results.
+
+(define (test-end . o)
+ (cond
+ ((current-test-group)
+ => (lambda (group)
+ (if (and (pair? o) (not (equal? (car o) (test-group-name group))))
+ (warning "mismatched test-end:" (car o) (test-group-name group)))
+ (let ((parent (test-group-ref group 'parent)))
+ (cond
+ ((not (test-group-ref group 'skip-group?))
+ ;; only report if there's something to say
+ ((current-test-group-reporter) group)
+ (cond
+ (parent
+ (test-group-inc! parent 'subgroups-count)
+ (cond
+ ((and (zero? (test-group-ref group 'FAIL 0))
+ (zero? (test-group-ref group 'ERROR 0))
+ (= (test-group-ref group 'subgroups-pass 0)
+ (test-group-ref group 'subgroups-count 0)))
+ (test-group-inc! parent 'subgroups-pass)))))))
+ (current-test-group parent)
+ group)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parameters
+
+(define current-test-group (make-parameter #f))
+(define current-test-verbosity
+ (make-parameter
+ (cond ((get-environment-variable "TEST_VERBOSE")
+ => (lambda (s) (not (member s '("" "0")))))
+ (else #f))))
+(define current-test-epsilon (make-parameter 1e-5))
+(define current-test-comparator (make-parameter test-equal?))
+(define current-test-applier (make-parameter test-default-applier))
+(define current-test-handler (make-parameter test-default-handler))
+(define current-test-skipper (make-parameter test-default-skipper))
+(define current-test-group-reporter
+ (make-parameter test-default-group-reporter))
+(define test-failure-count (make-parameter 0))
+
+(define test-first-indentation
+ (make-parameter
+ (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
+ => string->number)
+ (else #f))
+ 1)))
+
+(define test-max-indentation
+ (make-parameter
+ (or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
+ => string->number)
+ (else #f))
+ 5)))
+
+(define (string->info-matcher str)
+ (lambda (info)
+ (cond ((test-get-name! info)
+ => (lambda (n) (string-search str n)))
+ (else #f))))
+
+(define (string->group-matcher str)
+ (lambda (group) (string-search str (car group))))
+
+(define (getenv-filter-list proc name . o)
+ (cond
+ ((get-environment-variable name)
+ => (lambda (s)
+ (guard
+ (exn
+ (else
+ (warning
+ (string-append "invalid filter '" s
+ "' from environment variable: " name))
+ (print-exception exn (current-error-port))
+ '()))
+ (let ((f (proc s)))
+ (list (if (and (pair? o) (car o))
+ (lambda (x) (not (f x)))
+ f))))))
+ (else '())))
+
+(define current-test-filters
+ (make-parameter
+ (append (getenv-filter-list string->info-matcher "TEST_FILTER")
+ (getenv-filter-list string->info-matcher "TEST_REMOVE" #t))))
+
+(define current-test-group-filters
+ (make-parameter
+ (append (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")
+ (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE" #t))))
+
+(define current-column-width
+ (make-parameter
+ (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
+ => string->number)
+ (else #f))
+ 72)))
+
+
+
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Chibi's r7rs-tests.scm
+;;;
+;;; Guile modifications:
+;;; * (test-exit) added to end to indicate overall pass or fail to
+;;; make check
+;;; * The test "(let () (define y 1) (let-syntax () (define y 2) #f) (test 1 y))"
+;;; was disabled.
+;;; * The test "(test-write-syntax "|\"|" '|\"|)" was disabled.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;; R7RS test suite. Covers all procedures and syntax in the small
+;; language except `delete-file'. Currently assumes full-unicode
+;; support, the full numeric tower and all standard libraries
+;; provided.
+;;
+;; Uses the (chibi test) library which is written in portable R7RS.
+;; This is mostly a subset of SRFI-64, providing test-begin, test-end
+;; and test, which could be defined as something like:
+;;
+;; (define (test-begin . o) #f)
+;;
+;; (define (test-end . o) #f)
+;;
+;; (define-syntax test
+;; (syntax-rules ()
+;; ((test expected expr)
+;; (let ((res expr))
+;; (cond
+;; ((not (equal? expr expected))
+;; (display "FAIL: ")
+;; (write 'expr)
+;; (display ": expected ")
+;; (write expected)
+;; (display " but got ")
+;; (write res)
+;; (newline)))))))
+;;
+;; however (chibi test) provides nicer output, timings, and
+;; approximate equivalence for floating point numbers.
+
+(test-begin "R7RS")
+
+(test-begin "4.1 Primitive expression types")
+
+(let ()
+ (define x 28)
+ (test 28 x))
+
+(test 'a (quote a))
+(test #(a b c) (quote #(a b c)))
+(test '(+ 1 2) (quote (+ 1 2)))
+
+(test 'a 'a)
+(test #(a b c) '#(a b c))
+(test '() '())
+(test '(+ 1 2) '(+ 1 2))
+(test '(quote a) '(quote a))
+(test '(quote a) ''a)
+
+(test "abc" '"abc")
+(test "abc" "abc")
+(test 145932 '145932)
+(test 145932 145932)
+(test #t '#t)
+(test #t #t)
+
+(test 7 (+ 3 4))
+(test 12 ((if #f + *) 3 4))
+
+(test 8 ((lambda (x) (+ x x)) 4))
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 (reverse-subtract 7 10))
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 (add4 6))
+
+(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
+(test '(5 6) ((lambda (x y . z) z)
+ 3 4 5 6))
+
+(test 'yes (if (> 3 2) 'yes 'no))
+(test 'no (if (> 2 3) 'yes 'no))
+(test 1 (if (> 3 2)
+ (- 3 2)
+ (+ 3 2)))
+(let ()
+ (define x 2)
+ (test 3 (+ x 1)))
+
+(test-end)
+
+(test-begin "4.2 Derived expression types")
+
+(test 'greater
+ (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+
+(test 'equal
+ (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+
+(test 2
+ (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+
+(test 'composite
+ (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+
+(test 'c
+ (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else => (lambda (x) x))))
+
+(test '((other . z) (semivowel . y) (other . x)
+ (semivowel . w) (vowel . u))
+ (map (lambda (x)
+ (case x
+ ((a e i o u) => (lambda (w) (cons 'vowel w)))
+ ((w y) (cons 'semivowel x))
+ (else => (lambda (w) (cons 'other w)))))
+ '(z y x w u)))
+
+(test #t (and (= 2 2) (> 2 1)))
+(test #f (and (= 2 2) (< 2 1)))
+(test '(f g) (and 1 2 'c '(f g)))
+(test #t (and))
+
+(test #t (or (= 2 2) (> 2 1)))
+(test #t (or (= 2 2) (< 2 1)))
+(test #f (or #f #f #f))
+(test '(b c) (or (memq 'b '(a b c))
+ (/ 3 0)))
+
+(test 6 (let ((x 2) (y 3))
+ (* x y)))
+
+(test 35 (let ((x 2) (y 3))
+ (let ((x 7)
+ (z (+ x y)))
+ (* z x))))
+
+(test 70 (let ((x 2) (y 3))
+ (let* ((x 7)
+ (z (+ x y)))
+ (* z x))))
+
+(test #t
+ (letrec ((even?
+ (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
+ (even? 88)))
+
+(test 5
+ (letrec* ((p
+ (lambda (x)
+ (+ 1 (q (- x 1)))))
+ (q
+ (lambda (y)
+ (if (zero? y)
+ 0
+ (+ 1 (p (- y 1))))))
+ (x (p 5))
+ (y x))
+ y))
+
+;; By Jussi Piitulainen <jpiitula@ling.helsinki.fi>
+;; and John Cowan <cowan@mercury.ccil.org>:
+;; http://lists.scheme-reports.org/pipermail/scheme-reports/2013-December/003876.html
+(define (means ton)
+ (letrec*
+ ((mean
+ (lambda (f g)
+ (f (/ (sum g ton) n))))
+ (sum
+ (lambda (g ton)
+ (if (null? ton)
+ (+)
+ (if (number? ton)
+ (g ton)
+ (+ (sum g (car ton))
+ (sum g (cdr ton)))))))
+ (n (sum (lambda (x) 1) ton)))
+ (values (mean values values)
+ (mean exp log)
+ (mean / /))))
+(let*-values (((a b c) (means '(8 5 99 1 22))))
+ (test 27 a)
+ (test 9.728 b)
+ (test 1800/497 c))
+
+(let*-values (((root rem) (exact-integer-sqrt 32)))
+ (test 35 (* root rem)))
+
+(test '(1073741824 0)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 2 60))))
+ (list root rem)))
+
+(test '(1518500249 3000631951)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 2 61))))
+ (list root rem)))
+
+(test '(815238614083298888 443242361398135744)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 2 119))))
+ (list root rem)))
+
+(test '(1152921504606846976 0)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 2 120))))
+ (list root rem)))
+
+(test '(1630477228166597776 1772969445592542976)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 2 121))))
+ (list root rem)))
+
+(test '(31622776601683793319 62545769258890964239)
+ (let*-values (((root rem) (exact-integer-sqrt (expt 10 39))))
+ (list root rem)))
+
+(let*-values (((root rem) (exact-integer-sqrt (expt 2 140))))
+ (test 0 rem)
+ (test (expt 2 140) (square root)))
+
+(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y))
+ (let*-values (((a b) (values x y))
+ ((x y) (values a b)))
+ (list a b x y))))
+
+(test 'ok (let-values () 'ok))
+
+(test 1 (let ((x 1))
+ (let*-values ()
+ (define x 2)
+ #f)
+ x))
+
+(let ()
+ (define x 0)
+ (set! x 5)
+ (test 6 (+ x 1)))
+
+(test #(0 1 2 3 4) (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+
+(test 25 (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+
+(test '((6 1 3) (-5 -2))
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((>= (car numbers) 0)
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg))
+ ((< (car numbers) 0)
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg))))))
+
+(test 3 (force (delay (+ 1 2))))
+
+(test '(3 3)
+ (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+
+(define integers
+ (letrec ((next
+ (lambda (n)
+ (delay (cons n (next (+ n 1)))))))
+ (next 0)))
+(define head
+ (lambda (stream) (car (force stream))))
+(define tail
+ (lambda (stream) (cdr (force stream))))
+
+(test 2 (head (tail (tail integers))))
+
+(define (stream-filter p? s)
+ (delay-force
+ (if (null? (force s))
+ (delay '())
+ (let ((h (car (force s)))
+ (t (cdr (force s))))
+ (if (p? h)
+ (delay (cons h (stream-filter p? t)))
+ (stream-filter p? t))))))
+
+(test 5 (head (tail (tail (stream-filter odd? integers)))))
+
+(let ()
+ (define x 5)
+ (define count 0)
+ (define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (test 6 (force p))
+ (test 6 (begin (set! x 10) (force p))))
+
+(test #t (promise? (delay (+ 2 2))))
+(test #t (promise? (make-promise (+ 2 2))))
+(test #t
+ (let ((x (delay (+ 2 2))))
+ (force x)
+ (promise? x)))
+(test #t
+ (let ((x (make-promise (+ 2 2))))
+ (force x)
+ (promise? x)))
+
+(define radix
+ (make-parameter
+ 10
+ (lambda (x)
+ (if (and (integer? x) (<= 2 x 16))
+ x
+ (error "invalid radix")))))
+(define (f n) (number->string n (radix)))
+(test "12" (f 12))
+(test "1100" (parameterize ((radix 2))
+ (f 12)))
+(test "12" (f 12))
+
+(test '(list 3 4) `(list ,(+ 1 2) 4))
+(let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test #(10 5 4 16 9 8)
+ `#(10 5 ,(square 2) ,@(map square '(4 3)) 8))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) )
+(let ((name1 'x)
+ (name2 'y))
+ (test '(a `(b ,x ,'y d) e) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
+(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
+
+(define plus
+ (case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z) (+ (+ x y) z))
+ (args (apply + args))))
+
+(test 0 (plus))
+(test 1 (plus 1))
+(test 3 (plus 1 2))
+(test 6 (plus 1 2 3))
+(test 10 (plus 1 2 3 4))
+
+(define mult
+ (case-lambda
+ (() 1)
+ ((x) x)
+ ((x y) (* x y))
+ ((x y . z) (apply mult (* x y) z))))
+
+(test 1 (mult))
+(test 1 (mult 1))
+(test 2 (mult 1 2))
+(test 6 (mult 1 2 3))
+(test 24 (mult 1 2 3 4))
+
+(test-end)
+
+(test-begin "4.3 Macros")
+
+(test 'now (let-syntax
+ ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if)))
+
+(test 'outer (let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m)))))
+
+(test 7 (letrec-syntax
+ ((my-or (syntax-rules ()
+ ((my-or) #f)
+ ((my-or e) e)
+ ((my-or e1 e2 ...)
+ (let ((temp e1))
+ (if temp
+ temp
+ (my-or e2 ...)))))))
+ (let ((x #f)
+ (y 7)
+ (temp 8)
+ (let odd?)
+ (if even?))
+ (my-or x
+ (let temp)
+ (if y)
+ y))))
+
+(define-syntax be-like-begin1
+ (syntax-rules ()
+ ((be-like-begin1 name)
+ (define-syntax name
+ (syntax-rules ()
+ ((name expr (... ...))
+ (begin expr (... ...))))))))
+(be-like-begin1 sequence1)
+(test 3 (sequence1 0 1 2 3))
+
+(define-syntax be-like-begin2
+ (syntax-rules ()
+ ((be-like-begin2 name)
+ (define-syntax name
+ (... (syntax-rules ()
+ ((name expr ...)
+ (begin expr ...))))))))
+(be-like-begin2 sequence2)
+(test 4 (sequence2 1 2 3 4))
+
+(define-syntax be-like-begin3
+ (syntax-rules ()
+ ((be-like-begin3 name)
+ (define-syntax name
+ (syntax-rules dots ()
+ ((name expr dots)
+ (begin expr dots)))))))
+(be-like-begin3 sequence3)
+(test 5 (sequence3 2 3 4 5))
+
+;; Syntax pattern with ellipsis in middle of proper list.
+(define-syntax part-2
+ (syntax-rules ()
+ ((_ a b (m n) ... x y)
+ (vector (list a b) (list m ...) (list n ...) (list x y)))
+ ((_ . rest) 'error)))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77))
+ (part-2 10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77))
+;; Syntax pattern with ellipsis in middle of improper list.
+(define-syntax part-2x
+ (syntax-rules ()
+ ((_ (a b (m n) ... x y . rest))
+ (vector (list a b) (list m ...) (list n ...) (list x y)
+ (cons "rest:" 'rest)))
+ ((_ . rest) 'error)))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:"))
+ (part-2x (10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77)))
+(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:" . "tail"))
+ (part-2x (10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77 . "tail")))
+
+;; underscore
+(define-syntax underscore
+ (syntax-rules ()
+ ((foo _) '_)))
+(test '_ (underscore foo))
+
+(define-syntax count-to-2
+ (syntax-rules ()
+ ((_) 0)
+ ((_ _) 1)
+ ((_ _ _) 2)
+ ((_ . _) 'many)))
+(test '(2 0 many)
+ (list (count-to-2 a b) (count-to-2) (count-to-2 a b c d)))
+
+(define-syntax count-to-2_
+ (syntax-rules (_)
+ ((_) 0)
+ ((_ _) 1)
+ ((_ _ _) 2)
+ ((x . y) 'fail)))
+(test '(2 0 fail fail)
+ (list (count-to-2_ _ _) (count-to-2_)
+ (count-to-2_ a b) (count-to-2_ a b c d)))
+
+(define-syntax jabberwocky
+ (syntax-rules ()
+ ((_ hatter)
+ (begin
+ (define march-hare 42)
+ (define-syntax hatter
+ (syntax-rules ()
+ ((_) march-hare)))))))
+(jabberwocky mad-hatter)
+(test 42 (mad-hatter))
+
+(test 'ok (let ((=> #f)) (cond (#t => 'ok))))
+
+;; (let ()
+;; (define 7 1)
+;; (let-syntax ()
+;; (define x 2)
+;; #f)
+;; (test 1 x))
+
+(let ()
+ (define-syntax foo
+ (syntax-rules ()
+ ((foo bar y)
+ (define-syntax bar
+ (syntax-rules ()
+ ((bar x) 'y))))))
+ (foo bar x)
+ (test 'x (bar 1)))
+
+(begin
+ (define-syntax ffoo
+ (syntax-rules ()
+ ((ffoo ff)
+ (begin
+ (define (ff x)
+ (gg x))
+ (define (gg x)
+ (* x x))))))
+ (ffoo ff)
+ (test 100 (ff 10)))
+
+(let-syntax ((vector-lit
+ (syntax-rules ()
+ ((vector-lit)
+ '#(b)))))
+ (test '#(b) (vector-lit)))
+
+(let ()
+ ;; forward hygienic refs
+ (define-syntax foo399
+ (syntax-rules () ((foo399) (bar399))))
+ (define (quux399)
+ (foo399))
+ (define (bar399)
+ 42)
+ (test 42 (quux399)))
+
+(test-end)
+
+(test-begin "5 Program structure")
+
+(define add3
+ (lambda (x) (+ x 3)))
+(test 6 (add3 3))
+(define first car)
+(test 1 (first '(1 2)))
+
+(test 45 (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+
+(test 'ok
+ (let ()
+ (define-values () (values))
+ 'ok))
+(test 1
+ (let ()
+ (define-values (x) (values 1))
+ x))
+(test 3
+ (let ()
+ (define-values x (values 1 2))
+ (apply + x)))
+(test 3
+ (let ()
+ (define-values (x y) (values 1 2))
+ (+ x y)))
+(test 6
+ (let ()
+ (define-values (x y z) (values 1 2 3))
+ (+ x y z)))
+(test 10
+ (let ()
+ (define-values (x y . z) (values 1 2 3 4))
+ (+ x y (car z) (cadr z))))
+
+(test '(2 1) (let ((x 1) (y 2))
+ (define-syntax swap!
+ (syntax-rules ()
+ ((swap! a b)
+ (let ((tmp a))
+ (set! a b)
+ (set! b tmp)))))
+ (swap! x y)
+ (list x y)))
+
+;; Records
+
+(define-record-type <pare>
+ (kons x y)
+ pare?
+ (x kar set-kar!)
+ (y kdr))
+
+(test #t (pare? (kons 1 2)))
+(test #f (pare? (cons 1 2)))
+(test 1 (kar (kons 1 2)))
+(test 2 (kdr (kons 1 2)))
+(test 3 (let ((k (kons 1 2)))
+ (set-kar! k 3)
+ (kar k)))
+
+(test-end)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 6 Standard Procedures
+
+(test-begin "6.1 Equivalence Predicates")
+
+(test #t (eqv? 'a 'a))
+(test #f (eqv? 'a 'b))
+(test #t (eqv? 2 2))
+(test #t (eqv? '() '()))
+(test #t (eqv? 100000000 100000000))
+(test #f (eqv? (cons 1 2) (cons 1 2)))
+(test #f (eqv? (lambda () 1)
+ (lambda () 2)))
+(test #f (eqv? #f 'nil))
+
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(test #t
+ (let ((g (gen-counter)))
+ (eqv? g g)))
+(test #f (eqv? (gen-counter) (gen-counter)))
+(define gen-loser
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) 27))))
+(test #t (let ((g (gen-loser)))
+ (eqv? g g)))
+
+(test #f
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (eqv? f g)))
+
+(test #t
+ (let ((x '(a)))
+ (eqv? x x)))
+
+(test #t (eq? 'a 'a))
+(test #f (eq? (list 'a) (list 'a)))
+(test #t (eq? '() '()))
+(test #t
+ (let ((x '(a)))
+ (eq? x x)))
+(test #t
+ (let ((x '#()))
+ (eq? x x)))
+(test #t
+ (let ((p (lambda (x) x)))
+ (eq? p p)))
+
+(test #t (equal? 'a 'a))
+(test #t (equal? '(a) '(a)))
+(test #t (equal? '(a (b) c)
+ '(a (b) c)))
+(test #t (equal? "abc" "abc"))
+(test #t (equal? 2 2))
+(test #t (equal? (make-vector 5 'a)
+ (make-vector 5 'a)))
+
+(test-end)
+
+(test-begin "6.2 Numbers")
+
+(test #t (complex? 3+4i))
+(test #t (complex? 3))
+(test #t (real? 3))
+(test #t (real? -2.5+0i))
+(test #f (real? -2.5+0.0i))
+(test #t (real? #e1e10))
+(test #t (real? +inf.0))
+(test #f (rational? -inf.0))
+(test #t (rational? 6/10))
+(test #t (rational? 6/3))
+(test #t (integer? 3+0i))
+(test #t (integer? 3.0))
+(test #t (integer? 8/4))
+
+(test #f (exact? 3.0))
+(test #t (exact? #e3.0))
+(test #t (inexact? 3.))
+
+(test #t (exact-integer? 32))
+(test #f (exact-integer? 32.0))
+(test #f (exact-integer? 32/5))
+
+(test #t (finite? 3))
+(test #f (finite? +inf.0))
+(test #f (finite? 3.0+inf.0i))
+
+(test #f (infinite? 3))
+(test #t (infinite? +inf.0))
+(test #f (infinite? +nan.0))
+(test #t (infinite? 3.0+inf.0i))
+
+(test #t (nan? +nan.0))
+(test #f (nan? 32))
+;; (test #t (nan? +nan.0+5.0i))
+(test #f (nan? 1+2i))
+
+(test #t (= 1 1.0 1.0+0.0i))
+(test #f (= 1.0 1.0+1.0i))
+(test #t (< 1 2 3))
+(test #f (< 1 1 2))
+(test #t (> 3.0 2.0 1.0))
+(test #f (> -3.0 2.0 1.0))
+(test #t (<= 1 1 2))
+(test #f (<= 1 2 1))
+(test #t (>= 2 1 1))
+(test #f (>= 1 2 1))
+(test '(#t #f) (list (<= 1 1 2) (<= 2 1 3)))
+
+;; From R7RS 6.2.6 Numerical operations:
+;;
+;; These predicates are required to be transitive.
+;;
+;; _Note:_ The traditional implementations of these predicates in
+;; Lisp-like languages, which involve converting all arguments to inexact
+;; numbers if any argument is inexact, are not transitive.
+
+;; Example from Alan Bawden
+(let ((a (- (expt 2 1000) 1))
+ (b (inexact (expt 2 1000))) ; assuming > single-float-epsilon
+ (c (+ (expt 2 1000) 1)))
+ (test #t (if (and (= a b) (= b c))
+ (= a c)
+ #t)))
+
+;; From CLtL 12.3. Comparisons on Numbers:
+;;
+;; Let _a_ be the result of (/ 10.0 single-float-epsilon), and let
+;; _j_ be the result of (floor a). ..., all of (<= a j), (< j (+ j
+;; 1)), and (<= (+ j 1) a) would be true; transitivity would then
+;; imply that (< a a) ought to be true ...
+
+;; Transliteration from Jussi Piitulainen
+(define single-float-epsilon
+ (do ((eps 1.0 (* eps 2.0)))
+ ((= eps (+ eps 1.0)) eps)))
+
+(let* ((a (/ 10.0 single-float-epsilon))
+ (j (exact a)))
+ (test #t (if (and (<= a j) (< j (+ j 1)))
+ (not (<= (+ j 1) a))
+ #t)))
+
+(test #t (zero? 0))
+(test #t (zero? 0.0))
+(test #t (zero? 0.0+0.0i))
+(test #f (zero? 1))
+(test #f (zero? -1))
+
+(test #f (positive? 0))
+(test #f (positive? 0.0))
+(test #t (positive? 1))
+(test #t (positive? 1.0))
+(test #f (positive? -1))
+(test #f (positive? -1.0))
+(test #t (positive? +inf.0))
+(test #f (positive? -inf.0))
+
+(test #f (negative? 0))
+(test #f (negative? 0.0))
+(test #f (negative? 1))
+(test #f (negative? 1.0))
+(test #t (negative? -1))
+(test #t (negative? -1.0))
+(test #f (negative? +inf.0))
+(test #t (negative? -inf.0))
+
+(test #f (odd? 0))
+(test #t (odd? 1))
+(test #t (odd? -1))
+(test #f (odd? 102))
+
+(test #t (even? 0))
+(test #f (even? 1))
+(test #t (even? -2))
+(test #t (even? 102))
+
+(test 3 (max 3))
+(test 4 (max 3 4))
+(test 4.0 (max 3.9 4))
+(test 5.0 (max 5 3.9 4))
+(test +inf.0 (max 100 +inf.0))
+(test 3 (min 3))
+(test 3 (min 3 4))
+(test 3.0 (min 3 3.1))
+(test -inf.0 (min -inf.0 -100))
+
+(test 7 (+ 3 4))
+(test 3 (+ 3))
+(test 0 (+))
+(test 4 (* 4))
+(test 1 (*))
+
+(test -1 (- 3 4))
+(test -6 (- 3 4 5))
+(test -3 (- 3))
+(test 3/20 (/ 3 4 5))
+(test 1/3 (/ 3))
+
+(test 7 (abs -7))
+(test 7 (abs 7))
+
+(test-values (values 2 1) (floor/ 5 2))
+(test-values (values -3 1) (floor/ -5 2))
+(test-values (values -3 -1) (floor/ 5 -2))
+(test-values (values 2 -1) (floor/ -5 -2))
+(test-values (values 2 1) (truncate/ 5 2))
+(test-values (values -2 -1) (truncate/ -5 2))
+(test-values (values -2 1) (truncate/ 5 -2))
+(test-values (values 2 -1) (truncate/ -5 -2))
+(test-values (values 2.0 -1.0) (truncate/ -5.0 -2))
+
+(test 1 (modulo 13 4))
+(test 1 (remainder 13 4))
+
+(test 3 (modulo -13 4))
+(test -1 (remainder -13 4))
+
+(test -3 (modulo 13 -4))
+(test 1 (remainder 13 -4))
+
+(test -1 (modulo -13 -4))
+(test -1 (remainder -13 -4))
+
+(test -1.0 (remainder -13 -4.0))
+
+(test 4 (gcd 32 -36))
+(test 0 (gcd))
+(test 288 (lcm 32 -36))
+(test 288.0 (lcm 32.0 -36))
+(test 1 (lcm))
+
+(test 3 (numerator (/ 6 4)))
+(test 2 (denominator (/ 6 4)))
+(test 2.0 (denominator (inexact (/ 6 4))))
+(test 11.0 (numerator 5.5))
+(test 2.0 (denominator 5.5))
+(test 5.0 (numerator 5.0))
+(test 1.0 (denominator 5.0))
+
+(test -5.0 (floor -4.3))
+(test -4.0 (ceiling -4.3))
+(test -4.0 (truncate -4.3))
+(test -4.0 (round -4.3))
+
+(test 3.0 (floor 3.5))
+(test 4.0 (ceiling 3.5))
+(test 3.0 (truncate 3.5))
+(test 4.0 (round 3.5))
+
+(test 4 (round 7/2))
+(test 7 (round 7))
+
+(test 1/3 (rationalize (exact .3) 1/10))
+(test #i1/3 (rationalize .3 1/10))
+
+(test 1.0 (inexact (exp 0))) ;; may return exact number
+(test 20.0855369231877 (exp 3))
+
+(test 0.0 (inexact (log 1))) ;; may return exact number
+(test 1.0 (log (exp 1)))
+(test 42.0 (log (exp 42)))
+(test 2.0 (log 100 10))
+(test 12.0 (log 4096 2))
+
+(test 0.0 (inexact (sin 0))) ;; may return exact number
+(test 1.0 (sin 1.5707963267949))
+(test 1.0 (inexact (cos 0))) ;; may return exact number
+(test -1.0 (cos 3.14159265358979))
+(test 0.0 (inexact (tan 0))) ;; may return exact number
+(test 1.5574077246549 (tan 1))
+
+(test 0.0 (inexact (asin 0))) ;; may return exact number
+(test 1.5707963267949 (asin 1))
+(test 0.0 (inexact (acos 1))) ;; may return exact number
+(test 3.14159265358979 (acos -1))
+
+;; (test 0.0-0.0i (asin 0+0.0i))
+;; (test 1.5707963267948966+0.0i (acos 0+0.0i))
+
+(test 0.0 (atan 0.0 1.0))
+(test -0.0 (atan -0.0 1.0))
+(test 0.785398163397448 (atan 1.0 1.0))
+(test 1.5707963267949 (atan 1.0 0.0))
+(test 2.35619449019234 (atan 1.0 -1.0))
+(test 3.14159265358979 (atan 0.0 -1.0))
+(test -3.14159265358979 (atan -0.0 -1.0)) ;
+(test -2.35619449019234 (atan -1.0 -1.0))
+(test -1.5707963267949 (atan -1.0 0.0))
+(test -0.785398163397448 (atan -1.0 1.0))
+;; (test undefined (atan 0.0 0.0))
+
+(test 1764 (square 42))
+(test 4 (square 2))
+
+(test 3.0 (inexact (sqrt 9)))
+(test 1.4142135623731 (sqrt 2))
+(test 0.0+1.0i (inexact (sqrt -1)))
+
+(test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list))
+(test '(2 1) (call-with-values (lambda () (exact-integer-sqrt 5)) list))
+
+(test 27 (expt 3 3))
+(test 1 (expt 0 0))
+(test 0 (expt 0 1))
+(test 1.0 (expt 0.0 0))
+(test 0.0 (expt 0 1.0))
+
+(test 1+2i (make-rectangular 1 2))
+
+(test 0.54030230586814+0.841470984807897i (make-polar 1 1))
+
+(test 1 (real-part 1+2i))
+
+(test 2 (imag-part 1+2i))
+
+(test 2.23606797749979 (magnitude 1+2i))
+
+(test 1.10714871779409 (angle 1+2i))
+
+(test 1.0 (inexact 1))
+(test #t (inexact? (inexact 1)))
+(test 1 (exact 1.0))
+(test #t (exact? (exact 1.0)))
+
+(test 100 (string->number "100"))
+(test 256 (string->number "100" 16))
+(test 100.0 (string->number "1e2"))
+
+(test-end)
+
+(test-begin "6.3 Booleans")
+
+(test #t #t)
+(test #f #f)
+(test #f '#f)
+
+(test #f (not #t))
+(test #f (not 3))
+(test #f (not (list 3)))
+(test #t (not #f))
+(test #f (not '()))
+(test #f (not (list)))
+(test #f (not 'nil))
+
+(test #t (boolean? #f))
+(test #f (boolean? 0))
+(test #f (boolean? '()))
+
+(test #t (boolean=? #t #t))
+(test #t (boolean=? #f #f))
+(test #f (boolean=? #t #f))
+(test #t (boolean=? #f #f #f))
+(test #f (boolean=? #t #t #f))
+
+(test-end)
+
+(test-begin "6.4 Lists")
+
+(let* ((x (list 'a 'b 'c))
+ (y x))
+ (test '(a b c) (values y))
+ (test #t (list? y))
+ (set-cdr! x 4)
+ (test '(a . 4) (values x))
+ (test #t (eqv? x y))
+ (test #f (list? y))
+ (set-cdr! x x)
+ (test #f (list? x)))
+
+(test #t (pair? '(a . b)))
+(test #t (pair? '(a b c)))
+(test #f (pair? '()))
+(test #f (pair? '#(a b)))
+
+(test '(a) (cons 'a '()))
+(test '((a) b c d) (cons '(a) '(b c d)))
+(test '("a" b c) (cons "a" '(b c)))
+(test '(a . 3) (cons 'a 3))
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test 'a (car '(a b c)))
+(test '(a) (car '((a) b c d)))
+(test 1 (car '(1 . 2)))
+
+(test '(b c d) (cdr '((a) b c d)))
+(test 2 (cdr '(1 . 2)))
+(define (g) '(constant-list))
+
+(test #t (list? '(a b c)))
+(test #t (list? '()))
+(test #f (list? '(a . b)))
+(test #f (let ((x (list 'a))) (set-cdr! x x) (list? x)))
+
+(test '(3 3) (make-list 2 3))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+(test '() (list))
+
+(test 3 (length '(a b c)))
+(test 3 (length '(a (b) (c d e))))
+(test 0 (length '()))
+
+(test '(x y) (append '(x) '(y)))
+(test '(a b c d) (append '(a) '(b c d)))
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+
+(test '(a b c . d) (append '(a b) '(c . d)))
+(test 'a (append '() 'a))
+
+(test '(c b a) (reverse '(a b c)))
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+(test '(d e) (list-tail '(a b c d e) 3))
+
+(test 'c (list-ref '(a b c d) 2))
+(test 'c (list-ref '(a b c d)
+ (exact (round 1.8))))
+
+(test '(0 ("Sue" "Sue") "Anna")
+ (let ((lst (list 0 '(2 2 2 2) "Anna")))
+ (list-set! lst 1 '("Sue" "Sue"))
+ lst))
+
+(test '(a b c) (memq 'a '(a b c)))
+(test '(b c) (memq 'b '(a b c)))
+(test #f (memq 'a '(b c d)))
+(test #f (memq (list 'a) '(b (a) c)))
+(test '((a) c) (member (list 'a) '(b (a) c)))
+(test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
+(test '(101 102) (memv 101 '(100 101 102)))
+
+(let ()
+ (define e '((a 1) (b 2) (c 3)))
+ (test '(a 1) (assq 'a e))
+ (test '(b 2) (assq 'b e))
+ (test #f (assq 'd e)))
+
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+(test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+(test '(1 2 3) (list-copy '(1 2 3)))
+(test "foo" (list-copy "foo"))
+(test '() (list-copy '()))
+(test '(3 . 4) (list-copy '(3 . 4)))
+(test '(6 7 8 . 9) (list-copy '(6 7 8 . 9)))
+(let* ((l1 '((a b) (c d) e))
+ (l2 (list-copy l1)))
+ (test l2 '((a b) (c d) e))
+ (test #t (eq? (car l1) (car l2)))
+ (test #t (eq? (cadr l1) (cadr l2)))
+ (test #f (eq? (cdr l1) (cdr l2)))
+ (test #f (eq? (cddr l1) (cddr l2))))
+
+(test-end)
+
+(test-begin "6.5 Symbols")
+
+(test #t (symbol? 'foo))
+(test #t (symbol? (car '(a b))))
+(test #f (symbol? "bar"))
+(test #t (symbol? 'nil))
+(test #f (symbol? '()))
+(test #f (symbol? #f))
+
+(test #t (symbol=? 'a 'a))
+(test #f (symbol=? 'a 'A))
+(test #t (symbol=? 'a 'a 'a))
+(test #f (symbol=? 'a 'a 'A))
+
+(test "flying-fish"
+(symbol->string 'flying-fish))
+(test "Martin" (symbol->string 'Martin))
+(test "Malvina" (symbol->string (string->symbol "Malvina")))
+
+(test 'mISSISSIppi (string->symbol "mISSISSIppi"))
+(test #t (eq? 'bitBlt (string->symbol "bitBlt")))
+(test #t (eq? 'LollyPop (string->symbol (symbol->string 'LollyPop))))
+(test #t (string=? "K. Harper, M.D."
+ (symbol->string (string->symbol "K. Harper, M.D."))))
+
+(test-end)
+
+(test-begin "6.6 Characters")
+
+(test #t (char? #\a))
+(test #f (char? "a"))
+(test #f (char? 'a))
+(test #f (char? 0))
+
+(test #t (char=? #\a #\a #\a))
+(test #f (char=? #\a #\A))
+(test #t (char<? #\a #\b #\c))
+(test #f (char<? #\a #\a))
+(test #f (char<? #\b #\a))
+(test #f (char>? #\a #\b))
+(test #f (char>? #\a #\a))
+(test #t (char>? #\c #\b #\a))
+(test #t (char<=? #\a #\b #\b))
+(test #t (char<=? #\a #\a))
+(test #f (char<=? #\b #\a))
+(test #f (char>=? #\a #\b))
+(test #t (char>=? #\a #\a))
+(test #t (char>=? #\b #\b #\a))
+
+(test #t (char-ci=? #\a #\a))
+(test #t (char-ci=? #\a #\A #\a))
+(test #f (char-ci=? #\a #\b))
+(test #t (char-ci<? #\a #\B #\c))
+(test #f (char-ci<? #\A #\a))
+(test #f (char-ci<? #\b #\A))
+(test #f (char-ci>? #\A #\b))
+(test #f (char-ci>? #\a #\A))
+(test #t (char-ci>? #\c #\B #\a))
+(test #t (char-ci<=? #\a #\B #\b))
+(test #t (char-ci<=? #\A #\a))
+(test #f (char-ci<=? #\b #\A))
+(test #f (char-ci>=? #\A #\b))
+(test #t (char-ci>=? #\a #\A))
+(test #t (char-ci>=? #\b #\B #\a))
+
+(test #t (char-alphabetic? #\a))
+(test #f (char-alphabetic? #\space))
+(test #t (char-numeric? #\0))
+(test #f (char-numeric? #\.))
+(test #f (char-numeric? #\a))
+(test #t (char-whitespace? #\space))
+(test #t (char-whitespace? #\tab))
+(test #t (char-whitespace? #\newline))
+(test #f (char-whitespace? #\_))
+(test #f (char-whitespace? #\a))
+(test #t (char-upper-case? #\A))
+(test #f (char-upper-case? #\a))
+(test #f (char-upper-case? #\3))
+(test #t (char-lower-case? #\a))
+(test #f (char-lower-case? #\A))
+(test #f (char-lower-case? #\3))
+
+(test #t (char-alphabetic? #\Λ))
+(test #f (char-alphabetic? #\x0E50))
+(test #t (char-upper-case? #\Λ))
+(test #f (char-upper-case? #\λ))
+(test #f (char-lower-case? #\Λ))
+(test #t (char-lower-case? #\λ))
+(test #f (char-numeric? #\Λ))
+(test #t (char-numeric? #\x0E50))
+(test #t (char-whitespace? #\x1680))
+
+(test 0 (digit-value #\0))
+(test 3 (digit-value #\3))
+(test 9 (digit-value #\9))
+(test 4 (digit-value #\x0664))
+(test 0 (digit-value #\x0AE6))
+(test #f (digit-value #\.))
+(test #f (digit-value #\-))
+
+(test 97 (char->integer #\a))
+(test #\a (integer->char 97))
+
+(test #\A (char-upcase #\a))
+(test #\A (char-upcase #\A))
+(test #\a (char-downcase #\a))
+(test #\a (char-downcase #\A))
+(test #\a (char-foldcase #\a))
+(test #\a (char-foldcase #\A))
+
+(test #\Λ (char-upcase #\λ))
+(test #\Λ (char-upcase #\Λ))
+(test #\λ (char-downcase #\λ))
+(test #\λ (char-downcase #\Λ))
+(test #\λ (char-foldcase #\λ))
+(test #\λ (char-foldcase #\Λ))
+
+(test-end)
+
+(test-begin "6.7 Strings")
+
+(test #t (string? ""))
+(test #t (string? " "))
+(test #f (string? 'a))
+(test #f (string? #\a))
+
+(test 3 (string-length (make-string 3)))
+(test "---" (make-string 3 #\-))
+
+(test "" (string))
+(test "---" (string #\- #\- #\-))
+(test "kitten" (string #\k #\i #\t #\t #\e #\n))
+
+(test 0 (string-length ""))
+(test 1 (string-length "a"))
+(test 3 (string-length "abc"))
+
+(test #\a (string-ref "abc" 0))
+(test #\b (string-ref "abc" 1))
+(test #\c (string-ref "abc" 2))
+
+(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str))
+
+(test (string #\a #\x1F700 #\c)
+ (let ((s (string #\a #\b #\c)))
+ (string-set! s 1 #\x1F700)
+ s))
+
+(test #t (string=? "" ""))
+(test #t (string=? "abc" "abc" "abc"))
+(test #f (string=? "" "abc"))
+(test #f (string=? "abc" "aBc"))
+
+(test #f (string<? "" ""))
+(test #f (string<? "abc" "abc"))
+(test #t (string<? "abc" "abcd" "acd"))
+(test #f (string<? "abcd" "abc"))
+(test #t (string<? "abc" "bbc"))
+
+(test #f (string>? "" ""))
+(test #f (string>? "abc" "abc"))
+(test #f (string>? "abc" "abcd"))
+(test #t (string>? "acd" "abcd" "abc"))
+(test #f (string>? "abc" "bbc"))
+
+(test #t (string<=? "" ""))
+(test #t (string<=? "abc" "abc"))
+(test #t (string<=? "abc" "abcd" "abcd"))
+(test #f (string<=? "abcd" "abc"))
+(test #t (string<=? "abc" "bbc"))
+
+(test #t (string>=? "" ""))
+(test #t (string>=? "abc" "abc"))
+(test #f (string>=? "abc" "abcd"))
+(test #t (string>=? "abcd" "abcd" "abc"))
+(test #f (string>=? "abc" "bbc"))
+
+(test #t (string-ci=? "" ""))
+(test #t (string-ci=? "abc" "abc"))
+(test #f (string-ci=? "" "abc"))
+(test #t (string-ci=? "abc" "aBc"))
+(test #f (string-ci=? "abc" "aBcD"))
+
+(test #f (string-ci<? "abc" "aBc"))
+(test #t (string-ci<? "abc" "aBcD"))
+(test #f (string-ci<? "ABCd" "aBc"))
+
+(test #f (string-ci>? "abc" "aBc"))
+(test #f (string-ci>? "abc" "aBcD"))
+(test #t (string-ci>? "ABCd" "aBc"))
+
+(test #t (string-ci<=? "abc" "aBc"))
+(test #t (string-ci<=? "abc" "aBcD"))
+(test #f (string-ci<=? "ABCd" "aBc"))
+
+(test #t (string-ci>=? "abc" "aBc"))
+(test #f (string-ci>=? "abc" "aBcD"))
+(test #t (string-ci>=? "ABCd" "aBc"))
+
+(test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ"))
+(test #f (string-ci<? "ΑΒΓ" "αβγ"))
+(test #f (string-ci>? "ΑΒΓ" "αβγ"))
+(test #t (string-ci<=? "ΑΒΓ" "αβγ"))
+(test #t (string-ci>=? "ΑΒΓ" "αβγ"))
+
+;; latin
+(test "ABC" (string-upcase "abc"))
+(test "ABC" (string-upcase "ABC"))
+(test "abc" (string-downcase "abc"))
+(test "abc" (string-downcase "ABC"))
+(test "abc" (string-foldcase "abc"))
+(test "abc" (string-foldcase "ABC"))
+
+;; cyrillic
+(test "ΑΒΓ" (string-upcase "αβγ"))
+(test "ΑΒΓ" (string-upcase "ΑΒΓ"))
+(test "αβγ" (string-downcase "αβγ"))
+(test "αβγ" (string-downcase "ΑΒΓ"))
+(test "αβγ" (string-foldcase "αβγ"))
+(test "αβγ" (string-foldcase "ΑΒΓ"))
+
+;; special cases
+(test "SSA" (string-upcase "ßa"))
+(test "ßa" (string-downcase "ßa"))
+(test "ssa" (string-downcase "SSA"))
+(test "İ" (string-upcase "İ"))
+(test "i\x0307;" (string-downcase "İ"))
+(test "i\x0307;" (string-foldcase "İ"))
+(test "J̌" (string-upcase "ǰ"))
+
+;; context-sensitive (final sigma)
+(test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα"))
+(test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ"))
+(test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ"))
+(test "ΜΈΛΟΣ" (string-upcase "μέλος"))
+(test #t (and (member (string-downcase "ΜΈΛΟΣ") '("μέλος" "μέλοσ")) #t))
+(test "μέλοσ" (string-foldcase "ΜΈΛΟΣ"))
+(test #t (and (member (string-downcase "ΜΈΛΟΣ ΕΝΌΣ")
+ '("μέλος ενός" "μέλοσ ενόσ"))
+ #t))
+
+(test "" (substring "" 0 0))
+(test "" (substring "a" 0 0))
+(test "" (substring "abc" 1 1))
+(test "ab" (substring "abc" 0 2))
+(test "bc" (substring "abc" 1 3))
+
+(test "" (string-append ""))
+(test "" (string-append "" ""))
+(test "abc" (string-append "" "abc"))
+(test "abc" (string-append "abc" ""))
+(test "abcde" (string-append "abc" "de"))
+(test "abcdef" (string-append "abc" "de" "f"))
+
+(test '() (string->list ""))
+(test '(#\a) (string->list "a"))
+(test '(#\a #\b #\c) (string->list "abc"))
+(test '(#\a #\b #\c) (string->list "abc" 0))
+(test '(#\b #\c) (string->list "abc" 1))
+(test '(#\b #\c) (string->list "abc" 1 3))
+
+(test "" (list->string '()))
+(test "abc" (list->string '(#\a #\b #\c)))
+
+(test "" (string-copy ""))
+(test "" (string-copy "" 0))
+(test "" (string-copy "" 0 0))
+(test "abc" (string-copy "abc"))
+(test "abc" (string-copy "abc" 0))
+(test "bc" (string-copy "abc" 1))
+(test "b" (string-copy "abc" 1 2))
+(test "bc" (string-copy "abc" 1 3))
+
+(test "-----"
+ (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
+(test "xx---"
+ (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
+(test "xx-xx"
+ (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
+
+(test "a12de"
+ (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
+(test "-----"
+ (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
+(test "---xx"
+ (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
+(test "xx---"
+ (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
+(test "xx-xx"
+ (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
+
+;; same source and dest
+(test "aabde"
+ (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
+(test "abcab"
+ (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
+
+(test-end)
+
+(test-begin "6.8 Vectors")
+
+(test #t (vector? #()))
+(test #t (vector? #(1 2 3)))
+(test #t (vector? '#(1 2 3)))
+
+(test 0 (vector-length (make-vector 0)))
+(test 1000 (vector-length (make-vector 1000)))
+
+(test #(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna"))
+
+(test #(a b c) (vector 'a 'b 'c))
+
+(test 8 (vector-ref '#(1 1 2 3 5 8 13 21) 5))
+(test 13 (vector-ref '#(1 1 2 3 5 8 13 21)
+ (let ((i (round (* 2 (acos -1)))))
+ (if (inexact? i)
+ (exact i)
+ i))))
+
+(test #(0 ("Sue" "Sue") "Anna") (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+
+(test '(dah dah didah) (vector->list '#(dah dah didah)))
+(test '(dah didah) (vector->list '#(dah dah didah) 1))
+(test '(dah) (vector->list '#(dah dah didah) 1 2))
+(test #(dididit dah) (list->vector '(dididit dah)))
+
+(test #() (string->vector ""))
+(test #(#\A #\B #\C) (string->vector "ABC"))
+(test #(#\B #\C) (string->vector "ABC" 1))
+(test #(#\B) (string->vector "ABC" 1 2))
+
+(test "" (vector->string #()))
+(test "123" (vector->string #(#\1 #\2 #\3)))
+(test "23" (vector->string #(#\1 #\2 #\3) 1))
+(test "2" (vector->string #(#\1 #\2 #\3) 1 2))
+
+(test #() (vector-copy #()))
+(test #(a b c) (vector-copy #(a b c)))
+(test #(b c) (vector-copy #(a b c) 1))
+(test #(b) (vector-copy #(a b c) 1 2))
+
+(test #() (vector-append #()))
+(test #() (vector-append #() #()))
+(test #(a b c) (vector-append #() #(a b c)))
+(test #(a b c) (vector-append #(a b c) #()))
+(test #(a b c d e) (vector-append #(a b c) #(d e)))
+(test #(a b c d e f) (vector-append #(a b c) #(d e) #(f)))
+
+(test #(1 2 smash smash 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec))
+(test #(x x x x x)
+ (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec))
+(test #(1 2 x x x)
+ (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec))
+(test #(1 2 x 4 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec))
+
+(test #(1 a b 4 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 #(a b c d e) 0 2) vec))
+(test #(a b c d e)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e)) vec))
+(test #(c d e 4 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e) 2) vec))
+(test #(1 2 a b c)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 0 3) vec))
+(test #(1 2 c 4 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 2 3) vec))
+
+;; same source and dest
+(test #(1 1 2 4 5)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 vec 0 2) vec))
+(test #(1 2 3 1 2)
+ (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 3 vec 0 2) vec))
+
+(test-end)
+
+(test-begin "6.9 Bytevectors")
+
+(test #t (bytevector? #u8()))
+(test #t (bytevector? #u8(0 1 2)))
+(test #f (bytevector? #()))
+(test #f (bytevector? #(0 1 2)))
+(test #f (bytevector? '()))
+(test #t (bytevector? (make-bytevector 0)))
+
+(test 0 (bytevector-length (make-bytevector 0)))
+(test 1024 (bytevector-length (make-bytevector 1024)))
+(test 1024 (bytevector-length (make-bytevector 1024 255)))
+
+(test 3 (bytevector-length (bytevector 0 1 2)))
+
+(test 0 (bytevector-u8-ref (bytevector 0 1 2) 0))
+(test 1 (bytevector-u8-ref (bytevector 0 1 2) 1))
+(test 2 (bytevector-u8-ref (bytevector 0 1 2) 2))
+
+(test #u8(0 255 2)
+ (let ((bv (bytevector 0 1 2))) (bytevector-u8-set! bv 1 255) bv))
+
+(test #u8() (bytevector-copy #u8()))
+(test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
+(test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
+(test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
+
+(test #u8(1 6 7 4 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 1 #u8(6 7 8 9 10) 0 2)
+ bv))
+(test #u8(6 7 8 9 10)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 0 #u8(6 7 8 9 10))
+ bv))
+(test #u8(8 9 10 4 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 0 #u8(6 7 8 9 10) 2)
+ bv))
+(test #u8(1 2 6 7 8)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 2 #u8(6 7 8 9 10) 0 3)
+ bv))
+(test #u8(1 2 8 4 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 2 #u8(6 7 8 9 10) 2 3)
+ bv))
+
+;; same source and dest
+(test #u8(1 1 2 4 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 1 bv 0 2)
+ bv))
+(test #u8(1 2 3 1 2)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (bytevector-copy! bv 3 bv 0 2)
+ bv))
+
+(test #u8() (bytevector-append #u8()))
+(test #u8() (bytevector-append #u8() #u8()))
+(test #u8(0 1 2) (bytevector-append #u8() #u8(0 1 2)))
+(test #u8(0 1 2) (bytevector-append #u8(0 1 2) #u8()))
+(test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4)))
+(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5)))
+
+(test "ABC" (utf8->string #u8(#x41 #x42 #x43)))
+(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1))
+(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4))
+(test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3))
+(test #u8(#x41 #x42 #x43) (string->utf8 "ABC"))
+(test #u8(#x42 #x43) (string->utf8 "ABC" 1))
+(test #u8(#x42) (string->utf8 "ABC" 1 2))
+(test #u8(#xCE #xBB) (string->utf8 "λ"))
+
+(test-end)
+
+(test-begin "6.10 Control Features")
+
+(test #t (procedure? car))
+(test #f (procedure? 'car))
+(test #t (procedure? (lambda (x) (* x x))))
+(test #f (procedure? '(lambda (x) (* x x))))
+(test #t (call-with-current-continuation procedure?))
+
+(test 7 (apply + (list 3 4)))
+
+(define compose
+ (lambda (f g)
+ (lambda args
+ (f (apply g args)))))
+(test '(30 0)
+ (call-with-values (lambda () ((compose exact-integer-sqrt *) 12 75))
+ list))
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6 7)))
+
+(test #t
+ (let ((res (let ((count 0))
+ (map (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b)))))
+ (or (equal? res '(1 2))
+ (equal? res '(2 1)))))
+
+(test '(10 200 3000 40 500 6000)
+ (let ((ls1 (list 10 100 1000))
+ (ls2 (list 1 2 3 4 5 6)))
+ (set-cdr! (cddr ls1) ls1)
+ (map * ls1 ls2)))
+
+(test "abdegh" (string-map char-foldcase "AbdEgH"))
+
+(test "IBM" (string-map
+ (lambda (c)
+ (integer->char (+ 1 (char->integer c))))
+ "HAL"))
+
+(test "StUdLyCaPs"
+ (string-map
+ (lambda (c k) (if (eqv? k #\u) (char-upcase c) (char-downcase c)))
+ "studlycaps xxx"
+ "ululululul"))
+
+(test #(b e h) (vector-map cadr '#((a b) (d e) (g h))))
+
+(test #(1 4 27 256 3125)
+ (vector-map (lambda (n) (expt n n))
+ '#(1 2 3 4 5)))
+
+(test #(5 7 9) (vector-map + '#(1 2 3) '#(4 5 6 7)))
+
+(test #t
+ (let ((res (let ((count 0))
+ (vector-map
+ (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '#(a b)))))
+ (or (equal? res #(1 2))
+ (equal? res #(2 1)))))
+
+(test #(0 1 4 9 16)
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i)
+ (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+
+(test 9750
+ (let ((ls1 (list 10 100 1000))
+ (ls2 (list 1 2 3 4 5 6))
+ (count 0))
+ (set-cdr! (cddr ls1) ls1)
+ (for-each (lambda (x y) (set! count (+ count (* x y)))) ls2 ls1)
+ count))
+
+(test '(101 100 99 98 97)
+ (let ((v '()))
+ (string-for-each
+ (lambda (c) (set! v (cons (char->integer c) v)))
+ "abcde")
+ v))
+
+(test '(0 1 4 9 16) (let ((v (make-list 5)))
+ (vector-for-each
+ (lambda (i) (list-set! v i (* i i)))
+ '#(0 1 2 3 4))
+ v))
+
+(test -3 (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t)))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r
+ (lambda (obj)
+ (cond ((null? obj) 0)
+ ((pair? obj)
+ (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+
+(test 4 (list-length '(1 2 3 4)))
+
+(test #f (list-length '(a b . c)))
+
+(test 5
+ (call-with-values (lambda () (values 4 5))
+ (lambda (a b) b)))
+
+(test -1 (call-with-values * -))
+
+(test '(connect talk1 disconnect
+ connect talk2 disconnect)
+ (let ((path '())
+ (c #f))
+ (let ((add (lambda (s)
+ (set! path (cons s path)))))
+ (dynamic-wind
+ (lambda () (add 'connect))
+ (lambda ()
+ (add (call-with-current-continuation
+ (lambda (c0)
+ (set! c c0)
+ 'talk1))))
+ (lambda () (add 'disconnect)))
+ (if (< (length path) 4)
+ (c 'talk2)
+ (reverse path)))))
+
+(test-end)
+
+(test-begin "6.11 Exceptions")
+
+(test 65
+ (with-exception-handler
+ (lambda (con) 42)
+ (lambda ()
+ (+ (raise-continuable "should be a number")
+ 23))))
+
+(test #t
+ (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+(test "BOOM!"
+ (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+(test '(1 2 3)
+ (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+
+(test #f
+ (file-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+ (file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
+
+(test #f
+ (read-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+ (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
+
+(define something-went-wrong #f)
+(define (test-exception-handler-1 v)
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (x)
+ (set! something-went-wrong (list "condition: " x))
+ (k 'exception))
+ (lambda ()
+ (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))))
+(test 106 (test-exception-handler-1 5))
+(test #f something-went-wrong)
+(test 'exception (test-exception-handler-1 -1))
+(test '("condition: " an-error) something-went-wrong)
+
+(set! something-went-wrong #f)
+(define (test-exception-handler-2 v)
+ (guard (ex (else 'caught-another-exception))
+ (with-exception-handler
+ (lambda (x)
+ (set! something-went-wrong #t)
+ (list "exception:" x))
+ (lambda ()
+ (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
+(test 106 (test-exception-handler-2 5))
+(test #f something-went-wrong)
+(test 'caught-another-exception (test-exception-handler-2 -1))
+(test #t something-went-wrong)
+
+;; Based on an example from R6RS-lib section 7.1 Exceptions.
+;; R7RS section 6.11 Exceptions has a simplified version.
+(let* ((out (open-output-string))
+ (value (with-exception-handler
+ (lambda (con)
+ (cond
+ ((not (list? con))
+ (raise con))
+ ((list? con)
+ (display (car con) out))
+ (else
+ (display "a warning has been issued" out)))
+ 42)
+ (lambda ()
+ (+ (raise-continuable
+ (list "should be a number"))
+ 23)))))
+ (test "should be a number" (get-output-string out))
+ (test 65 value))
+
+;; From SRFI-34 "Examples" section - #3
+(define (test-exception-handler-3 v out)
+ (guard (condition
+ (else
+ (display "condition: " out)
+ (write condition out)
+ (display #\! out)
+ 'exception))
+ (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
+(let* ((out (open-output-string))
+ (value (test-exception-handler-3 0 out)))
+ (test 'exception value)
+ (test "condition: an-error!" (get-output-string out)))
+
+(define (test-exception-handler-4 v out)
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (x)
+ (display "reraised " out)
+ (write x out) (display #\! out)
+ (k 'zero))
+ (lambda ()
+ (guard (condition
+ ((positive? condition)
+ 'positive)
+ ((negative? condition)
+ 'negative))
+ (raise v)))))))
+
+;; From SRFI-34 "Examples" section - #5
+(let* ((out (open-output-string))
+ (value (test-exception-handler-4 1 out)))
+ (test "" (get-output-string out))
+ (test 'positive value))
+;; From SRFI-34 "Examples" section - #6
+(let* ((out (open-output-string))
+ (value (test-exception-handler-4 -1 out)))
+ (test "" (get-output-string out))
+ (test 'negative value))
+;; From SRFI-34 "Examples" section - #7
+(let* ((out (open-output-string))
+ (value (test-exception-handler-4 0 out)))
+ (test "reraised 0!" (get-output-string out))
+ (test 'zero value))
+
+;; From SRFI-34 "Examples" section - #8
+(test 42
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'a 42)))))
+
+;; From SRFI-34 "Examples" section - #9
+(test '(b . 23)
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'b 23)))))
+
+(test 'caught-d
+ (guard (condition
+ ((assq 'c condition) 'caught-c)
+ ((assq 'd condition) 'caught-d))
+ (list
+ (sqrt 8)
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'd 24)))))))
+
+(test-end)
+
+(test-begin "6.12 Environments and evaluation")
+
+;; (test 21 (eval '(* 7 3) (scheme-report-environment 5)))
+
+(test 20
+ (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
+ (f + 10)))
+
+(test 1024 (eval '(expt 2 10) (environment '(scheme base))))
+;; (sin 0) may return exact number
+(test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
+;; ditto
+(test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
+ (environment '(scheme base) '(scheme inexact))))
+
+(test-end)
+
+(test-begin "6.13 Input and output")
+
+(test #t (port? (current-input-port)))
+(test #t (input-port? (current-input-port)))
+(test #t (output-port? (current-output-port)))
+(test #t (output-port? (current-error-port)))
+(test #t (input-port? (open-input-string "abc")))
+(test #t (output-port? (open-output-string)))
+
+(test #t (textual-port? (open-input-string "abc")))
+(test #t (textual-port? (open-output-string)))
+(test #t (binary-port? (open-input-bytevector #u8(0 1 2))))
+(test #t (binary-port? (open-output-bytevector)))
+
+(test #t (input-port-open? (open-input-string "abc")))
+(test #t (output-port-open? (open-output-string)))
+
+(test #f
+ (let ((in (open-input-string "abc")))
+ (close-input-port in)
+ (input-port-open? in)))
+
+(test #f
+ (let ((out (open-output-string)))
+ (close-output-port out)
+ (output-port-open? out)))
+
+(test #f
+ (let ((out (open-output-string)))
+ (close-port out)
+ (output-port-open? out)))
+
+(test 'error
+ (let ((in (open-input-string "abc")))
+ (close-input-port in)
+ (guard (exn (else 'error)) (read-char in))))
+
+(test 'error
+ (let ((out (open-output-string)))
+ (close-output-port out)
+ (guard (exn (else 'error)) (write-char #\c out))))
+
+(test #t (eof-object? (eof-object)))
+(test #t (eof-object? (read (open-input-string ""))))
+(test #t (char-ready? (open-input-string "42")))
+(test 42 (read (open-input-string " 42 ")))
+
+(test #t (eof-object? (read-char (open-input-string ""))))
+(test #\a (read-char (open-input-string "abc")))
+
+(test #t (eof-object? (read-line (open-input-string ""))))
+(test "abc" (read-line (open-input-string "abc")))
+(test "abc" (read-line (open-input-string "abc\ndef\n")))
+
+(test #t (eof-object? (read-string 3 (open-input-string ""))))
+(test "abc" (read-string 3 (open-input-string "abcd")))
+(test "abc" (read-string 3 (open-input-string "abc\ndef\n")))
+
+(let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702))))
+ (let* ((c1 (read-char in))
+ (c2 (read-char in))
+ (c3 (read-char in)))
+ (test #\x10F700 c1)
+ (test #\x10F701 c2)
+ (test #\x10F702 c3)))
+
+(test (string #\x10F700)
+ (let ((out (open-output-string)))
+ (write-char #\x10F700 out)
+ (get-output-string out)))
+
+(test "abc"
+ (let ((out (open-output-string)))
+ (write 'abc out)
+ (get-output-string out)))
+
+(test "abc def"
+ (let ((out (open-output-string)))
+ (display "abc def" out)
+ (get-output-string out)))
+
+(test "abc"
+ (let ((out (open-output-string)))
+ (display #\a out)
+ (display "b" out)
+ (display #\c out)
+ (get-output-string out)))
+
+(test #t
+ (let* ((out (open-output-string))
+ (r (begin (newline out) (get-output-string out))))
+ (or (equal? r "\n") (equal? r "\r\n"))))
+
+(test "abc def"
+ (let ((out (open-output-string)))
+ (write-string "abc def" out)
+ (get-output-string out)))
+
+(test "def"
+ (let ((out (open-output-string)))
+ (write-string "abc def" out 4)
+ (get-output-string out)))
+
+(test "c d"
+ (let ((out (open-output-string)))
+ (write-string "abc def" out 2 5)
+ (get-output-string out)))
+
+(test ""
+ (let ((out (open-output-string)))
+ (flush-output-port out)
+ (get-output-string out)))
+
+(test #t (eof-object? (read-u8 (open-input-bytevector #u8()))))
+(test 1 (read-u8 (open-input-bytevector #u8(1 2 3))))
+
+(test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8()))))
+(test #t (u8-ready? (open-input-bytevector #u8(1))))
+(test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1))))
+(test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2))))
+(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3))))
+(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3 4))))
+
+(test #t
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (eof-object? (read-bytevector! bv (open-input-bytevector #u8())))))
+
+(test #u8(6 7 8 9 10)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 5)
+ bv))
+
+(test #u8(6 7 8 4 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 3)
+ bv))
+
+(test #u8(1 2 3 6 5)
+ (let ((bv (bytevector 1 2 3 4 5)))
+ (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 3 4)
+ bv))
+
+(test #u8(1 2 3)
+ (let ((out (open-output-bytevector)))
+ (write-u8 1 out)
+ (write-u8 2 out)
+ (write-u8 3 out)
+ (get-output-bytevector out)))
+
+(test #u8(1 2 3 4 5)
+ (let ((out (open-output-bytevector)))
+ (write-bytevector #u8(1 2 3 4 5) out)
+ (get-output-bytevector out)))
+
+(test #u8(3 4 5)
+ (let ((out (open-output-bytevector)))
+ (write-bytevector #u8(1 2 3 4 5) out 2)
+ (get-output-bytevector out)))
+
+(test #u8(3 4)
+ (let ((out (open-output-bytevector)))
+ (write-bytevector #u8(1 2 3 4 5) out 2 4)
+ (get-output-bytevector out)))
+
+(test #u8()
+ (let ((out (open-output-bytevector)))
+ (flush-output-port out)
+ (get-output-bytevector out)))
+
+(test #t
+ (and (member
+ (let ((out (open-output-string))
+ (x (list 1)))
+ (set-cdr! x x)
+ (write x out)
+ (get-output-string out))
+ ;; labels not guaranteed to be 0 indexed, spacing may differ
+ '("#0=(1 . #0#)" "#1=(1 . #1#)"))
+ #t))
+
+(test "((1 2 3) (1 2 3))"
+ (let ((out (open-output-string))
+ (x (list 1 2 3)))
+ (write (list x x) out)
+ (get-output-string out)))
+
+(test "((1 2 3) (1 2 3))"
+ (let ((out (open-output-string))
+ (x (list 1 2 3)))
+ (write-simple (list x x) out)
+ (get-output-string out)))
+
+(test #t
+ (and (member (let ((out (open-output-string))
+ (x (list 1 2 3)))
+ (write-shared (list x x) out)
+ (get-output-string out))
+ '("(#0=(1 2 3) #0#)" "(#1=(1 2 3) #1#)"))
+ #t))
+
+(test-begin "Read syntax")
+
+;; check reading boolean followed by eof
+(test #t (read (open-input-string "#t")))
+(test #t (read (open-input-string "#true")))
+(test #f (read (open-input-string "#f")))
+(test #f (read (open-input-string "#false")))
+(define (read2 port)
+ (let* ((o1 (read port)) (o2 (read port)))
+ (cons o1 o2)))
+;; check reading boolean followed by delimiter
+(test '(#t . (5)) (read2 (open-input-string "#t(5)")))
+(test '(#t . 6) (read2 (open-input-string "#true 6 ")))
+(test '(#f . 7) (read2 (open-input-string "#f 7")))
+(test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
+
+(test '() (read (open-input-string "()")))
+(test '(1 2) (read (open-input-string "(1 2)")))
+(test '(1 . 2) (read (open-input-string "(1 . 2)")))
+(test '(1 2) (read (open-input-string "(1 . (2))")))
+(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
+(test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
+(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
+
+(test '(quote (1 2)) (read (open-input-string "'(1 2)")))
+(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
+(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
+(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
+
+(test #() (read (open-input-string "#()")))
+(test #(a b) (read (open-input-string "#(a b)")))
+
+(test #u8() (read (open-input-string "#u8()")))
+(test #u8(0 1) (read (open-input-string "#u8(0 1)")))
+
+(test 'abc (read (open-input-string "abc")))
+(test 'abc (read (open-input-string "abc def")))
+(test 'ABC (read (open-input-string "ABC")))
+(test 'Hello (read (open-input-string "|H\\x65;llo|")))
+
+(test 'abc (read (open-input-string "#!fold-case ABC")))
+(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
+
+(test 'def (read (open-input-string "#; abc def")))
+(test 'def (read (open-input-string "; abc \ndef")))
+(test 'def (read (open-input-string "#| abc |# def")))
+(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
+(test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
+(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
+(test '(a d) (read (open-input-string "(a #; #;b c d)")))
+(test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
+(test '(a . c) (read (open-input-string "(a . #;b c)")))
+(test '(a . b) (read (open-input-string "(a . b #;c)")))
+
+(define (test-read-error str)
+ (test-assert str
+ (guard (exn (else #t))
+ (read (open-input-string str))
+ #f)))
+
+(test-read-error "(#;a . b)")
+(test-read-error "(a . #;b)")
+(test-read-error "(a #;. b)")
+(test-read-error "(#;x #;y . z)")
+(test-read-error "(#; #;x #;y . z)")
+(test-read-error "(#; #;x . z)")
+
+(test #\a (read (open-input-string "#\\a")))
+(test #\space (read (open-input-string "#\\space")))
+(test 0 (char->integer (read (open-input-string "#\\null"))))
+(test 7 (char->integer (read (open-input-string "#\\alarm"))))
+(test 8 (char->integer (read (open-input-string "#\\backspace"))))
+(test 9 (char->integer (read (open-input-string "#\\tab"))))
+(test 10 (char->integer (read (open-input-string "#\\newline"))))
+(test 13 (char->integer (read (open-input-string "#\\return"))))
+(test #x7F (char->integer (read (open-input-string "#\\delete"))))
+(test #x1B (char->integer (read (open-input-string "#\\escape"))))
+(test #x03BB (char->integer (read (open-input-string "#\\λ"))))
+(test #x03BB (char->integer (read (open-input-string "#\\x03BB"))))
+
+(test "abc" (read (open-input-string "\"abc\"")))
+(test "abc" (read (open-input-string "\"abc\" \"def\"")))
+(test "ABC" (read (open-input-string "\"ABC\"")))
+(test "Hello" (read (open-input-string "\"H\\x65;llo\"")))
+(test 7 (char->integer (string-ref (read (open-input-string "\"\\a\"")) 0)))
+(test 8 (char->integer (string-ref (read (open-input-string "\"\\b\"")) 0)))
+(test 9 (char->integer (string-ref (read (open-input-string "\"\\t\"")) 0)))
+(test 10 (char->integer (string-ref (read (open-input-string "\"\\n\"")) 0)))
+(test 13 (char->integer (string-ref (read (open-input-string "\"\\r\"")) 0)))
+(test #x22 (char->integer (string-ref (read (open-input-string "\"\\\"\"")) 0)))
+(test #x7C (char->integer (string-ref (read (open-input-string "\"\\|\"")) 0)))
+(test "line 1\nline 2\n" (read (open-input-string "\"line 1\nline 2\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\\ncontinued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\ \ncontinued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\\n continued\n\"")))
+(test "line 1continued\n" (read (open-input-string "\"line 1\\ \t \n \t continued\n\"")))
+(test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\"")))
+(test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0)))
+
+(define-syntax test-write-syntax
+ (syntax-rules ()
+ ((test-write-syntax expect-str obj-expr)
+ (let ((out (open-output-string)))
+ (write obj-expr out)
+ (test expect-str (get-output-string out))))))
+
+(test-write-syntax "|.|" '|.|)
+(test-write-syntax "|a b|" '|a b|)
+(test-write-syntax "|,a|" '|,a|)
+;; (test-write-syntax "|\"|" '|\"|)
+(test-write-syntax "a" '|a|)
+;; (test-write-syntax "a.b" '|a.b|)
+(test-write-syntax "|2|" '|2|)
+(test-write-syntax "|+3|" '|+3|)
+(test-write-syntax "|-.4|" '|-.4|)
+(test-write-syntax "|+i|" '|+i|)
+(test-write-syntax "|-i|" '|-i|)
+(test-write-syntax "|+inf.0|" '|+inf.0|)
+(test-write-syntax "|-inf.0|" '|-inf.0|)
+(test-write-syntax "|+nan.0|" '|+nan.0|)
+(test-write-syntax "|+NaN.0|" '|+NaN.0|)
+(test-write-syntax "|+NaN.0abc|" '|+NaN.0abc|)
+
+(test-end)
+
+(test-begin "Numeric syntax")
+
+;; Numeric syntax adapted from Peter Bex's tests.
+;;
+;; These are updated to R7RS, using string ports instead of
+;; string->number, and "error" tests removed because implementations
+;; are free to provide their own numeric extensions. Currently all
+;; tests are run by default - need to cond-expand and test for
+;; infinities and -0.0.
+
+(define-syntax test-numeric-syntax
+ (syntax-rules ()
+ ((test-numeric-syntax str expect strs ...)
+ (let* ((z (read (open-input-string str)))
+ (out (open-output-string))
+ (z-str (begin (write z out) (get-output-string out))))
+ (test expect (values z))
+ (test #t (and (member z-str '(str strs ...)) #t))))))
+
+;; Each test is of the form:
+;;
+;; (test-numeric-syntax input-str expected-value expected-write-values ...)
+;;
+;; where the input should be eqv? to the expected-value, and the
+;; written output the same as any of the expected-write-values. The
+;; form
+;;
+;; (test-numeric-syntax input-str expected-value)
+;;
+;; is a shorthand for
+;;
+;; (test-numeric-syntax input-str expected-value (input-str))
+
+;; Simple
+(test-numeric-syntax "1" 1)
+(test-numeric-syntax "+1" 1 "1")
+(test-numeric-syntax "-1" -1)
+(test-numeric-syntax "#i1" 1.0 "1.0" "1.")
+(test-numeric-syntax "#I1" 1.0 "1.0" "1.")
+(test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.")
+;; Decimal
+(test-numeric-syntax "1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "1." 1.0 "1.0" "1.")
+(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
+(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
+;; Some Schemes don't allow negative zero. This is okay with the standard
+(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "#i1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "#e1.0" 1 "1")
+(test-numeric-syntax "#e-.0" 0 "0")
+(test-numeric-syntax "#e-0." 0 "0")
+;; Decimal notation with suffix
+(test-numeric-syntax "1e2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1E2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1s2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1S2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1f2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1F2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1d2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1D2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1l2" 100.0 "100.0" "100.")
+(test-numeric-syntax "1L2" 100.0 "100.0" "100.")
+;; NaN, Inf
+(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0")
+;; Exact ratios
+(test-numeric-syntax "1/2" (/ 1 2))
+(test-numeric-syntax "#e1/2" (/ 1 2) "1/2")
+(test-numeric-syntax "10/2" 5 "5")
+(test-numeric-syntax "-1/2" (- (/ 1 2)))
+(test-numeric-syntax "0/10" 0 "0")
+(test-numeric-syntax "#e0/10" 0 "0")
+(test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5")
+;; Exact complex
+(test-numeric-syntax "1+2i" (make-rectangular 1 2))
+(test-numeric-syntax "1+2I" (make-rectangular 1 2) "1+2i")
+(test-numeric-syntax "1-2i" (make-rectangular 1 -2))
+(test-numeric-syntax "-1+2i" (make-rectangular -1 2))
+(test-numeric-syntax "-1-2i" (make-rectangular -1 -2))
+(test-numeric-syntax "+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "0+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i")
+(test-numeric-syntax "-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "0-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i")
+(test-numeric-syntax "+2i" (make-rectangular 0 2) "2i" "+2i" "0+2i")
+(test-numeric-syntax "-2i" (make-rectangular 0 -2) "-2i" "0-2i")
+;; Decimal-notation complex numbers (rectangular notation)
+(test-numeric-syntax "1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i")
+(test-numeric-syntax "1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i")
+(test-numeric-syntax "1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+(test-numeric-syntax "1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+(test-numeric-syntax "1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+(test-numeric-syntax "1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+;; Fractional complex numbers (rectangular notation)
+(test-numeric-syntax "1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4)))
+;; Mixed fractional/decimal notation complex numbers (rectangular notation)
+(test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4))
+ "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i")
+;; Complex NaN, Inf (rectangular notation)
+;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i")
+(test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i")
+(test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i")
+(test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i")
+(test-numeric-syntax "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0) "+Inf.0-Inf.0i")
+;; Complex numbers (polar notation)
+;; Need to account for imprecision in write output.
+;;(test-numeric-syntax "1@2" -0.416146836547142+0.909297426825682i "-0.416146836547142+0.909297426825682i")
+;; Base prefixes
+(test-numeric-syntax "#x11" 17 "17")
+(test-numeric-syntax "#X11" 17 "17")
+(test-numeric-syntax "#d11" 11 "11")
+(test-numeric-syntax "#D11" 11 "11")
+(test-numeric-syntax "#o11" 9 "9")
+(test-numeric-syntax "#O11" 9 "9")
+(test-numeric-syntax "#b11" 3 "3")
+(test-numeric-syntax "#B11" 3 "3")
+(test-numeric-syntax "#o7" 7 "7")
+(test-numeric-syntax "#xa" 10 "10")
+(test-numeric-syntax "#xA" 10 "10")
+(test-numeric-syntax "#xf" 15 "15")
+(test-numeric-syntax "#x-10" -16 "-16")
+(test-numeric-syntax "#d-10" -10 "-10")
+(test-numeric-syntax "#o-10" -8 "-8")
+(test-numeric-syntax "#b-10" -2 "-2")
+;; Combination of prefixes
+(test-numeric-syntax "#e#x10" 16 "16")
+(test-numeric-syntax "#i#x10" 16.0 "16.0" "16.")
+;; (Attempted) decimal notation with base prefixes
+(test-numeric-syntax "#d1." 1.0 "1.0" "1.")
+(test-numeric-syntax "#d.1" 0.1 "0.1" ".1" "100.0e-3")
+(test-numeric-syntax "#x1e2" 482 "482")
+(test-numeric-syntax "#d1e2" 100.0 "100.0" "100.")
+;; Fractions with prefixes
+(test-numeric-syntax "#x10/2" 8 "8")
+(test-numeric-syntax "#x11/2" (/ 17 2) "17/2")
+(test-numeric-syntax "#d11/2" (/ 11 2) "11/2")
+(test-numeric-syntax "#o11/2" (/ 9 2) "9/2")
+(test-numeric-syntax "#b11/10" (/ 3 2) "3/2")
+;; Complex numbers with prefixes
+;;(test-numeric-syntax "#x10+11i" (make-rectangular 16 17) "16+17i")
+(test-numeric-syntax "#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i")
+(test-numeric-syntax "#d10+11i" (make-rectangular 10 11) "10+11i")
+;;(test-numeric-syntax "#o10+11i" (make-rectangular 8 9) "8+9i")
+;;(test-numeric-syntax "#b10+11i" (make-rectangular 2 3) "2+3i")
+;;(test-numeric-syntax "#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i")
+;;(test-numeric-syntax "#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i")
+
+(test-end)
+
+(test-end)
+
+(test-begin "6.14 System interface")
+
+;; 6.14 System interface
+
+;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH"))
+
+(test #t (string? (get-environment-variable "PATH")))
+
+;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables))
+
+(let ((env (get-environment-variables)))
+ (define (env-pair? x)
+ (and (pair? x) (string? (car x)) (string? (cdr x))))
+ (define (all? pred ls)
+ (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
+ (test #t (list? env))
+ (test #t (all? env-pair? env)))
+
+(test #t (list? (command-line)))
+
+(test #t (real? (current-second)))
+(test #t (inexact? (current-second)))
+(test #t (exact? (current-jiffy)))
+(test #t (exact? (jiffies-per-second)))
+
+(test #t (list? (features)))
+(test #t (and (memq 'r7rs (features)) #t))
+
+(test #t (file-exists? "."))
+(test #f (file-exists? " no such file "))
+
+(test #t (file-error?
+ (guard (exn (else exn))
+ (delete-file " no such file "))))
+
+(test-end)
+
+(test-end)
+
+
+;; Added in Guile
+;(test-exit)
--
2.9.4
^ permalink raw reply related [flat|nested] 3+ messages in thread
end of thread, other threads:[~2017-06-19 6:41 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-06-18 11:14 On adding Kawa/Chibi R7RS test-suite to the r7rs-wip branch Freja Nordsiek
2017-06-19 5:25 ` Mark H Weaver
2017-06-19 6:41 ` Freja Nordsiek
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).