diff --git a/test-suite/guile-test b/test-suite/guile-test index b59e85772..12597ff55 100755 --- a/test-suite/guile-test +++ b/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)))))) diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 6d15ccc68..6dcca3661 100644 --- a/test-suite/test-suite/lib.scm +++ b/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) 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))))