/[guile]/guile/guile-core/test-suite/guile-test
ViewVC logotype

Diff of /guile/guile-core/test-suite/guile-test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.2.1 by mgrabmue, Thu Jul 19 20:49:33 2001 UTC revision 1.9.2.2 by ttn, Sat Feb 9 22:34:37 2002 UTC
# Line 6  Line 6 
6  ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999  ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
7  ;;;;  ;;;;
8  ;;;;    Copyright (C) 1999, 2001 Free Software Foundation, Inc.  ;;;;    Copyright (C) 1999, 2001 Free Software Foundation, Inc.
9  ;;;;  ;;;;
10  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
11  ;;;; it under the terms of the GNU General Public License as published by  ;;;; it under the terms of the GNU General Public License as published by
12  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;;;; the Free Software Foundation; either version 2, or (at your option)
13  ;;;; any later version.  ;;;; any later version.
14  ;;;;  ;;;;
15  ;;;; This program is distributed in the hope that it will be useful,  ;;;; This program is distributed in the hope that it will be useful,
16  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18  ;;;; GNU General Public License for more details.  ;;;; GNU General Public License for more details.
19  ;;;;  ;;;;
20  ;;;; You should have received a copy of the GNU General Public License  ;;;; You should have received a copy of the GNU General Public License
21  ;;;; along with this software; see the file COPYING.  If not, write to  ;;;; along with this software; see the file COPYING.  If not, write to
22  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
# Line 36  Line 36 
36  ;;;; Scheme code.)  However, you can have it execute specific tests by  ;;;; Scheme code.)  However, you can have it execute specific tests by
37  ;;;; listing their filenames on the command line.  ;;;; listing their filenames on the command line.
38  ;;;;  ;;;;
39  ;;;; The option '--test-suite' can be given to specify the test  ;;;; The option `--test-suite' can be given to specify the test
40  ;;;; directory.  If no such option is given, the test directory is  ;;;; directory.  If no such option is given, the test directory is
41  ;;;; taken from the environment variable TEST_SUITE_DIR (if defined),  ;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
42  ;;;; otherwise a default directory that is hardcoded in this file is  ;;;; otherwise a default directory that is hardcoded in this file is
43  ;;;; used (see "Installation" below).  ;;;; used (see "Installation" below).
44  ;;;;  ;;;;
45  ;;;; If present, the `--log-file LOG' option tells `guile-test' to put  ;;;; If present, the `--log-file LOG' option tells `guile-test' to put
46  ;;;; the log output in a file named LOG.  ;;;; the log output in a file named LOG.
47  ;;;;  ;;;;
48  ;;;; If present, the '--debug' option will enable a debugging mode.  ;;;; If present, the `--debug' option will enable a debugging mode.
49    ;;;;
50    ;;;; If present, the `--flag-unresolved' option will cause guile-test
51    ;;;; to exit with failure status if any tests are UNRESOLVED.
52  ;;;;  ;;;;
53  ;;;;  ;;;;
54  ;;;; Installation:  ;;;; Installation:
# Line 105  Line 108 
108  ;;; symlinks.  ;;; symlinks.
109  (define (for-each-file f root)  (define (for-each-file f root)
110    
111    ;; A "hard directory" is a path that denotes a directory and is not a    ;; A "hard directory" is a path that denotes a directory and is not a
112    ;; symlink.    ;; symlink.
113    (define (file-is-hard-directory? filename)    (define (file-is-hard-directory? filename)
114      (eq? (stat:type (lstat filename)) 'directory))      (eq? (stat:type (lstat filename)) 'directory))
# Line 116  Line 119 
119            (let ((dir (opendir root)))            (let ((dir (opendir root)))
120              (let loop ()              (let loop ()
121                (let ((entry (readdir dir)))                (let ((entry (readdir dir)))
122                  (cond                  (cond
123                   ((eof-object? entry) #f)                   ((eof-object? entry) #f)
124                   ((or (string=? entry ".")                   ((or (string=? entry ".")
125                        (string=? entry ".."))                        (string=? entry ".."))
# Line 157  Line 160 
160    
161  (define (main args)  (define (main args)
162    (let ((options (getopt-long args    (let ((options (getopt-long args
163                                `((test-suite                                `((test-suite
164                                   (single-char #\t)                                   (single-char #\t)
165                                   (value #t))                                   (value #t))
166                                  (log-file                                  (flag-unresolved
167                                     (single-char #\u))
168                                    (log-file
169                                   (single-char #\l)                                   (single-char #\l)
170                                   (value #t))                                   (value #t))
171                                  (debug                                  (debug
172                                   (single-char #\d))))))                                   (single-char #\d))))))
173      (define (opt tag default)      (define (opt tag default)
174        (let ((pair (assq tag options)))        (let ((pair (assq tag options)))
# Line 184  Line 189 
189    
190      (let* ((tests      (let* ((tests
191              (let ((foo (opt '() '())))              (let ((foo (opt '() '())))
192                (if (null? foo)                (if (null? foo)
193                    (enumerate-tests test-suite)                    (enumerate-tests test-suite)
194                    foo)))                    foo)))
195             (log-file             (log-file
196              (opt 'log-file "guile.log")))              (opt 'log-file "guile.log")))
197    
198        ;; Open the log file.        ;; Open the log file.
# Line 201  Line 206 
206            (register-reporter user-reporter)            (register-reporter user-reporter)
207            (register-reporter (lambda results            (register-reporter (lambda results
208                                 (case (car results)                                 (case (car results)
209                                   ((fail upass unresolved error)                                   ((unresolved)
210                                      (and (opt 'flag-unresolved #f)
211                                           (set! global-pass #f)))
212                                     ((fail upass error)
213                                    (set! global-pass #f)))))                                    (set! global-pass #f)))))
214    
215            ;; Run the tests.            ;; Run the tests.

Legend:
Removed from v.1.9.2.1  
changed lines
  Added in v.1.9.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26