[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [PATCH] Switch to modernized SRFI-64 implementation.
|
From: |
Taylan Ulrich Bayırlı/Kammer |
|
Subject: |
Re: [PATCH] Switch to modernized SRFI-64 implementation. |
|
Date: |
Tue, 22 Sep 2015 11:27:48 +0200 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) |
address@hidden (Taylan Ulrich "Bayırlı/Kammer") writes:
> This patch swaps out our SRFI-64 implementation for the one hosted at:
>
> https://github.com/taylanub/scheme-srfis
There has since been one bug fix, and a refactoring of the macros for
better compile times, so here's an updated patch that uses the updated
version.
>From 05254ab75f9663062ecfb0bba94d6e653a09b703 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<address@hidden>
Date: Tue, 1 Sep 2015 22:57:09 +0200
Subject: [PATCH] Switch to modernized SRFI-64 implementation.
* module/srfi/srfi-64.scm: Add imports and other boilerplate for new
implementation.
* module/srfi/srfi-64/execution.body.scm: New file.
* module/srfi/srfi-64/source-info.body.scm: New file.
* module/srfi/srfi-64/test-runner-simple.body.scm: New file.
* module/srfi/srfi-64/test-runner.body.scm: New file.
* module/srfi/srfi-64/testing.scm: Deleted.
* module/Makefile.am (srfi-64.go, NOCOMP_SOURCES): Change accordingly.
---
module/Makefile.am | 11 +-
module/srfi/srfi-64.scm | 12 +-
module/srfi/srfi-64/execution.body.scm | 378 ++++++++
module/srfi/srfi-64/source-info.body.scm | 59 ++
module/srfi/srfi-64/test-runner-simple.body.scm | 141 +++
module/srfi/srfi-64/test-runner.body.scm | 156 ++++
module/srfi/srfi-64/testing.scm | 1040 -----------------------
7 files changed, 754 insertions(+), 1043 deletions(-)
create mode 100644 module/srfi/srfi-64/execution.body.scm
create mode 100644 module/srfi/srfi-64/source-info.body.scm
create mode 100644 module/srfi/srfi-64/test-runner-simple.body.scm
create mode 100644 module/srfi/srfi-64/test-runner.body.scm
delete mode 100644 module/srfi/srfi-64/testing.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 13e5000..d52cb4f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -258,7 +258,11 @@ ICE_9_SOURCES = \
ice-9/local-eval.scm \
ice-9/unicode.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+srfi/srfi-64.go: srfi/srfi-64.scm \
+ srfi/srfi-64/execution.body.scm \
+ srfi/srfi-64/source-info.body.scm \
+ srfi/srfi-64/test-runner-simple.body.scm \
+ srfi/srfi-64/test-runner.body.scm
SRFI_SOURCES = \
srfi/srfi-2.scm \
@@ -401,7 +405,10 @@ NOCOMP_SOURCES = \
ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \
srfi/srfi-42/ec.scm \
- srfi/srfi-64/testing.scm \
+ srfi/srfi-64/execution.body.scm \
+ srfi/srfi-64/source-info.body.scm \
+ srfi/srfi-64/test-runner-simple.body.scm \
+ srfi/srfi-64/test-runner.body.scm \
srfi/srfi-67/compare.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
index 81dcc5d..1dc14e0 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -52,4 +52,14 @@
(cond-expand-provide (current-module) '(srfi-64))
-(include-from-path "srfi/srfi-64/testing.scm")
+(import
+ (only (rnrs exceptions) guard)
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-11)
+ (srfi srfi-35))
+
+(include-from-path "srfi/srfi-64/source-info.body.scm")
+(include-from-path "srfi/srfi-64/test-runner.body.scm")
+(include-from-path "srfi/srfi-64/test-runner-simple.body.scm")
+(include-from-path "srfi/srfi-64/execution.body.scm")
diff --git a/module/srfi/srfi-64/execution.body.scm
b/module/srfi/srfi-64/execution.body.scm
new file mode 100644
index 0000000..e1f90f7
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,378 @@
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+
+;;; Grouping
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (when (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((r (test-runner-current)))
+ (let ((skip-list (%test-runner-skip-list r))
+ (skip-save (%test-runner-skip-save r))
+ (fail-list (%test-runner-fail-list r))
+ (fail-save (%test-runner-fail-save r))
+ (total-count (%test-runner-total-count r))
+ (count-list (%test-runner-count-list r))
+ (group-stack (test-runner-group-stack r)))
+ ((test-runner-on-group-begin r) r name count)
+ (%test-runner-skip-save! r (cons skip-list skip-save))
+ (%test-runner-fail-save! r (cons fail-list fail-save))
+ (%test-runner-count-list! r (cons (cons total-count count)
+ count-list))
+ (test-runner-group-stack! r (cons name group-stack)))))))
+
+(define test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((name)
+ (let* ((r (test-runner-get))
+ (groups (test-runner-group-stack r)))
+ (test-result-clear r)
+ (when (null? groups)
+ (error "test-end not in a group"))
+ (when (and name (not (equal? name (car groups))))
+ ((test-runner-on-bad-end-name r) r name (car groups)))
+ (let* ((count-list (%test-runner-count-list r))
+ (expected-count (cdar count-list))
+ (saved-count (caar count-list))
+ (group-count (- (%test-runner-total-count r) saved-count)))
+ (when (and expected-count
+ (not (= expected-count group-count)))
+ ((test-runner-on-bad-count r) r group-count expected-count))
+ ((test-runner-on-group-end r) r)
+ (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+ (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+ (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+ (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+ (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+ (%test-runner-count-list! r (cdr count-list))
+ (when (null? (test-runner-group-stack r))
+ ((test-runner-on-final r) r)))))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ <name> <body> . <body>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (when (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (lambda () (test-end name)))))))
+
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ ((_ <name> <body> <body>* ... <cleanup>)
+ (test-group <name>
+ (dynamic-wind (lambda () #f)
+ (lambda () <body> <body>* ...)
+ (lambda () <cleanup>))))))
+
+
+;;; Skipping, expected-failing, matching
+
+(define (test-skip . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-skip-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-skip-list runner)))))
+
+(define (test-skip? runner)
+ (let ((run-list (%test-runner-run-list runner))
+ (skip-list (%test-runner-skip-list runner)))
+ (or (and run-list (not (any-pred run-list runner)))
+ (any-pred skip-list runner))))
+
+(define (test-expect-fail . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-fail-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-fail-list runner)))))
+
+(define (test-match-any . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (any-pred preds runner))))
+
+(define (test-match-all . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (every-pred preds runner))))
+
+(define (make-pred spec)
+ (cond
+ ((procedure? spec)
+ spec)
+ ((integer? spec)
+ (test-match-nth 1 spec))
+ ((string? spec)
+ (test-match-name spec))
+ (else
+ (error "not a valid test specifier" spec))))
+
+(define test-match-nth
+ (case-lambda
+ ((n) (test-match-nth n 1))
+ ((n count)
+ (let ((i 0))
+ (lambda (runner)
+ (set! i (+ i 1))
+ (and (>= i n) (< i (+ n count))))))))
+
+(define (test-match-name name)
+ (lambda (runner)
+ (equal? name (test-runner-test-name runner))))
+
+;;; Beware: all predicates must be called because they might have side-effects;
+;;; no early returning or and/or short-circuiting of procedure calls allowed.
+
+(define (any-pred preds object)
+ (let loop ((matched? #f)
+ (preds preds))
+ (if (null? preds)
+ matched?
+ (let ((result ((car preds) object)))
+ (loop (or matched? result)
+ (cdr preds))))))
+
+(define (every-pred preds object)
+ (let loop ((failed? #f)
+ (preds preds))
+ (if (null? preds)
+ (not failed?)
+ (let ((result ((car preds) object)))
+ (loop (or failed? (not result))
+ (cdr preds))))))
+
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (let ((skip? (test-skip? runner)))
+ (if skip?
+ (test-result-set! runner 'result-kind 'skip)
+ (let ((fail-list (%test-runner-fail-list runner)))
+ (when (any-pred fail-list runner)
+ ;; For later inspection only.
+ (test-result-set! runner 'result-kind 'xfail))))
+ ((test-runner-on-test-begin runner) runner)
+ (not skip?)))
+
+(define (test-postlude runner)
+ (let ((result-kind (test-result-kind runner)))
+ (case result-kind
+ ((pass)
+ (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner))))
+ ((fail)
+ (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner))))
+ ((xpass)
+ (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count
runner))))
+ ((xfail)
+ (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count
runner))))
+ ((skip)
+ (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner)))))
+ (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner)))
+ ((test-runner-on-test-end runner) runner)))
+
+(define (set-result-kind! runner pass?)
+ (test-result-set! runner 'result-kind
+ (if (eq? (test-result-kind runner) 'xfail)
+ (if pass? 'xpass 'xfail)
+ (if pass? 'pass 'fail))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ <expr>)
+ (test-assert #f <expr>))
+ ((_ <name> <expr>)
+ (%test-assert (source-info) <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) runner)))
+ (test-result-set! runner 'actual-value val)
+ (set-result-kind! runner val)))
+ (test-postlude runner)))
+
+(define-syntax test-compare
+ (syntax-rules ()
+ ((_ <compare> <expected> <expr>)
+ (test-compare <compare> #f <expected> <expr>))
+ ((_ <compare> <name> <expected> <expr>)
+ (%test-compare
+ (source-info) <compare> <name> <expected> '<expr> (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (test-result-set! runner 'actual-value val)
+ (compare expected val))
+ runner)))
+ (set-result-kind! runner pass?)))
+ (test-postlude runner)))
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare equal? . <rest>))))
+
+(define-syntax test-eqv
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare eqv? . <rest>))))
+
+(define-syntax test-eq
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare eq? . <rest>))))
+
+(define (approx= margin)
+ (lambda (value expected)
+ (let ((rval (real-part value))
+ (ival (imag-part value))
+ (rexp (real-part expected))
+ (iexp (imag-part expected)))
+ (and (>= rval (- rexp margin))
+ (>= ival (- iexp margin))
+ (<= rval (+ rexp margin))
+ (<= ival (+ iexp margin))))))
+
+(define-syntax test-approximate
+ (syntax-rules ()
+ ((_ <expected> <expr> <error-margin>)
+ (test-approximate #f <expected> <expr> <error-margin>))
+ ((_ <name> <expected> <expr> <error-margin>)
+ (test-compare (approx= <error-margin>) <name> <expected> <expr>))))
+
+(define (error-matches? error type)
+ (cond
+ ((eq? type #t)
+ #t)
+ ((condition-type? type)
+ (and (condition? error) (condition-has-type? error type)))
+ ((procedure? type)
+ (type error))
+ (else
+ (format #t "WARNING: unknown error type predicate: ~a~%" type)
+ (format #t " error was: ~a~%" error)
+ #f)))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ <expr>)
+ (test-error #f #t <expr>))
+ ((_ <error-type> <expr>)
+ (test-error #f <error-type> <expr>))
+ ((_ <name> <error-type> <expr>)
+ (%test-error
+ (source-info) <name> <error-type> '<expr> (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-error error-type)
+ (let ((pass? (guard (error (else (test-result-set!
+ runner 'actual-error error)
+ (error-matches? error error-type)))
+ (let ((val (thunk)))
+ (test-result-set! runner 'actual-value val))
+ #f)))
+ (set-result-kind! runner pass?)))
+ (test-postlude runner)))
+
+(define test-read-eval-string
+ (case-lambda
+ ((string)
+ (test-read-eval-string string (cond-expand
+ (guile (current-module))
+ (else #f))))
+ ((string env)
+ (let* ((port (open-input-string string))
+ (form (read port)))
+ (if (eof-object? (read-char port))
+ (if env
+ (eval form env)
+ (eval form))
+ (error "(not at eof)"))))))
+
+
+;;; Test runner control flow
+
+(define-syntax test-with-runner
+ (syntax-rules ()
+ ((_ <runner> <body> . <body>*)
+ (let ((saved-runner (test-runner-current)))
+ (dynamic-wind
+ (lambda () (test-runner-current <runner>))
+ (lambda () <body> . <body>*)
+ (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+ (let ((runner (if (test-runner? first)
+ first
+ (or (test-runner-current) (test-runner-create))))
+ (run-list (if (test-runner? first)
+ (drop-right rest 1)
+ (cons first (drop-right rest 1))))
+ (proc (last rest)))
+ (test-with-runner runner
+ (let ((saved-run-list (%test-runner-run-list runner)))
+ (%test-runner-run-list! runner run-list)
+ (proc)
+ (%test-runner-run-list! runner saved-run-list)))))
+
+;;; execution.scm ends here
diff --git a/module/srfi/srfi-64/source-info.body.scm
b/module/srfi/srfi-64/source-info.body.scm
new file mode 100644
index 0000000..c1c6f97
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,59 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <address@hidden>
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-syntax source-info
+ (cond-expand
+ ((or kawa guile-2)
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_)
+ (let ((file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line))))))))
+ (else
+ (syntax-rules ()
+ ((_)
+ #f)))))
+
+(define (syntax-source-file stx)
+ (cond-expand
+ (kawa
+ (syntax-source stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'filename))))))
+
+(define (syntax-source-line stx)
+ (cond-expand
+ (kawa
+ (syntax-line stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'line))))))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; source-info.body.scm ends here
diff --git a/module/srfi/srfi-64/test-runner-simple.body.scm
b/module/srfi/srfi-64/test-runner-simple.body.scm
new file mode 100644
index 0000000..f55bf5c
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,141 @@
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; Helpers
+
+(define (string-join strings delimiter)
+ (if (null? strings)
+ ""
+ (let loop ((result (car strings))
+ (rest (cdr strings)))
+ (if (null? rest)
+ result
+ (loop (string-append result delimiter (car rest))
+ (cdr rest))))))
+
+(define (truncate-string string length)
+ (let* ((fill "...")
+ (fill-len (string-length fill))
+ (string-len (string-length string)))
+ (if (<= string-len (+ length 3))
+ string
+ (let-values (((q r) (floor/ length 4)))
+ ;; Left part gets 3/4 plus the remainder.
+ (let ((left-end (+ (* q 3) r))
+ (right-start (- string-len q)))
+ (string-append (substring string 0 left-end)
+ fill
+ (substring string right-start string-len)))))))
+
+;;; Main
+
+(define (test-runner-simple)
+ (let ((runner (test-runner-null)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-on-group-begin-simple)
+ (test-runner-on-group-end! runner test-on-group-end-simple)
+ (test-runner-on-final! runner test-on-final-simple)
+ (test-runner-on-test-begin! runner test-on-test-begin-simple)
+ (test-runner-on-test-end! runner test-on-test-end-simple)
+ (test-runner-on-bad-count! runner test-on-bad-count-simple)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ runner))
+
+(when (not (test-runner-factory))
+ (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+ (if (null? (test-runner-group-stack runner))
+ (format #t "Test suite begin: ~a~%" name)
+ (format #t "Group begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+ (let ((name (car (test-runner-group-stack runner))))
+ (if (= 1 (length (test-runner-group-stack runner)))
+ (format #t "Test suite end: ~a~%" name)
+ (format #t "Group end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (format #t "Passes: ~a\n" (test-runner-pass-count runner))
+ (format #t "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (format #t "Failures: ~a\n" (test-runner-fail-count runner))
+ (format #t "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (format #t "Skipped tests: ~a~%" (test-runner-skip-count runner)))
+
+(define (test-on-test-begin-simple runner)
+ (values))
+
+(define (test-on-test-end-simple runner)
+ (let* ((result-kind (test-result-kind runner))
+ (result-kind-name (case result-kind
+ ((pass) "PASS") ((fail) "FAIL")
+ ((xpass) "XPASS") ((xfail) "XFAIL")
+ ((skip) "SKIP")))
+ (name (let ((name (test-runner-test-name runner)))
+ (if (string=? "" name)
+ (truncate-string
+ (format #f "~a" (test-result-ref runner 'source-form))
+ 30)
+ name)))
+ (label (string-join (append (test-runner-group-path runner)
+ (list name))
+ "/")))
+ (format #t "[~a] ~a~%" result-kind-name label)
+ (when (memq result-kind '(fail xpass))
+ (let ((nil (cons #f #f)))
+ (define (found? value)
+ (not (eq? nil value)))
+ (define (maybe-print value message)
+ (when (found? value)
+ (format #t message value)))
+ (let ((file (test-result-ref runner 'source-file))
+ (line (test-result-ref runner 'source-line))
+ (expression (test-result-ref runner 'source-form))
+ (expected-value (test-result-ref runner 'expected-value nil))
+ (actual-value (test-result-ref runner 'actual-value nil))
+ (expected-error (test-result-ref runner 'expected-error nil))
+ (actual-error (test-result-ref runner 'actual-error nil)))
+ (newline)
+ (when line
+ (format #t "Source:\n~a:~a\n~%" (or file "(unknown file)") line))
+ (format #t "Expression:\n~a\n~%" expression)
+ (maybe-print expected-value "Expected value:\n~a\n~%")
+ (maybe-print expected-error "Expected error:\n~a\n~%")
+ (when (or (found? expected-value) (found? expected-error))
+ (maybe-print actual-value "Got value:\n~a\n~%"))
+ (maybe-print actual-error "Got error:\n~a\n~%"))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (format #t "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (format #t "*** Discrepancy indicates testsuite error or exceptions. ***~%"))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"."
+ end-name begin-name)))
+
+;;; test-runner-simple.scm ends here
diff --git a/module/srfi/srfi-64/test-runner.body.scm
b/module/srfi/srfi-64/test-runner.body.scm
new file mode 100644
index 0000000..be0c5a3
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,156 @@
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+
+;;; The data type
+
+(define-record-type <test-runner>
+ (make-test-runner) test-runner?
+
+ (result-alist test-result-alist test-result-alist!)
+
+ (pass-count test-runner-pass-count test-runner-pass-count!)
+ (fail-count test-runner-fail-count test-runner-fail-count!)
+ (xpass-count test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count test-runner-skip-count test-runner-skip-count!)
+ (total-count %test-runner-total-count %test-runner-total-count!)
+
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list %test-runner-count-list %test-runner-count-list!)
+
+ ;; Normally #f, except when in a test-apply.
+ (run-list %test-runner-run-list %test-runner-run-list!)
+
+ (skip-list %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list %test-runner-fail-list %test-runner-fail-list!)
+
+ (skip-save %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save %test-runner-fail-save %test-runner-fail-save!)
+
+ (group-stack test-runner-group-stack test-runner-group-stack!)
+
+ ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and
+ ;; test-end forms in the execution library. They're called at the
+ ;; beginning/end of each individual test, whereas the test-begin and test-end
+ ;; forms demarcate test groups.
+
+ (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+ (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end test-runner-on-test-end test-runner-on-test-end!)
+ (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+ (on-final test-runner-on-final test-runner-on-final!)
+ (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!)
+ (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!))
+
+(define (test-runner-group-path runner)
+ (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-reset runner)
+ (test-result-alist! runner '())
+ (test-runner-pass-count! runner 0)
+ (test-runner-fail-count! runner 0)
+ (test-runner-xpass-count! runner 0)
+ (test-runner-xfail-count! runner 0)
+ (test-runner-skip-count! runner 0)
+ (%test-runner-total-count! runner 0)
+ (%test-runner-count-list! runner '())
+ (%test-runner-run-list! runner #f)
+ (%test-runner-skip-list! runner '())
+ (%test-runner-fail-list! runner '())
+ (%test-runner-skip-save! runner '())
+ (%test-runner-fail-save! runner '())
+ (test-runner-group-stack! runner '()))
+
+(define (test-runner-null)
+ (define (test-null-callback . args) #f)
+ (let ((runner (make-test-runner)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-null-callback)
+ (test-runner-on-group-end! runner test-null-callback)
+ (test-runner-on-final! runner test-null-callback)
+ (test-runner-on-test-begin! runner test-null-callback)
+ (test-runner-on-test-end! runner test-null-callback)
+ (test-runner-on-bad-count! runner test-null-callback)
+ (test-runner-on-bad-end-name! runner test-null-callback)
+ runner))
+
+
+;;; State
+
+(define test-result-ref
+ (case-lambda
+ ((runner key)
+ (test-result-ref runner key #f))
+ ((runner key default)
+ (let ((entry (assq key (test-result-alist runner))))
+ (if entry (cdr entry) default)))))
+
+(define (test-result-set! runner key value)
+ (let* ((alist (test-result-alist runner))
+ (entry (assq key alist)))
+ (if entry
+ (set-cdr! entry value)
+ (test-result-alist! runner (cons (cons key value) alist)))))
+
+(define (test-result-remove runner key)
+ (test-result-alist! runner (remove (lambda (entry)
+ (eq? key (car entry)))
+ (test-result-alist runner))))
+
+(define (test-result-clear runner)
+ (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+ (or (test-result-ref runner 'name) ""))
+
+(define test-result-kind
+ (case-lambda
+ (() (test-result-kind (test-runner-get)))
+ ((runner) (test-result-ref runner 'result-kind))))
+
+(define test-passed?
+ (case-lambda
+ (() (test-passed? (test-runner-get)))
+ ((runner) (memq (test-result-kind runner) '(pass xpass)))))
+
+
+;;; Factory and current instance
+
+(define test-runner-factory (make-parameter #f))
+
+(define (test-runner-create) ((test-runner-factory)))
+
+(define test-runner-current (make-parameter #f))
+
+(define (test-runner-get)
+ (or (test-runner-current)
+ (error "test-runner not initialized - test-begin missing?")))
+
+;;; test-runner.scm ends here
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
deleted file mode 100644
index d686662..0000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1040 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;; Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <address@hidden>, Copyright (c) 2014.
-;;
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-;;
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-;;
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-(cond-expand
- (chicken
- (require-extension syntax-case))
- (guile-2
- (use-modules (srfi srfi-9)
- ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
- ;; with either Guile's native exceptions or R6RS exceptions.
- ;;(srfi srfi-34) (srfi srfi-35)
- (srfi srfi-39)))
- (guile
- (use-modules (ice-9 syncase) (srfi srfi-9)
- ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
- (srfi srfi-39)))
- (sisc
- (require-extension (srfi 9 34 35 39)))
- (kawa
- (module-compile-options warn-undefined-variable: #t
- warn-invoke-unknown-method: #t)
- (provide 'srfi-64)
- (provide 'testing)
- (require 'srfi-34)
- (require 'srfi-35))
- (else ()
- ))
-
-(cond-expand
- (kawa
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export test-begin . other-names)
- (module-export %test-begin . other-names)))))
- (else
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index setter getter) ...)
- (define-record-type test-runner
- (alloc)
- runner?
- (name setter getter) ...)))))
- (else
- (define %test-runner-cookie (list "test-runner"))
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index getter setter) ...)
- (begin
- (define (runner? obj)
- (and (vector? obj)
- (> (vector-length obj) 1)
- (eq (vector-ref obj 0) %test-runner-cookie)))
- (define (alloc)
- (let ((runner (make-vector 23)))
- (vector-set! runner 0 %test-runner-cookie)
- runner))
- (begin
- (define (getter runner)
- (vector-ref runner index)) ...)
- (begin
- (define (setter runner value)
- (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
- (test-result-alist! runner '())
- (test-runner-pass-count! runner 0)
- (test-runner-fail-count! runner 0)
- (test-runner-xpass-count! runner 0)
- (test-runner-xfail-count! runner 0)
- (test-runner-skip-count! runner 0)
- (%test-runner-total-count! runner 0)
- (%test-runner-count-list! runner '())
- (%test-runner-run-list! runner #t)
- (%test-runner-skip-list! runner '())
- (%test-runner-fail-list! runner '())
- (%test-runner-skip-save! runner '())
- (%test-runner-fail-save! runner '())
- (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
- (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner (lambda (runner name count) #f))
- (test-runner-on-group-end! runner %test-null-callback)
- (test-runner-on-final! runner %test-null-callback)
- (test-runner-on-test-begin! runner %test-null-callback)
- (test-runner-on-test-end! runner %test-null-callback)
- (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
- (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
- runner))
-
-;; Not part of the specification. FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner test-on-group-begin-simple)
- (test-runner-on-group-end! runner test-on-group-end-simple)
- (test-runner-on-final! runner test-on-final-simple)
- (test-runner-on-test-begin! runner test-on-test-begin-simple)
- (test-runner-on-test-end! runner test-on-test-end-simple)
- (test-runner-on-bad-count! runner test-on-bad-count-simple)
- (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
- runner))
-
-(cond-expand
- (srfi-39
- (define test-runner-current (make-parameter #f))
- (define test-runner-factory (make-parameter test-runner-simple)))
- (else
- (define %test-runner-current #f)
- (define-syntax test-runner-current
- (syntax-rules ()
- ((test-runner-current)
- %test-runner-current)
- ((test-runner-current runner)
- (set! %test-runner-current runner))))
- (define %test-runner-factory test-runner-simple)
- (define-syntax test-runner-factory
- (syntax-rules ()
- ((test-runner-factory)
- %test-runner-factory)
- ((test-runner-factory runner)
- (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
- (let ((r (test-runner-current)))
- (if (not r)
- (cond-expand
- (srfi-23 (error "test-runner not initialized - test-begin missing?"))
- (else #t)))
- r))
-
-(define (%test-specifier-matches spec runner)
- (spec runner))
-
-(define (test-runner-create)
- ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
- (let ((result #f))
- (let loop ((l list))
- (cond ((null? l) result)
- (else
- (if (%test-specifier-matches (car l) runner)
- (set! result #t))
- (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
- (let ((run (%test-runner-run-list runner)))
- (cond ((or
- (not (or (eqv? run #t)
- (%test-any-specifier-matches run runner)))
- (%test-any-specifier-matches
- (%test-runner-skip-list runner)
- runner))
- (test-result-set! runner 'result-kind 'skip)
- #f)
- ((%test-any-specifier-matches
- (%test-runner-fail-list runner)
- runner)
- (test-result-set! runner 'result-kind 'xfail)
- 'xfail)
- (else #t))))
-
-(define (%test-begin suite-name count)
- (if (not (test-runner-current))
- (test-runner-current (test-runner-create)))
- (let ((runner (test-runner-current)))
- ((test-runner-on-group-begin runner) runner suite-name count)
- (%test-runner-skip-save! runner
- (cons (%test-runner-skip-list runner)
- (%test-runner-skip-save runner)))
- (%test-runner-fail-save! runner
- (cons (%test-runner-fail-list runner)
- (%test-runner-fail-save runner)))
- (%test-runner-count-list! runner
- (cons (cons (%test-runner-total-count runner)
- count)
- (%test-runner-count-list runner)))
- (test-runner-group-stack! runner (cons suite-name
- (test-runner-group-stack runner)))))
-(cond-expand
- (kawa
- ;; Kawa has test-begin built in, implemented as:
- ;; (begin
- ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
- ;; (%test-begin suite-name [count]))
- ;; This puts test-begin but only test-begin in the default environment.,
- ;; which makes normal test suites loadable without non-portable commands.
- )
- (else
- (define-syntax test-begin
- (syntax-rules ()
- ((test-begin suite-name)
- (%test-begin suite-name #f))
- ((test-begin suite-name count)
- (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
- (if (null? (test-runner-group-stack runner))
- (begin
- (display "%%%% Starting test ")
- (display suite-name)
- (if test-log-to-file
- (let* ((log-file-name
- (if (string? test-log-to-file) test-log-to-file
- (string-append suite-name ".log")))
- (log-file
- (cond-expand (mzscheme
- (open-output-file log-file-name
'truncate/replace))
- (else (open-output-file log-file-name)))))
- (display "%%%% Starting test " log-file)
- (display suite-name log-file)
- (newline log-file)
- (test-runner-aux-value! runner log-file)
- (display " (Writing full log to \"")
- (display log-file-name)
- (display "\")")))
- (newline)))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group begin: " log)
- (display suite-name log)
- (newline log))))
- #f)
-
-(define (test-on-group-end-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group end: " log)
- (display (car (test-runner-group-stack runner)) log)
- (newline log))))
- #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
- (display "*** Total number of tests was " port)
- (display count port)
- (display " but should be " port)
- (display expected-count port)
- (display ". ***" port)
- (newline port)
- (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
- (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
- (%test-on-bad-count-write runner count expected-count (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
- (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
- " does not match test-begin " end-name)))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
-
-
-(define (%test-final-report1 value label port)
- (if (> value 0)
- (begin
- (display label port)
- (display value port)
- (newline port))))
-
-(define (%test-final-report-simple runner port)
- (%test-final-report1 (test-runner-pass-count runner)
- "# of expected passes " port)
- (%test-final-report1 (test-runner-xfail-count runner)
- "# of expected failures " port)
- (%test-final-report1 (test-runner-xpass-count runner)
- "# of unexpected successes " port)
- (%test-final-report1 (test-runner-fail-count runner)
- "# of unexpected failures " port)
- (%test-final-report1 (test-runner-skip-count runner)
- "# of skipped tests " port))
-
-(define (test-on-final-simple runner)
- (%test-final-report-simple runner (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
- (let* ((line-info (test-result-alist runner))
- (source-file (assq 'source-file line-info))
- (source-line (assq 'source-line line-info))
- (file (if source-file (cdr source-file) "")))
- (if source-line
- (string-append file ":"
- (number->string (cdr source-line)) ": ")
- "")))
-
-(define (%test-end suite-name line-info)
- (let* ((r (test-runner-get))
- (groups (test-runner-group-stack r))
- (line (%test-format-line r)))
- (test-result-alist! r line-info)
- (if (null? groups)
- (let ((msg (string-append line "test-end not in a group")))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
- (if (and suite-name (not (equal? suite-name (car groups))))
- ((test-runner-on-bad-end-name r) r suite-name (car groups)))
- (let* ((count-list (%test-runner-count-list r))
- (expected-count (cdar count-list))
- (saved-count (caar count-list))
- (group-count (- (%test-runner-total-count r) saved-count)))
- (if (and expected-count
- (not (= expected-count group-count)))
- ((test-runner-on-bad-count r) r group-count expected-count))
- ((test-runner-on-group-end r) r)
- (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
- (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
- (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
- (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
- (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
- (%test-runner-count-list! r (cdr count-list))
- (if (null? (test-runner-group-stack r))
- ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
- (syntax-rules ()
- ((test-group suite-name . body)
- (let ((r (test-runner-current)))
- ;; Ideally should also set line-number, if available.
- (test-result-alist! r (list (cons 'test-name suite-name)))
- (if (%test-should-execute r)
- (dynamic-wind
- (lambda () (test-begin suite-name))
- (lambda () . body)
- (lambda () (test-end suite-name))))))))
-
-(define-syntax test-group-with-cleanup
- (syntax-rules ()
- ((test-group-with-cleanup suite-name form cleanup-form)
- (test-group suite-name
- (dynamic-wind
- (lambda () #f)
- (lambda () form)
- (lambda () cleanup-form))))
- ((test-group-with-cleanup suite-name cleanup-form)
- (test-group-with-cleanup suite-name #f cleanup-form))
- ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
- (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (source-form (assq 'source-form results))
- (test-name (assq 'test-name results)))
- (display "Test begin:" log)
- (newline log)
- (if test-name (%test-write-result1 test-name log))
- (if source-file (%test-write-result1 source-file log))
- (if source-line (%test-write-result1 source-line log))
- (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
- (syntax-rules ()
- ((test-result-ref runner pname)
- (test-result-ref runner pname #f))
- ((test-result-ref runner pname default)
- (let ((p (assq pname (test-result-alist runner))))
- (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
- (let ((log (test-runner-aux-value runner))
- (kind (test-result-ref runner 'result-kind)))
- (if (memq kind '(fail xpass))
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (test-name (assq 'test-name results)))
- (if (or source-file source-line)
- (begin
- (if source-file (display (cdr source-file)))
- (display ":")
- (if source-line (display (cdr source-line)))
- (display ": ")))
- (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
- (if test-name
- (begin
- (display " ")
- (display (cdr test-name))))
- (newline)))
- (if (output-port? log)
- (begin
- (display "Test end:" log)
- (newline log)
- (let loop ((list (test-result-alist runner)))
- (if (pair? list)
- (let ((pair (car list)))
- ;; Write out properties not written out by on-test-begin.
- (if (not (memq (car pair)
- '(test-name source-file source-line
source-form)))
- (%test-write-result1 pair log))
- (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
- (display " " port)
- (display (car pair) port)
- (display ": " port)
- (write (cdr pair) port)
- (newline port))
-
-(define (test-result-set! runner pname value)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (set-cdr! p value)
- (test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
- (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (test-result-alist! runner
- (let loop ((r alist))
- (if (eq? r p) (cdr r)
- (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
- (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
- (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
- (let* ((r (test-runner-get))
- (result-kind (test-result-kind r)))
- (case result-kind
- ((pass)
- (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
- ((fail)
- (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
- ((xpass)
- (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
- ((xfail)
- (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
- (else
- (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
- (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
- ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (catch #t
- (lambda () test-expression)
- (lambda (key . args)
- (test-result-set! (test-runner-current) 'actual-error
- (cons key args))
- #f))))))
- (kawa
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (try-catch test-expression
- (ex <java.lang.Throwable>
- (test-result-set! (test-runner-current) 'actual-error ex)
- #f))))))
- (srfi-34
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (guard (err (else #f)) test-expression)))))
- (chicken
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (condition-case test-expression (ex () #f))))))
- (else
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- test-expression)))))
-
-(cond-expand
- ((or kawa mzscheme)
- (cond-expand
- (mzscheme
- (define-for-syntax (%test-syntax-file form)
- (let ((source (syntax-source form)))
- (cond ((string? source) file)
- ((path? source) (path->string source))
- (else #f)))))
- (kawa
- (define (%test-syntax-file form)
- (syntax-source form))))
- (define (%test-source-line2 form)
- (let* ((line (syntax-line form))
- (file (%test-syntax-file form))
- (line-pair (if line (list (cons 'source-line line)) '())))
- (cons (cons 'source-form (syntax-object->datum form))
- (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
- (define (%test-source-line2 form)
- (let* ((src-props (syntax-source form))
- (file (and src-props (assq-ref src-props 'filename)))
- (line (and src-props (assq-ref src-props 'line)))
- (file-alist (if file
- `((source-file . ,file))
- '()))
- (line-alist (if line
- `((source-line . ,(+ line 1)))
- '())))
- (datum->syntax (syntax here)
- `((source-form . ,(syntax->datum form))
- ,@file-alist
- ,@line-alist)))))
- (else
- (define (%test-source-line2 form)
- '())))
-
-(define (%test-on-test-begin r)
- (%test-should-execute r)
- ((test-runner-on-test-begin r) r)
- (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
- (test-result-set! r 'result-kind
- (if (eq? (test-result-ref r 'result-kind) 'xfail)
- (if result 'xpass 'xfail)
- (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
- (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
- (syntax-rules ()
- ((%test-comp2body r comp expected expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ((exp expected))
- (test-result-set! r 'expected-value exp)
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r (comp exp res)))))
- (%test-report-result)))))
-
-(define (%test-approximate= error)
- (lambda (value expected)
- (let ((rval (real-part value))
- (ival (imag-part value))
- (rexp (real-part expected))
- (iexp (imag-part expected)))
- (and (>= rval (- rexp error))
- (>= ival (- iexp error))
- (<= rval (+ rexp error))
- (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
- (syntax-rules ()
- ((%test-comp1body r expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ()
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r res))))
- (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
- ;; Should be made to work for any Scheme with syntax-case
- ;; However, I haven't gotten the quoting working. FIXME.
- (define-syntax test-end
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac suite-name) line)
- (syntax
- (%test-end suite-name line)))
- (((mac) line)
- (syntax
- (%test-end #f line))))))
- (define-syntax test-assert
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp1body r expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp1body r expr)))))))
- (define (%test-comp2 comp x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
- (((mac tname expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r comp expected expr))))
- (((mac expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r comp expected expr))))))
- (define-syntax test-eqv
- (lambda (x) (%test-comp2 (syntax eqv?) x)))
- (define-syntax test-eq
- (lambda (x) (%test-comp2 (syntax eq?) x)))
- (define-syntax test-equal
- (lambda (x) (%test-comp2 (syntax equal?) x)))
- (define-syntax test-approximate ;; FIXME - needed for non-Kawa
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expected expr error) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r (%test-approximate= error) expected expr))))
- (((mac expected expr error) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
- (define-syntax test-end
- (syntax-rules ()
- ((test-end)
- (%test-end #f '()))
- ((test-end suite-name)
- (%test-end suite-name '()))))
- (define-syntax test-assert
- (syntax-rules ()
- ((test-assert tname test-expression)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r '((test-name . tname)))
- (%test-comp1body r test-expression)))
- ((test-assert test-expression)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp1body r test-expression)))))
- (define-syntax %test-comp2
- (syntax-rules ()
- ((%test-comp2 comp tname expected expr)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (list (cons 'test-name tname)))
- (%test-comp2body r comp expected expr)))
- ((%test-comp2 comp expected expr)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp2body r comp expected expr)))))
- (define-syntax test-equal
- (syntax-rules ()
- ((test-equal . rest)
- (%test-comp2 equal? . rest))))
- (define-syntax test-eqv
- (syntax-rules ()
- ((test-eqv . rest)
- (%test-comp2 eqv? . rest))))
- (define-syntax test-eq
- (syntax-rules ()
- ((test-eq . rest)
- (%test-comp2 eq? . rest))))
- (define-syntax test-approximate
- (syntax-rules ()
- ((test-approximate tname expected expr error)
- (%test-comp2 (%test-approximate= error) tname expected expr))
- ((test-approximate expected expr error)
- (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (cond ((%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (catch #t
- (lambda ()
- (test-result-set! r 'actual-value expr)
- #f)
- (lambda (key . args)
- ;; TODO: decide how to specify expected
- ;; error types for Guile.
- (test-result-set! r 'actual-error
- (cons key args))
- #t)))
- (%test-report-result))))))))
- (mzscheme
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
- (let ()
- (test-result-set! r 'actual-value
expr)
- #f)))))))
- (chicken
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r #t expr)
- (cond ((%test-on-test-begin r)
- (test-result-set! r 'expected-error #t)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- #t)))
- (%test-report-result))))
- ((%test-error r etype expr)
- (if (%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- (cond ((and (instance? et
<gnu.bytecode.ClassType>)
-
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
- (instance? ex et))
- (else #t)))))
- (%test-report-result)))))))
- ((and srfi-34 srfi-35)
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex ((condition-type? etype)
- (and (condition? ex) (condition-has-type? ex etype)))
- ((procedure? etype)
- (etype ex))
- ((equal? etype #t)
- #t)
- (else #t))
- expr #f))))))
- (srfi-34
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (begin
- ((test-runner-on-test-begin r) r)
- (test-result-set! r 'result-kind 'skip)
- (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
- (define-syntax test-error
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname etype expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-error r etype expr))))
- (((mac etype expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r etype expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r #t expr))))))))
- (else
- (define-syntax test-error
- (syntax-rules ()
- ((test-error name etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r `((test-name . ,name)))
- (%test-error r etype expr)))
- ((test-error etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r etype expr)))
- ((test-error expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
- (if (test-runner? first)
- (test-with-runner first (apply test-apply rest))
- (let ((r (test-runner-current)))
- (if r
- (let ((run-list (%test-runner-run-list r)))
- (cond ((null? rest)
- (%test-runner-run-list! r (reverse run-list))
- (first)) ;; actually apply procedure thunk
- (else
- (%test-runner-run-list!
- r
- (if (eq? run-list #t) (list first) (cons first run-list)))
- (apply test-apply rest)
- (%test-runner-run-list! r run-list))))
- (let ((r (test-runner-create)))
- (test-with-runner r (apply test-apply first rest))
- ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
- (syntax-rules ()
- ((test-with-runner runner form ...)
- (let ((saved-runner (test-runner-current)))
- (dynamic-wind
- (lambda () (test-runner-current runner))
- (lambda () form ...)
- (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
- (let ((i 0))
- (lambda (runner)
- (set! i (+ i 1))
- (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
- (syntax-rules ()
- ((test-match-nth n)
- (test-match-nth n 1))
- ((test-match-nth n count)
- (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
- (lambda (runner)
- (let ((result #t))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if (not ((car l) runner))
- (set! result #f))
- (loop (cdr l))))))))
-
-(define-syntax test-match-all
- (syntax-rules ()
- ((test-match-all pred ...)
- (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
- (lambda (runner)
- (let ((result #f))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if ((car l) runner)
- (set! result #t))
- (loop (cdr l))))))))
-
-(define-syntax test-match-any
- (syntax-rules ()
- ((test-match-any pred ...)
- (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
- (cond ((procedure? specifier) specifier)
- ((integer? specifier) (test-match-nth 1 specifier))
- ((string? specifier) (test-match-name specifier))
- (else
- (error "not a valid test specifier"))))
-
-(define-syntax test-skip
- (syntax-rules ()
- ((test-skip pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-skip-list! runner
- (cons (test-match-all (%test-as-specifier
pred) ...)
- (%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
- (syntax-rules ()
- ((test-expect-fail pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-fail-list! runner
- (cons (test-match-all (%test-as-specifier
pred) ...)
- (%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
- (lambda (runner)
- (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
- (let* ((port (open-input-string string))
- (form (read port)))
- (if (eof-object? (read-char port))
- (cond-expand
- (guile (eval form (current-module)))
- (else (eval form)))
- (cond-expand
- (srfi-23 (error "(not at eof)"))
- (else "error")))))
-
--
2.5.0