unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCHES] Use a better SRFI-64 implementation.
@ 2021-05-10 18:25 Taylan Kammer
  2021-05-11 11:32 ` Taylan Kammer
                   ` (2 more replies)
  0 siblings, 3 replies; 6+ messages in thread
From: Taylan Kammer @ 2021-05-10 18:25 UTC (permalink / raw)
  To: guile-devel

[-- 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


^ permalink raw reply related	[flat|nested] 6+ messages in thread
end of thread, other threads:[~2021-05-11 20:52 UTC | newest]

Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-05-10 18:25 [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
2021-05-11 11:32 ` 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

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).