Support an optional --trs-file PATH argument that causes guile-test to write the status information expected by the automake parallel test harness to PATH.
In addition, when --trs-file is specified, suppress the final test summary (via print-counts) since it would be repeated per-test-file when running in parallel, the automake harness prints its own summary. cf. https://www.gnu.org/software/automake/manual/html_node/API-for-Custom-Test-Drivers.html --- test-suite/guile-test | 29 +++++++++++--- test-suite/test-suite/lib/automake.scm | 54 ++++++++++++++++++++++++++ 2 files changed, 77 insertions(+), 6 deletions(-) create mode 100644 test-suite/test-suite/lib/automake.scm diff --git a/test-suite/guile-test b/test-suite/guile-test index e0c4333f7..6090efc35 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -89,6 +89,7 @@ :use-module (system vm coverage) :use-module (srfi srfi-11) :use-module (system vm vm) + :use-module ((test-suite lib automake) :prefix automake/) :export (main data-file-name test-file-name)) @@ -184,7 +185,9 @@ (coverage (single-char #\c)) (debug - (single-char #\d)))))) + (single-char #\d)) + (trs-file + (value #t)))))) (define (opt tag default) (let ((pair (assq tag options))) (if pair (cdr pair) default))) @@ -207,11 +210,16 @@ (if (null? foo) (enumerate-tests test-suite) foo))) - (log-file - (opt 'log-file "guile.log"))) + (log-file (opt 'log-file "guile.log")) + (trs-file (opt 'trs-file #f))) ;; Open the log file. - (let ((log-port (open-output-file log-file))) + (let ((log-port (open-output-file log-file)) + (trs-port (and trs-file + (let ((p (open-output-file trs-file))) + (set-port-encoding! p "UTF-8") + (display ":copy-in-global-log: no\n" p) + p)))) ;; Allow for arbitrary Unicode characters in the log file. (set-port-encoding! log-port "UTF-8") @@ -223,9 +231,11 @@ ;; Register some reporters. (let ((global-pass #t) (counter (make-count-reporter))) + (when trs-port + (register-reporter (automake/reporter trs-port))) (register-reporter (car counter)) (register-reporter (make-log-reporter log-port)) - (register-reporter user-reporter) + (register-reporter user-reporter) (register-reporter (lambda results (case (car results) ((unresolved) @@ -255,10 +265,17 @@ ;; Display the final counts, both to the user and in the log ;; file. (let ((counts ((cadr counter)))) - (print-counts counts) + (unless trs-port + (print-counts counts)) (print-counts counts log-port)) (close-port log-port) + + (when trs-port + (when global-pass (display ":recheck: no\n" trs-port)) + (display ":test-global-result: umm, ok?\n" trs-port) + (close-port trs-port)) + (quit global-pass)))))) diff --git a/test-suite/test-suite/lib/automake.scm b/test-suite/test-suite/lib/automake.scm new file mode 100644 index 000000000..237a89d65 --- /dev/null +++ b/test-suite/test-suite/lib/automake.scm @@ -0,0 +1,54 @@ +;;;; test-suite/lib/automake.scm --- support for automake driven tests +;;;; Copyright (C) 2023 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 + +(define-module (test-suite lib automake) + :use-module ((ice-9 match)) + :use-module ((srfi srfi-1) :select (drop-right last)) + :export (reporter)) + +(define (display->str x) + (call-with-output-string (lambda (port) (display x port)))) + +(define (write->str x) + (call-with-output-string (lambda (port) (write x port)))) + +(define (show port . args) + (for-each (lambda (x) (display x port)) args)) + +(define (render-name name) + (string-join (append (map display->str (drop-right name 1)) + ;; Because for some tests, say via pass-if or + ;; pass-if-equal with no explict name, it's an + ;; arbirary form, possibly including null chars, + ;; etc. + (list (write->str (last name)))) + ": ")) + +(define (reporter trs-port) + (match-lambda* + (('pass name) (show trs-port ":test-result: PASS " (render-name name) "\n")) + (('upass name) (show trs-port ":test-result: XPASS " (render-name name) "\n")) + (('fail name) (show trs-port ":test-result: FAIL " (render-name name) "\n")) + (('xfail name . args) (show trs-port ":test-result: XFAIL " (render-name name) "\n")) + (('untested name) (show trs-port ":test-result: SKIP " (render-name name) "\n")) + (('unsupported name) (show trs-port ":test-result: SKIP " (render-name name) "\n")) + (('unresolved name) (show trs-port ":test-result: SKIP " (render-name name) "\n")) + (('error name . args) + (show trs-port ":test-result: ERROR " (render-name name) " ") + (write args trs-port) + (newline trs-port)))) -- 2.39.2
