summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTomas Volf <~@wolfsden.cz>2024-10-26 18:06:51 +0200
committerLudovic Courtès <ludo@gnu.org>2024-10-26 19:44:40 +0200
commit1a5e35f0eb9a9160d931b6a4a9f1764e65b7e5b8 (patch)
tree54e18080928aa7d9a56898cdcf605915934b0c31
parent242e8698c2fdfada96a136abde5156bac3dbc6c9 (diff)
downloadguile-1a5e35f0eb9a9160d931b6a4a9f1764e65b7e5b8.tar.gz
srfi-64: Accept symbols as test group names.
The specification mandates a string, but with rationale suggesting symbols would be a more natural fit. > In some ways using symbols would be preferable. However, we want > human-readable names, and standard Scheme does not provide a way to include > spaces or mixed-case text in literal symbols. Add support for symbols as an implementation extension and for backwards compatibility with the reference implementation. * module/srfi/srfi-64.scm (%cmp-group-name): New procedure. (test-end): Use it. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Reported-by: Daniel Llorens <lloda@sarc.name>
-rw-r--r--module/srfi/srfi-64.scm15
1 files changed, 13 insertions, 2 deletions
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
index 1f60a72e5..98fcef645 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -522,7 +522,10 @@ returning new test runner. Defaults to @code{test-runner-simple}.")
(1+ (group-executed-count group)))))))
(define* (test-begin suite-name #:optional count)
- "Enter a new test group."
+ "Enter a new test group.
+
+As implementation extension, in addition to strings, symbols are also
+supported as @var{suite-name}."
(let* ((r (test-runner-current))
(r install? (if r
(values r #f)
@@ -544,6 +547,14 @@ returning new test runner. Defaults to @code{test-runner-simple}.")
((test-runner-on-group-begin r) r suite-name count)))
+(define (%cmp-group-name a b)
+ (match (list a b)
+ (((? string?) (? string?))
+ (string=? a b))
+ (((? symbol?) (? symbol?))
+ (eq? a b))
+ (_ #f)))
+
(define* (test-end #:optional suite-name)
"Leave the current test group."
(let* ((r (test-runner-current))
@@ -551,7 +562,7 @@ returning new test runner. Defaults to @code{test-runner-simple}.")
(let ((begin-name (car (test-runner-group-stack r)))
(end-name suite-name))
- (when (and end-name (not (string=? begin-name end-name)))
+ (when (and end-name (not (%cmp-group-name begin-name end-name)))
((test-runner-on-bad-end-name r) r begin-name end-name)
(raise-exception (make-bad-end-name begin-name end-name))))