mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

test-suite: support SRFI-64 based tests

Browse source 
Add support for SRFI-64 based test-suite tests. When a SCM_TESTS test
ends in .sr64, run it using a new automake "Parallel Test Harness"
compatible driver (see the automake info pages) provided by (srfi
srfi-64 automake). For now, provide .trs file and standard output
results like guile-test's, but write SRFI-64's default test runner
output to the log file.

./check-guile, which the existing automake test-suite/driver relies on,
can now handle .sr64 files, though for the time being, it does not allow
mixing (test-suite lib) and SRFI-64 tests in the same invocation since
doing so correctly would require some way of merging the trs (and log)
output from the currently separate domains. This restriction does not
affect automake (make check) because it runs each test separately with
its own ouput files (e.g. test-suite/tests/numbers.{log,trs}) and
compiles the results.

Don't export anything from (srfi srfi-64 automake) until/unless we're
ready to commit to the API(s). For now, just provide support for
check-guile via (private) main.

* check-guile.in: Process *all* options; handle SRFI-64 tests.
* module/srfi/srfi-64/automake.scm: Add automake SRFI-64 test support.
* test-suite/Makefile.am: Add SRFI-64 test support.
This commit is contained in:
Rob Browning 2025-06-04 20:13:27 -05:00
parent a74987beba
commit c858253288
3 changed files with 303 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

223
module/srfi/srfi-64/automake.scm Normal file
View file

@ -0,0 +1,223 @@
;;;; module/srfi/srfi-64/automake.scm --- automake test driver compatible runner
;;;; Copyright (C) 2025 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this software; see the file COPYING.LESSER.
;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This provides an automake parallel test harness compatible SRFI-64
;;; test runner, and a check-guile compatible command line
;;; interface. For now, this is only intended to support check-guile and
;;; no public APIs have been settled, so there are no exports.
;;;
;;; Code:
(define-module (srfi srfi-64 automake)
#:declarative? #f
#:use-module ((ice-9 getopt-long) #:select (getopt-long option-ref))
#:use-module ((srfi srfi-64)
#:select (test-on-bad-count-simple
test-on-bad-end-name-simple
test-on-group-begin-simple
test-on-group-end-simple
test-on-test-end-simple
test-result-kind
test-runner-current
test-runner-fail-count
test-runner-group-path
test-runner-group-stack
test-runner-test-name
test-runner-null
test-runner-on-bad-count!
test-runner-on-bad-end-name!
test-runner-on-final!
test-runner-on-group-begin!
test-runner-on-group-end!
test-runner-on-test-begin!
test-runner-on-test-end!
test-runner-pass-count
test-runner-reset
test-runner-skip-count
test-runner-xfail-count
test-runner-xpass-count)))
(define (show port . args)
(for-each (lambda (x) (display x port)) args))
(define (write->str x)
(call-with-output-string (lambda (port) (write x port))))
(define (on-bad-count-callback log)
(define (automake-srfi-64-on-bad-count runner actual-count expected-count)
(with-output-to-port log
(λ () (test-on-bad-count-simple runner actual-count expected-count))))
automake-srfi-64-on-bad-count)
(define (on-bad-end-name-callback log)
(define (automake-srfi-64-on-bad-end-name runner begin-name end-name)
(with-output-to-port log
(λ () (test-on-bad-end-name-simple runner begin-name end-name))))
automake-srfi-64-on-bad-end-name)
(define (on-final-callback summary log trs)
(define (automake-srfi-64-on-final runner)
;; Match guile-test output (currently omits fields srfi-64 doesn't
;; support).
(let* ((pass (test-runner-pass-count runner))
(fail (test-runner-fail-count runner))
(xpass (test-runner-xpass-count runner))
(xfail (test-runner-xfail-count runner))
(skip (test-runner-skip-count runner))
(report (list
"\n"
"Totals for this test run:\n"
"passes: " pass "\n"
"failures: " fail "\n"
"unexpected passes: " xpass "\n"
"expected failures: " xfail "\n"
"untested test cases: " skip "\n"
"\n")))
(when trs
(when (and (zero? pass) (zero? fail) (zero? xpass) (zero? xfail))
(display ":recheck: no\n" trs))
(display ":test-global-result: " trs)
(for-each (λ (name count) (show trs " " name "=" count))
;; Match test-suite-lib names
'("PASS" "FAIL" "UPASS" "XFAIL" "UNTESTED")
(list pass fail xpass xfail skip))
(newline trs))
(apply show log report)
(unless trs
(apply show summary report))))
automake-srfi-64-on-final)
(define (on-group-begin-callback log)
(define (automake-srfi-64-on-group-begin runner suite-name count)
(with-output-to-port log
(λ () (test-on-group-begin-simple runner suite-name count))))
automake-srfi-64-on-group-begin)
(define (on-group-end-callback log)
(define (automake-srfi-64-on-group-end runner)
(with-output-to-port log (λ () (test-on-group-end-simple runner))))
automake-srfi-64-on-group-end)
(define (automake-srfi-64-on-test-begin runner) #f)
(define (on-test-end-callback log trs)
(define (automake-srfi-64-on-test-end runner)
(with-output-to-port log (λ () (test-on-test-end-simple runner)))
(let ((name (write->str (reverse
(cons (test-runner-test-name runner)
(test-runner-group-stack runner))))))
(case (test-result-kind runner)
((pass) (when trs (show trs ":test-result: PASS " name "\n")))
((fail)
(show (current-output-port) "FAIL: " name "\n")
(when trs (show trs ":test-result: FAIL " name "\n")))
((xfail)
(show (current-output-port) "XFAIL: " name "\n")
(when trs (show trs ":test-result: XFAIL " name "\n")))
((xpass)
(show (current-output-port) "UPASS: " name "\n")
(when trs (show trs ":test-result: XPASS " name "\n")))
((skip) (when trs (show trs ":test-result: SKIP " name "\n")))
(else => (λ (k) (error "Unexpected SRFI-64 test result kind:" k))))))
automake-srfi-64-on-test-end)
(define* (automake-srfi-64-runner #:key
(log (current-error-port))
(trs #f)
(final? #t))
"Return a SRFI-64 test runner that essentially matches the behavior of
guile-test (i.e. (test-suite lib) based tests). Write the same summary
output to (current-output-port) unless there's a TRS port. Send
SRFI-64's default test runner output to the LOG, followed by the
summary, and write the automake test driver output to the TRS port. When
FINAL? is #f, ignore the final event (cf. test-runner-on-final),
alllowing the aggregation of results across multiple top-level groups.
"
(let ((r (test-runner-null)))
(test-runner-reset r)
(test-runner-on-bad-count! r (on-bad-count-callback log))
(test-runner-on-bad-end-name! r (on-bad-end-name-callback log))
(test-runner-on-final! r
(if final?
(on-final-callback (current-output-port) log trs)
(λ args #f)))
(test-runner-on-group-begin! r (on-group-begin-callback log))
(test-runner-on-group-end! r (on-group-end-callback log))
(test-runner-on-test-begin! r automake-srfi-64-on-test-begin)
(test-runner-on-test-end! r (on-test-end-callback log trs))
r))
(define (dir-content dir)
(let ((d (opendir dir)))
(let lp ((p (readdir d)) (result '()))
(if (eof-object? p)
(begin
(closedir d)
result)
(lp (readdir d)
(cons p result))))))
(define (run-tests tests log trs)
(let ((runner (automake-srfi-64-runner #:log log #:trs trs #:final? #f)))
(test-runner-current runner)
(for-each (λ (test)
(format (current-output-port) "Running ~a\n" (basename test))
(load test))
tests)
((on-final-callback (current-output-port) log trs) runner)
(if (or (positive? (test-runner-fail-count runner))
(positive? (test-runner-xpass-count runner))
(positive? (test-runner-xfail-count runner)))
(exit 2)
(exit 0))))
(define-syntax-rule (with-final action body)
(let ((entered? #f))
(dynamic-wind
(λ ()
(when entered? (error "Not reentrant"))
(set! entered? #t))
(λ () body)
(λ () action))))
(define (main args)
"Provide a check-guile compatible command line interface, which means
matching guile-test's behavior where it's relevant, including support
for --log-file, --trs-file, and --test-suite."
(let* ((opts (getopt-long args '((log-file (value #t))
(test-suite (value #t) (required? #t))
(trs-file (value #t)))))
(test-suite (option-ref opts 'test-suite #f))
(add-suite (λ (p) (string-append test-suite "/" p)))
(tests (option-ref opts '() #f))
(tests (if tests
(map add-suite tests)
(map add-suite
(filter (λ (s) (string-suffix? ".sr64" s))
(dir-content test-suite)))))
(log-file (option-ref opts 'log-file #f))
(trs-file (option-ref opts 'trs-file #f))
(log (if log-file (open-output-file log-file) (current-error-port))))
(with-final
(when log-file (close-port log))
(let ((trs (and trs-file (open-output-file trs-file))))
(with-final
(when trs-file (close-port trs))
(run-tests tests log trs))))))