From 51f953cf3152a8653ed00ff66fccd9ced227551f Mon Sep 17 00:00:00 2001 From: Freja Nordsiek 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 ( ...)) " + (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 +;; and John Cowan : +;; 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 + (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)) +(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)) +(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 #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 #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 #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 "address@hidden" -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