guile-test: support automake parallel test harness via --trs-file

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 (main): support --trs-file and --log-file.
* test-suite/test-suite/lib.scm: add count-summary-line.
* test-suite/test-suite/lib/automake.scm: add automake custom test driver.

test-suite/guile-test

@@ -91,6 +91,7 @@
   :use-module (srfi srfi-11)
   :use-module (system vm vm)
   #:declarative? #f
+  :use-module ((test-suite lib automake) :prefix automake/)
   :export (main data-file-name test-file-name))
 
 
@@ -186,7 +187,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)))
@@ -209,11 +212,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")
@@ -225,9 +233,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)
@@ -257,10 +267,19 @@
 	  ;; Display the final counts, both to the user and in the log
 	  ;; file.
 	  (let ((counts ((cadr counter))))
-	    (print-counts counts)
-	    (print-counts counts log-port))
+            (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: " trs-port)
+              (display (count-summary-line counts) trs-port)
+              (newline trs-port)
+              (close-port trs-port)))
 
-	  (close-port log-port)
 	  (quit global-pass))))))
 
 

test-suite/test-suite/lib.scm

@@ -67,7 +67,7 @@
 
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
- make-count-reporter print-counts
+ make-count-reporter print-counts count-summary-line
  make-log-reporter
  full-reporter
  user-reporter))
@@ -696,6 +696,17 @@
      result-tags)
     (newline port)))
 
+(define (count-summary-line results)
+  (string-join
+   (map (lambda (tag-info)
+          (match-let* (((tag tag-name _) tag-info)
+                       ((_ . count) (or (assq tag results) '(#f #f))))
+            (if (zero? count)
+                ""
+                (string-append tag-name "=" (or (number->string count) "???")))))
+        result-tags)
+   " "))
+
 ;;; Return a reporter procedure which prints all results to the file
 ;;; FILE, in human-readable form.  FILE may be a filename, or a port.
 (define (make-log-reporter file)

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