gomp-20050608-branch/libjava/classpath/testsuite/scheme/test.scm

   1 #!/usr/local/bin/guile -s
   2 !#
   3
   4 ;  Guile/JNI/JVM Testing Framework
   5 ;
   6 ;  Copyright (c) 1998 Free Software Foundation, Inc.
   7 ;  Written by Paul Fisher (rao@gnu.org)
   8 ;
   9 ;  This program is free software; you can redistribute it and/or modify
  10 ;  it under the terms of the GNU General Public License as published by
  11 ;  the Free Software Foundation; either version 2 of the License, or
  12 ;  (at your option) any later version.
  13 ;
  14 ;  This program is distributed in the hope that it will be useful,
  15 ;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;  GNU General Public License for more details.
  18 ;
  19 ;  You should have received a copy of the GNU General Public License
  20 ;  along with this program; if not, write to the Free Software
  21 ;  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
  22 ;  USA.
  23
  24
  25 ; log filenames
  26 (define verbose-log-file "classpath.log")
  27 (define summary-log-file "classpath.sum")
  28
  29 ; returns the number of times that ELEM appears in the toplevel of LS
  30 (define count
  31   (lambda (elem ls)
  32     (letrec
  33         ((count-it
  34           (lambda (ls acc)
  35             (cond
  36              ((null? ls) acc)
  37              ((equal? (car ls) elem) (count-it (cdr ls) (+ acc 1)))
  38              (else (count-it (cdr ls) acc))))))
  39       (count-it ls 0))))
  40
  41 ; returns a list of pairs containing an element of ELS along with the
  42 ; number of times that element appears in LS
  43 (define build-result-count
  44   (lambda (els ls)
  45     (cond
  46      ((null? els) '())
  47      (else (cons (cons (car els) (count (car els) ls))
  48                  (build-result-count (cdr els) ls))))))
  49
  50 ; soft port which sends output to both (current-output-port) and
  51 ; the verbose-log-port
  52 (define screen-and-log-port
  53   (make-soft-port
  54    (vector
  55     (lambda (c)
  56       (cond
  57        ((char=? c #\newline)
  58         (newline (current-output-port))
  59         (newline verbose-log-port))
  60        (else
  61         (write c (current-output-port))
  62         (write c verbose-log-port))))
  63     (lambda (s)
  64       (display s (current-output-port))
  65       (display s verbose-log-port))
  66     (lambda ()
  67       (force-output (current-output-port))
  68       (force-output verbose-log-port))
  69     #f
  70     #f)
  71    "w"))
  72
  73 ; pretty prints the result of a single test
  74 (define display-test-summary
  75   (lambda (result port)
  76     (let ((name (car result))
  77           (code (cadr result))
  78           (msg (caddr result)))
  79       (display "Name    : " port)
  80       (display name port)
  81       (newline port)
  82       (display "Result  : " port)
  83       (display code port)
  84       (newline port)
  85       (display "Message : " port)
  86       (if (= (string-length msg) 0)
  87           (display "None" port)
  88           (display msg port))
  89       (newline port)
  90       (newline port))))
  91
  92 ; status message
  93 (define display-running
  94   (lambda (class port)
  95     (display "Running " port)
  96     (display class port)
  97     (display "..." port)
  98     (newline port)))
  99
 100 ; runs the test named CLASS
 101 (define run-test
 102   (lambda (class)
 103     (display-running class screen-and-log-port)
 104     (force-output verbose-log-port)
 105     (let ((result (test class)))
 106       (display-test-summary result screen-and-log-port)
 107       (write (cons class result) summary-log-port)
 108       (newline summary-log-port)
 109       (cadr result))))
 110
 111 ; run each and every test.  each test is read from PORT
 112 ; and delimited by a newline.  returns a list of all test result codes
 113 (define parse-input-file
 114   (lambda (port)
 115     (letrec
 116         ((parse-line
 117           (lambda (line)
 118             (cond
 119              ((eof-object? (car line)) '())
 120              ((= (string-length (car line)) 0)
 121               (parse-line (read-line port 'split)))
 122              (else (cons (run-test (car line))
 123                          (parse-line
 124                           (read-line port 'split))))))))
 125       (parse-line (read-line port 'split)))))
 126
 127 ; pretty prints the result list
 128 (define display-results
 129   (lambda (results port)
 130     (display "Summary information..." port)
 131     (newline port)
 132     (letrec ((display-results-l
 133               (lambda (ls)
 134                 (cond
 135                  ((null? ls))
 136                  (else
 137                   (let ((res (car ls)))
 138                     (display "# of " port)
 139                     (display (car res) port)
 140                     (display "'s " port)
 141                     (display (cdr res) port)
 142                     (newline port))
 143                   (display-results-l (cdr ls)))))))
 144       (display-results-l results))))
 145
 146 (if (batch-mode?)
 147     (if (> (length (command-line)) 1)
 148         (define input-port (open-input-file (cadr (command-line))))
 149         (error "filename listing tests to execute must be specified.")))
 150
 151 ; open up the log files
 152 (define verbose-log-port (open verbose-log-file
 153                                (logior O_WRONLY O_CREAT O_TRUNC)))
 154 (define summary-log-port (open summary-log-file
 155                                (logior O_WRONLY O_CREAT O_TRUNC)))
 156
 157 ; redirect stderr to the verbose log
 158 (dup verbose-log-port 2)
 159
 160 ; run the tests, and build the result table, and display the results
 161 (display-results (build-result-count
 162                   '(PASS XPASS FAIL XPAIL UNRESOLVED
 163                          UNSUPPORTED UNTESTED ERROR)
 164                   (parse-input-file input-port)) screen-and-log-port)