diff --git a/check-guile.in b/check-guile.in old mode 100644 new mode 100755 index 7fc0e9897..62696d48a --- a/check-guile.in +++ b/check-guile.in @@ -10,30 +10,88 @@ # ./check-guile -i /usr/local/bin/guile numbers.test # ./check-guile -i meta/gdb-uninstalled-guile numbers.test -set -e +set -eu + +misuse() +{ + echo 'Usage: check-guile [-i GUILE] [--] [TEST...]' 1>&2 + exit 2 +} top_builddir=@top_builddir_absolute@ top_srcdir=@top_srcdir_absolute@ +test_suite_dir="${top_srcdir}/test-suite" +guile="${top_builddir}/meta/guile" +log_file=check-guile.log +trs_file='' -export TEST_SUITE_DIR="${top_srcdir}/test-suite" - -if [ x"$1" = x-i ] ; then - guile="$2" - shift 2 -else - guile="${top_builddir}/meta/guile" -fi - -export GUILE_LOAD_PATH="$TEST_SUITE_DIR" +while test $# -gt 0; do + case "$1" in + -i) test $# -gt 1 || misuse; guile="$2"; shift 2 ;; + --log-file) test $# -gt 1 || misuse; log_file="$2"; shift 2 ;; + --trs-file) test $# -gt 1 || misuse; trs_file="$2"; shift 2 ;; + --) break ;; + -*) misuse ;; + *) break ;; + esac +done if ! [ -f "$guile" -a -x "$guile" ] ; then echo "ERROR: Cannot execute $guile" 1>&2 exit 2 fi -exec "$guile" \ - --debug \ - -L "$TEST_SUITE_DIR" \ - --no-auto-compile -e main -s "$TEST_SUITE_DIR/guile-test" \ - --test-suite "$TEST_SUITE_DIR/tests" \ - --log-file check-guile.log "$@" +# Disallow mixed suites until/unless we can unify the log/trs files +have_sr64='' +have_test_lib='' +for test_file in "$@"; do + case "$test_file" in + *.sr64) have_sr64=true ;; + *) have_test_lib=true ;; + esac +done + +if test "$have_sr64" -a "$have_test_lib"; then + echo 'Cannot currently mix (test-suite lib) and SRFI-64 tests' 1>&2 + exit 2 +fi + +exec_srfi_64() +{ + exec "$guile" \ + --debug \ + --no-auto-compile \ + -e '(@@ (srfi srfi-64 automake) main)' \ + -- \ + --test-suite "$test_suite_dir/tests" \ + --log-file "$log_file" \ + "$@" +} + +if test "$have_sr64"; then + if test "$trs_file"; then + exec_srfi_64 --trs-file "$trs_file" "$@" + else + exec_srfi_64 "$@" + fi +fi + +exec_test_lib() +{ + export TEST_SUITE_DIR="$test_suite_dir" + export GUILE_LOAD_PATH="$test_suite_dir" + + exec "$guile" \ + --debug \ + -L "$test_suite_dir" \ + --no-auto-compile -e main -s "$test_suite_dir/guile-test" \ + --test-suite "$test_suite_dir/tests" \ + --log-file "$log_file" \ + "$@" +} + +if test "$trs_file"; then + exec_test_lib --trs-file "$trs_file" "$@" +else + exec_test_lib "$@" +fi diff --git a/module/srfi/srfi-64/automake.scm b/module/srfi/srfi-64/automake.scm new file mode 100644 index 000000000..72ad924ca --- /dev/null +++ b/module/srfi/srfi-64/automake.scm @@ -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)))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 6014b1f1f..1a1356d67 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -251,15 +251,17 @@ LALR_EXTRA += \ lalr/run-guile-test.sh TESTS = $(LALR_TESTS) $(SCM_TESTS) -TEST_EXTENSIONS = .scm .test +TEST_EXTENSIONS = .scm .sr64 .test AM_TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@ # Run *.scm tests with meta/guile SCM_LOG_COMPILER = $(top_builddir)/meta/guile AM_SCM_LOG_FLAGS = --no-auto-compile -# Use a custom driver for *.test (assume they use (test-suite lib)). -# See the automake info pages regarding "Custom Test Drivers". +# See "Custom Test Drivers" in the Automake info pages and ./check-guile.in. +# *.sr64 files use (srfi srfi-64 automake) +# *.test files use (test-suite lib) +SR64_LOG_DRIVER = $(srcdir)/driver TEST_LOG_DRIVER = $(srcdir)/driver EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS) tests/sxml-match-tests.ss driver