[PATCH 4/7] guile-test: support automake parallel test harness via --trs-file

[Rob Browning]

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