Commit | Line | Data |
---|---|---|
1f845305 | 1 | #!../meta/guile \ |
000ee07f JB |
2 | -e main -s |
3 | !# | |
4 | ||
5 | ;;;; guile-test --- run the Guile test suite | |
6 | ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 | |
7 | ;;;; | |
d332d846 | 8 | ;;;; Copyright (C) 1999, 2001, 2006, 2010 Free Software Foundation, Inc. |
068a9d87 | 9 | ;;;; |
53befeb7 NJ |
10 | ;;;; This program is free software; you can redistribute it and/or |
11 | ;;;; modify it under the terms of the GNU Lesser General Public | |
12 | ;;;; License as published by the Free Software Foundation; either | |
13 | ;;;; version 3, or (at your option) any later version. | |
068a9d87 | 14 | ;;;; |
000ee07f JB |
15 | ;;;; This program is distributed in the hope that it will be useful, |
16 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
53befeb7 | 18 | ;;;; GNU Lesser General Public License for more details. |
068a9d87 | 19 | ;;;; |
53befeb7 NJ |
20 | ;;;; You should have received a copy of the GNU Lesser General Public |
21 | ;;;; License along with this software; see the file COPYING.LESSER. | |
22 | ;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin | |
23 | ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA | |
000ee07f JB |
24 | |
25 | ||
1ff7abbe | 26 | ;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] |
000ee07f JB |
27 | ;;;; |
28 | ;;;; Run tests from the Guile test suite. Report failures and | |
29 | ;;;; unexpected passes to the standard output, along with a summary of | |
30 | ;;;; all the results. Record each reported test outcome in the log | |
1ff7abbe DH |
31 | ;;;; file, `guile.log'. The exit status is #f if any of the tests |
32 | ;;;; fail or pass unexpectedly. | |
000ee07f JB |
33 | ;;;; |
34 | ;;;; Normally, guile-test scans the test directory, and executes all | |
35 | ;;;; files whose names end in `.test'. (It assumes they contain | |
36 | ;;;; Scheme code.) However, you can have it execute specific tests by | |
37 | ;;;; listing their filenames on the command line. | |
38 | ;;;; | |
068a9d87 | 39 | ;;;; The option `--test-suite' can be given to specify the test |
1ff7abbe DH |
40 | ;;;; directory. If no such option is given, the test directory is |
41 | ;;;; taken from the environment variable TEST_SUITE_DIR (if defined), | |
068a9d87 | 42 | ;;;; otherwise a default directory that is hardcoded in this file is |
1ff7abbe DH |
43 | ;;;; used (see "Installation" below). |
44 | ;;;; | |
000ee07f JB |
45 | ;;;; If present, the `--log-file LOG' option tells `guile-test' to put |
46 | ;;;; the log output in a file named LOG. | |
47 | ;;;; | |
068a9d87 TTN |
48 | ;;;; 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. | |
1ff7abbe DH |
52 | ;;;; |
53 | ;;;; | |
000ee07f JB |
54 | ;;;; Installation: |
55 | ;;;; | |
1ff7abbe DH |
56 | ;;;; If you change the #! line at the top of this script to point at |
57 | ;;;; the Guile interpreter you want to test, you can call this script | |
58 | ;;;; as an executable instead of having to pass it as a parameter to | |
59 | ;;;; guile via "guile -e main -s guile-test". Further, you can edit | |
60 | ;;;; the definition of default-test-suite to point to the parent | |
61 | ;;;; directory of the `tests' tree, which makes it unnecessary to set | |
62 | ;;;; the environment variable `TEST_SUITE_DIR'. | |
63 | ;;;; | |
000ee07f JB |
64 | ;;;; |
65 | ;;;; Shortcomings: | |
66 | ;;;; | |
67 | ;;;; At the moment, due to a simple-minded implementation, test files | |
68 | ;;;; must live in the test directory, and you must specify their names | |
69 | ;;;; relative to the top of the test directory. If you want to send | |
1ff7abbe | 70 | ;;;; me a patch that fixes this, but still leaves sane test names in |
000ee07f JB |
71 | ;;;; the log file, that would be great. At the moment, all the tests |
72 | ;;;; I care about are in the test directory, though. | |
73 | ;;;; | |
74 | ;;;; It would be nice if you could specify the Guile interpreter you | |
75 | ;;;; want to test on the command line. As it stands, if you want to | |
76 | ;;;; change which Guile interpreter you're testing, you need to edit | |
77 | ;;;; the #! line at the top of this file, which is stupid. | |
78 | ||
8aa28a91 DH |
79 | (define (main . args) |
80 | (let ((module (resolve-module '(test-suite guile-test)))) | |
81 | (apply (module-ref module 'main) args))) | |
82 | ||
83 | (define-module (test-suite guile-test) | |
84 | :use-module (test-suite lib) | |
85 | :use-module (ice-9 getopt-long) | |
86 | :use-module (ice-9 and-let-star) | |
87 | :use-module (ice-9 rdelim) | |
36b5e394 LC |
88 | :use-module (system vm coverage) |
89 | :use-module (srfi srfi-11) | |
90 | :use-module (system vm vm) | |
8aa28a91 DH |
91 | :export (main data-file-name test-file-name)) |
92 | ||
1ff7abbe DH |
93 | \f |
94 | ;;; User configurable settings: | |
1f845305 BT |
95 | (define (default-test-suite) |
96 | (let ((argv0 (car (program-arguments)))) | |
97 | (if (string=? (basename argv0) "guile-test") | |
98 | (dirname argv0) | |
99 | (error "Cannot find default test suite.")))) | |
1ff7abbe DH |
100 | |
101 | \f | |
efb07c89 | 102 | ;;; Variables that will receive their actual values later. |
1f845305 | 103 | (define test-suite) |
efb07c89 | 104 | |
66301f9a GH |
105 | (define tmp-dir #f) |
106 | ||
efb07c89 | 107 | \f |
000ee07f JB |
108 | ;;; General utilities, that probably should be in a library somewhere. |
109 | ||
1ff7abbe DH |
110 | ;;; Enable debugging |
111 | (define (enable-debug-mode) | |
112 | (write-line %load-path) | |
113 | (set! %load-verbosely #t) | |
114 | (debug-enable 'backtrace 'debug)) | |
115 | ||
000ee07f JB |
116 | ;;; Traverse the directory tree at ROOT, applying F to the name of |
117 | ;;; each file in the tree, including ROOT itself. For a subdirectory | |
118 | ;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow | |
119 | ;;; symlinks. | |
120 | (define (for-each-file f root) | |
121 | ||
068a9d87 | 122 | ;; A "hard directory" is a path that denotes a directory and is not a |
000ee07f JB |
123 | ;; symlink. |
124 | (define (file-is-hard-directory? filename) | |
125 | (eq? (stat:type (lstat filename)) 'directory)) | |
126 | ||
127 | (let visit ((root root)) | |
128 | (let ((should-recur (f root))) | |
129 | (if (and should-recur (file-is-hard-directory? root)) | |
130 | (let ((dir (opendir root))) | |
131 | (let loop () | |
132 | (let ((entry (readdir dir))) | |
068a9d87 | 133 | (cond |
000ee07f JB |
134 | ((eof-object? entry) #f) |
135 | ((or (string=? entry ".") | |
1febd88c TTN |
136 | (string=? entry "..") |
137 | (string=? entry "CVS") | |
138 | (string=? entry "RCS")) | |
000ee07f JB |
139 | (loop)) |
140 | (else | |
141 | (visit (string-append root "/" entry)) | |
142 | (loop)))))))))) | |
143 | ||
000ee07f JB |
144 | \f |
145 | ;;; The test driver. | |
146 | ||
efb07c89 | 147 | \f |
66301f9a | 148 | ;;; Localizing test files and temporary data files. |
efb07c89 DH |
149 | |
150 | (define (data-file-name filename) | |
66301f9a | 151 | (in-vicinity tmp-dir filename)) |
efb07c89 DH |
152 | |
153 | (define (test-file-name test) | |
154 | (in-vicinity test-suite test)) | |
000ee07f JB |
155 | |
156 | ;;; Return a list of all the test files in the test tree. | |
1ff7abbe | 157 | (define (enumerate-tests test-dir) |
1ff7abbe | 158 | (let ((root-len (+ 1 (string-length test-dir))) |
000ee07f JB |
159 | (tests '())) |
160 | (for-each-file (lambda (file) | |
010b159f | 161 | (if (string-suffix? ".test" file) |
000ee07f JB |
162 | (let ((short-name |
163 | (substring file root-len))) | |
164 | (set! tests (cons short-name tests)))) | |
165 | #t) | |
1ff7abbe | 166 | test-dir) |
000ee07f JB |
167 | |
168 | ;; for-each-file presents the files in whatever order it finds | |
169 | ;; them in the directory. We sort them here, so they'll always | |
170 | ;; appear in the same order. This makes it easier to compare test | |
171 | ;; log files mechanically. | |
172 | (sort tests string<?))) | |
173 | ||
174 | (define (main args) | |
175 | (let ((options (getopt-long args | |
068a9d87 | 176 | `((test-suite |
1ff7abbe DH |
177 | (single-char #\t) |
178 | (value #t)) | |
068a9d87 TTN |
179 | (flag-unresolved |
180 | (single-char #\u)) | |
181 | (log-file | |
1ff7abbe DH |
182 | (single-char #\l) |
183 | (value #t)) | |
36b5e394 LC |
184 | (coverage |
185 | (single-char #\c)) | |
068a9d87 | 186 | (debug |
1ff7abbe | 187 | (single-char #\d)))))) |
000ee07f JB |
188 | (define (opt tag default) |
189 | (let ((pair (assq tag options))) | |
190 | (if pair (cdr pair) default))) | |
1ff7abbe DH |
191 | |
192 | (if (opt 'debug #f) | |
193 | (enable-debug-mode)) | |
194 | ||
efb07c89 DH |
195 | (set! test-suite |
196 | (or (opt 'test-suite #f) | |
197 | (getenv "TEST_SUITE_DIR") | |
1f845305 | 198 | (default-test-suite))) |
efb07c89 | 199 | |
66301f9a GH |
200 | ;; directory where temporary files are created. |
201 | ;; when run from "make check", this must be under the build-dir, | |
202 | ;; not the src-dir. | |
203 | (set! tmp-dir (getcwd)) | |
204 | ||
efb07c89 | 205 | (let* ((tests |
1ff7abbe | 206 | (let ((foo (opt '() '()))) |
068a9d87 | 207 | (if (null? foo) |
1ff7abbe DH |
208 | (enumerate-tests test-suite) |
209 | foo))) | |
068a9d87 | 210 | (log-file |
1ff7abbe | 211 | (opt 'log-file "guile.log"))) |
000ee07f JB |
212 | |
213 | ;; Open the log file. | |
214 | (let ((log-port (open-output-file log-file))) | |
215 | ||
d332d846 LC |
216 | ;; Allow for arbitrary Unicode characters in the log file. |
217 | (set-port-encoding! log-port "UTF-8") | |
218 | ||
dec84a0a LC |
219 | ;; Don't fail if we can't display a test name to stdout/stderr. |
220 | (set-port-conversion-strategy! (current-output-port) 'escape) | |
221 | (set-port-conversion-strategy! (current-error-port) 'escape) | |
222 | ||
000ee07f | 223 | ;; Register some reporters. |
1ff7abbe DH |
224 | (let ((global-pass #t) |
225 | (counter (make-count-reporter))) | |
000ee07f JB |
226 | (register-reporter (car counter)) |
227 | (register-reporter (make-log-reporter log-port)) | |
228 | (register-reporter user-reporter) | |
1ff7abbe DH |
229 | (register-reporter (lambda results |
230 | (case (car results) | |
068a9d87 TTN |
231 | ((unresolved) |
232 | (and (opt 'flag-unresolved #f) | |
233 | (set! global-pass #f))) | |
234 | ((fail upass error) | |
1ff7abbe | 235 | (set! global-pass #f))))) |
000ee07f JB |
236 | |
237 | ;; Run the tests. | |
36b5e394 LC |
238 | (let ((run-tests |
239 | (lambda () | |
240 | (for-each (lambda (test) | |
241 | (display (string-append "Running " test "\n")) | |
242 | (with-test-prefix test | |
243 | (load (test-file-name test)))) | |
244 | tests)))) | |
245 | (if (opt 'coverage #f) | |
246 | (let-values (((coverage-data _) | |
247 | (with-code-coverage (the-vm) run-tests))) | |
248 | (let ((out (open-output-file "guile.info"))) | |
249 | (coverage-data->lcov coverage-data out) | |
250 | (close out))) | |
251 | (run-tests))) | |
000ee07f JB |
252 | |
253 | ;; Display the final counts, both to the user and in the log | |
254 | ;; file. | |
255 | (let ((counts ((cadr counter)))) | |
256 | (print-counts counts) | |
257 | (print-counts counts log-port)) | |
258 | ||
1ff7abbe DH |
259 | (close-port log-port) |
260 | (quit global-pass)))))) | |
000ee07f JB |
261 | |
262 | \f | |
263 | ;;; Local Variables: | |
264 | ;;; mode: scheme | |
265 | ;;; End: |