mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

srfi-64: Accept symbols as test group names.

Browse source 
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>
This commit is contained in:
Tomas Volf 2024-10-26 18:06:51 +02:00 • committed by Ludovic Courtès
parent 242e8698c2
commit 1a5e35f0eb
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 13 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

15
module/srfi/srfi-64.scm
View file

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