* 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