From: Taylan Kammer <taylan.kammer@gmail.com>
To: guile-devel@gnu.org
Subject: [PATCHES] Use a better SRFI-64 implementation.
Date: Mon, 10 May 2021 20:25:49 +0200 [thread overview]
Message-ID: <94ecc225-684f-1d36-bc72-53b8026753b6@gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1717 bytes --]
Hi Guile devs,
I've noticed there have been a couple bug reports about SRFI-64
recently. Guile uses the reference implementation of SRFI-64 which has
really terrible readability, doesn't conform to its own standard, and
was revealed to have a number of bugs over the years.
I've attached two patches, the first of which replaces the SRFI-64
implementation shipped with Guile to the one I wrote as part of the R7RS
Scheme SRFIs project,[0] and the second patch adds a few tests to the
SRFI-64 meta test suite.
This implementation of SRFI-64 offers the following improvements:
- Much better readability through a modular design, modernized Scheme
code, better identifier names, and otherwise prettified code
- Output about executed tests in a format familiar to GNU users
- Improved expand-time performance for large test suites
- Fully conforms to the SRFI-64 specification
- Offers a small number of extensions
See the notes about SRFI-64 in the README of the Scheme SRFIs project[0]
for the most important differences from the reference implementation,
like the way it conforms to the spec where the reference implementation
doesn't, and the extensions mentioned above.
I had already proposed such a patch a number of years ago, but it was
rejected on the grounds that the upstream implementation is probably
better tested. I think the fact that there have been grave bugs in the
implementation that remained uncovered in ~15 years evidences that this
is not a valid reason. I believe that the over-complicated way the code
is written masks bugs and discourages people from improving the code.
What do you think? IMO this would be a clear improvement.
[0] https://github.com/TaylanUB/scheme-srfis
[-- Attachment #2: 0001-Use-a-different-SRFI-64-implementation.patch --]
[-- Type: text/plain, Size: 37903 bytes --]
From fa23f90fe3e516e57e6f1ddae5517d7170c62f44 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:23:17 +0200
Subject: [PATCH 1/2] Use a different 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 | 14 +-
module/srfi/srfi-64/execution.body.scm | 426 ++++++++++++++++++
module/srfi/srfi-64/source-info.body.scm | 88 ++++
.../srfi/srfi-64/test-runner-simple.body.scm | 168 +++++++
module/srfi/srfi-64/test-runner.body.scm | 165 +++++++
6 files changed, 868 insertions(+), 4 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
diff --git a/module/Makefile.am b/module/Makefile.am
index 41b77095b..e1c5267e7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.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
$(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
# Keep this rule in sync with that in `am/guilec'.
@@ -403,7 +407,10 @@ NOCOMP_SOURCES = \
ice-9/r7rs-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 925726f5c..a8cb08874 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -24,9 +24,9 @@
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-exit
test-result-ref test-result-set! test-result-clear test-result-remove
test-result-kind test-passed?
- test-log-to-file
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
@@ -53,4 +53,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 000000000..717d74bfa
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,426 @@
+;; 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 <mhw@netris.org>, 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+\f
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+ (when (not (test-runner-current))
+ (let ((runner (test-runner-simple))
+ (log-file (string-append suite-name ".srfi64.log")))
+ (%test-runner-log-file! runner log-file)
+ (test-runner-current runner))))
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (maybe-install-default-runner name)
+ (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
+ (maybe-install-default-runner name)
+ (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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; 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))))
+
+;;; We need to use some trickery to get the source info right. The important
+;;; thing is to pass a syntax object that is a pair to `source-info', and make
+;;; sure this syntax object comes from user code and not from ourselves.
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-assert/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-assert/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-assert/source-info <source-info> #f <expr>))
+ ((_ <source-info> <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 ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-compare/source-info
+ (syntax-rules ()
+ ((_ <source-info> <compare> <expected> <expr>)
+ (test-compare/source-info <source-info> <compare> #f <expected> <expr>))
+ ((_ <source-info> <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/source-info (source-info <rest>) equal? . <rest>))))
+
+(define-syntax test-eqv
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) eqv? . <rest>))))
+
+(define-syntax test-eq
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) 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 ()
+ ((_ . <rest>)
+ (test-approximate/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-approximate/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expected> <expr> <error-margin>)
+ (test-approximate/source-info
+ <source-info> #f <expected> <expr> <error-margin>))
+ ((_ <source-info> <name> <expected> <expr> <error-margin>)
+ (test-compare/source-info
+ <source-info> (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
+ (let ((runner (test-runner-get)))
+ ((%test-runner-on-bad-error-type runner) runner type error))
+ #f)))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-error/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-error/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-error/source-info <source-info> #f #t <expr>))
+ ((_ <source-info> <error-type> <expr>)
+ (test-error/source-info <source-info> #f <error-type> <expr>))
+ ((_ <source-info> <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 (default-module)
+ (cond-expand
+ (guile (current-module))
+ (else #f)))
+
+(define test-read-eval-string
+ (case-lambda
+ ((string)
+ (test-read-eval-string string (default-module)))
+ ((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)"))))))
+
+\f
+;;; 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)))))
+
+\f
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+ (let ((runner (test-runner-current)))
+ (if (and (zero? (test-runner-xpass-count runner))
+ (zero? (test-runner-fail-count runner)))
+ (exit 0)
+ (exit 1))))
+
+;;; 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 000000000..684873587
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,88 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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.
+
+;;; In some systems, a macro use like (source-info ...), that resides in a
+;;; syntax-rules macro body, first gets inserted into the place where the
+;;; syntax-rules macro was used, and then the transformer of 'source-info' is
+;;; called with a syntax object that has the source location information of that
+;;; position. That works fine when the user calls e.g. (test-assert ...), whose
+;;; body contains (source-info ...); the user gets the source location of the
+;;; (test-assert ...) call as intended, and not the source location of the real
+;;; (source-info ...) call.
+
+;;; In other systems, *first* the (source-info ...) is processed to get its real
+;;; position, which is within the body of a syntax-rules macro like test-assert,
+;;; so no matter where the user calls (test-assert ...), they get source
+;;; location information of where we defined test-assert with the call to
+;;; (source-info ...) in its body. That's arguably more correct behavior,
+;;; although in this case it makes our job a bit harder; we need to get the
+;;; source location from an argument to 'source-info' instead.
+
+(define (canonical-syntax form arg)
+ (cond-expand
+ (kawa arg)
+ (guile-2 form)
+ (else #f)))
+
+(cond-expand
+ ((or kawa guile-2)
+ (define-syntax source-info
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <x>)
+ (let* ((stx (canonical-syntax stx (syntax <x>)))
+ (file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line)))))))))
+ (else
+ (define-syntax source-info
+ (syntax-rules ()
+ ((_ <x>)
+ #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))))
+ (else
+ #f)))
+
+(define (syntax-source-line stx)
+ (cond-expand
+ (kawa
+ (syntax-line stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'line))))
+ (else
+ #f)))
+
+(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 000000000..f7ce2e383
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,168 @@
+;; 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 <mhw@netris.org>, 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)
+ (define (newline->space c) (if (char=? #\newline c) #\space c))
+ (let* ((string (string-map newline->space string))
+ (fill "...")
+ (fill-len (string-length fill))
+ (string-len (string-length string)))
+ (if (<= string-len (+ length fill-len))
+ 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)))))))
+
+(define (print runner format-string . args)
+ (apply format #t format-string args)
+ (let ((port (%test-runner-log-port runner)))
+ (when port
+ (apply format port format-string args))))
+
+;;; 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)
+ (%test-runner-on-bad-error-type! runner on-bad-error-type)
+ runner))
+
+(when (not (test-runner-factory))
+ (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+ (when (null? (test-runner-group-stack runner))
+ (maybe-start-logging runner)
+ (print runner "Test suite begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+ (let ((name (car (test-runner-group-stack runner))))
+ (when (= 1 (length (test-runner-group-stack runner)))
+ (print runner "Test suite end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (print runner "Passes: ~a\n" (test-runner-pass-count runner))
+ (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (print runner "Failures: ~a\n" (test-runner-fail-count runner))
+ (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner))
+ (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ ;; The possible race-condition here doesn't bother us.
+ (when (file-exists? log-file)
+ (delete-file log-file))
+ (%test-runner-log-port! runner (open-output-file log-file))
+ (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ (print runner "Wrote log file: ~a~%" log-file)
+ (close-output-port (%test-runner-log-port 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))
+ ": ")))
+ (print runner "[~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)
+ (print runner message value)))
+ (let ((file (test-result-ref runner 'source-file "(unknown file)"))
+ (line (test-result-ref runner 'source-line "(unknown 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)))
+ (print runner "~a:~a: ~s~%" file line expression)
+ (maybe-print expected-value "Expected value: ~s~%")
+ (maybe-print expected-error "Expected error: ~a~%")
+ (when (or (found? expected-value) (found? expected-error))
+ (maybe-print actual-value "Returned value: ~s~%"))
+ (maybe-print actual-error "Raised error: ~a~%")
+ (newline))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (print runner
+ "*** 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)))
+
+(define (on-bad-error-type runner type error)
+ (print runner "WARNING: unknown error type predicate: ~a~%" type)
+ (print runner " error was: ~a~%" error))
+
+;;; 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 000000000..f8131ebcf
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,165 @@
+;; 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 <mhw@netris.org>, 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.
+
+\f
+;;; 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!)
+
+ (on-bad-error-type %test-runner-on-bad-error-type
+ %test-runner-on-bad-error-type!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!)
+
+ (log-file %test-runner-log-file %test-runner-log-file!)
+ (log-port %test-runner-log-port %test-runner-log-port!))
+
+(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)
+ (%test-runner-on-bad-error-type! runner test-null-callback)
+ (%test-runner-log-file! runner #f)
+ (%test-runner-log-port! runner #f)
+ runner))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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
--
2.30.2
[-- Attachment #3: 0002-Augment-SRFI-64-test-suite.patch --]
[-- Type: text/plain, Size: 1901 bytes --]
From 5f7b1e3790f3941a12326aec10f90ca55fe0e1c3 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:26:10 +0200
Subject: [PATCH 2/2] Augment SRFI-64 test-suite.
* test-suite/tests/srfi-64-test.scm ("1.3. test-approximate"): New
section.
("2.1.4. FAIL with a test name and error type"):
("2.1.5. PASS with an error type but no name"):
("2.1.6. FAIL with an error type but no name"): New tests.
---
test-suite/tests/srfi-64-test.scm | 37 +++++++++++++++++++++++++++++++
1 file changed, 37 insertions(+)
diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..b7f6d2934 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -167,6 +167,19 @@
(test-end);1.2
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-approximate "a" (mean 3 5) 4 0.001)
+ (test-approximate "b" (mean 3 5) 4.5 0.001)
+ (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
(test-end "1. Simple test-cases")
;;;
@@ -202,6 +215,30 @@
;; PASS
(test-error "a" #t (vector-ref '#(1 2) 9)))))
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; FAIL
+ (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; PASS
+ (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; FAIL
+ (test-error #t (vector-ref '#(1 2) 0)))))
+
(test-end "2.1. test-error")
(test-end "2. Tests for catching errors")
--
2.30.2
next reply other threads:[~2021-05-10 18:25 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-05-10 18:25 Taylan Kammer [this message]
2021-05-11 11:32 ` [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
2021-05-11 19:14 ` Taylan Kammer
2021-05-11 20:52 ` Taylan Kammer
2021-05-11 14:32 ` Taylan Kammer
2021-05-11 19:39 ` Taylan Kammer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=94ecc225-684f-1d36-bc72-53b8026753b6@gmail.com \
--to=taylan.kammer@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).