tests/run-test.scm

   1 ;;; run-test.scm --- Run a test file and exit with an appropriate status.
   2 ;;;
   3 ;;; Jim Blandy <jimb@red-bean.com> --- May 1999
   4 ;;;
   5 ;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
   6 ;;; Copyright (C) 2007 Ludovic Courtès <ludovic.courtes@laas.fr>
   7 ;;;
   8 ;;; This program is free software; you can redistribute it and/or modify
   9 ;;; it under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 2, or (at your option)
  11 ;;; any later version.
  12 ;;;
  13 ;;; This program is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with this software; see the file COPYING.  If not, write to
  20 ;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  21 ;;; Boston, MA 02110-1301 USA
  22
  23 ;;; Code borrowed from `test-suite/guile-test' in the core Guile
  24 ;;; distribution.
  25
  26 (use-modules (test-suite lib))
  27
  28 (let ((tests (cdr (command-line)))
  29       (global-pass #t)
  30       (counter (make-count-reporter)))
  31   (register-reporter (car counter))
  32   (register-reporter user-reporter)
  33   (register-reporter (lambda results
  34                        (case (car results)
  35                          ((unresolved)
  36                           #f)
  37                          ((fail upass error)
  38                           (set! global-pass #f)))))
  39
  40   ;; Run the tests.
  41   (for-each (lambda (test)
  42               (display (string-append "Running `" test "'\n"))
  43               (save-module-excursion
  44                 (lambda ()
  45                   (with-test-prefix test (primitive-load test)))))
  46             tests)
  47
  48   ;; Display the final counts, both to the user and in the log
  49   ;; file.
  50   (let ((counts ((cadr counter))))
  51     (print-counts counts))
  52
  53   (quit global-pass))
  54
  55 ;;; arch-tag: f27521e3-3745-4ae0-a625-2d34ce3ffd2e