* Added Thien-Thi Nguyen's patch to support "make check".

1 files changed, 72 insertions, 26 deletions

diff --git a/test-suite/guile-test b/test-suite/guile-test
index faa9a1c13..20591a637 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -1,4 +1,4 @@
-#!/usr/local/bin/guile \
+#!/home/dirk/bin/guile \
 -e main -s
 !#
 
@@ -23,34 +23,48 @@
 ;;;; Boston, MA 02111-1307 USA
 
 
-
-;;;; Usage: guile-test [--log-file LOG] [TEST ...]
+;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
 ;;;;
 ;;;; Run tests from the Guile test suite.  Report failures and
 ;;;; unexpected passes to the standard output, along with a summary of
 ;;;; all the results.  Record each reported test outcome in the log
-;;;; file, `guile.log'.
+;;;; file, `guile.log'.  The exit status is #f if any of the tests
+;;;; fail or pass unexpectedly.
 ;;;;
 ;;;; Normally, guile-test scans the test directory, and executes all
 ;;;; files whose names end in `.test'.  (It assumes they contain
 ;;;; Scheme code.)  However, you can have it execute specific tests by
 ;;;; listing their filenames on the command line.
 ;;;;
+;;;; The option '--test-suite' can be given to specify the test
+;;;; directory.  If no such option is given, the test directory is
+;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
+;;;; otherwise a default directory that is hardcoded in this file is 
+;;;; used (see "Installation" below).
+;;;;
 ;;;; If present, the `--log-file LOG' option tells `guile-test' to put
 ;;;; the log output in a file named LOG.
 ;;;;
+;;;; If present, the '--debug' option will enable a debugging mode.
+;;;;
+;;;;
 ;;;; Installation:
 ;;;;
-;;;; Change the #! line at the top of this script to point at the
-;;;; Guile interpreter you want to test.  Edit `test-suite/paths.scm'
-;;;; so that datadir points to the parent directory of the `tests' tree.
+;;;; If you change the #! line at the top of this script to point at
+;;;; the Guile interpreter you want to test, you can call this script
+;;;; as an executable instead of having to pass it as a parameter to
+;;;; guile via "guile -e main -s guile-test".  Further, you can edit
+;;;; the definition of default-test-suite to point to the parent
+;;;; directory of the `tests' tree, which makes it unnecessary to set
+;;;; the environment variable `TEST_SUITE_DIR'.
+;;;;
 ;;;;
 ;;;; Shortcomings:
 ;;;;
 ;;;; At the moment, due to a simple-minded implementation, test files
 ;;;; must live in the test directory, and you must specify their names
 ;;;; relative to the top of the test directory.  If you want to send
-;;;; me a patche that fixes this, but still leaves sane test names in
+;;;; me a patch that fixes this, but still leaves sane test names in
 ;;;; the log file, that would be great.  At the moment, all the tests
 ;;;; I care about are in the test directory, though.
 ;;;;
@@ -59,14 +73,25 @@
 ;;;; change which Guile interpreter you're testing, you need to edit
 ;;;; the #! line at the top of this file, which is stupid.
 
+
+;;; User configurable settings:
+(define default-test-suite
+  (string-append (getenv "HOME") "/guile-core/test-suite"))
+
+
 (use-modules (test-suite lib)
-	     (test-suite paths)
 	     (ice-9 getopt-long)
 	     (ice-9 and-let*))
 
 
 ;;; General utilities, that probably should be in a library somewhere.
 
+;;; Enable debugging
+(define (enable-debug-mode)
+  (write-line %load-path)
+  (set! %load-verbosely #t)
+  (debug-enable 'backtrace 'debug))
+
 ;;; Traverse the directory tree at ROOT, applying F to the name of
 ;;; each file in the tree, including ROOT itself.  For a subdirectory
 ;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
@@ -93,18 +118,16 @@
 		  (visit (string-append root "/" entry))
 		  (loop))))))))))
 
-
 
 ;;; The test driver.
 
-(define test-root (in-vicinity datadir "tests"))
-
-(define (test-file-name test)
-  (in-vicinity test-root test))
+(define (test-file-name test-dir test)
+  (in-vicinity test-dir test))
 
 ;;; Return a list of all the test files in the test tree.
-(define (enumerate-tests)
-  (let ((root-len (+ 1 (string-length test-root)))
+(define (enumerate-tests test-dir)
+  
+  (let ((root-len (+ 1 (string-length test-dir)))
 	(tests '()))
     (for-each-file (lambda (file)
 		     (if (has-suffix? file ".test")
@@ -112,7 +135,7 @@
 				(substring file root-len)))
 			   (set! tests (cons short-name tests))))
 		     #t)
-		   test-root)
+		   test-dir)
 
     ;; for-each-file presents the files in whatever order it finds
     ;; them in the directory.  We sort them here, so they'll always
@@ -122,29 +145,51 @@
 
 (define (main args)
   (let ((options (getopt-long args
-			      `((log-file (single-char #\l)
-					  (value #t))))))
+			      `((test-suite 
+				 (single-char #\t)
+				 (value #t))
+				(log-file 
+				 (single-char #\l)
+				 (value #t))
+				(debug 
+				 (single-char #\d))))))
     (define (opt tag default)
       (let ((pair (assq tag options)))
 	(if pair (cdr pair) default)))
-    (let ((log-file (opt 'log-file "guile.log"))
-	  (tests (let ((foo (opt '() '())))
-		   (if (null? foo) (enumerate-tests)
-		       foo))))
+
+    (if (opt 'debug #f)
+	(enable-debug-mode))
+
+    (let* ((test-suite
+	    (or (opt 'test-suite #f)
+		(getenv "TEST_SUITE_DIR")
+		default-test-suite))
+	   (tests 
+	    (let ((foo (opt '() '())))
+	      (if (null? foo) 
+		  (enumerate-tests test-suite)
+		  foo)))
+	   (log-file 
+	    (opt 'log-file "guile.log")))
 
       ;; Open the log file.
       (let ((log-port (open-output-file log-file)))
 
 	;; Register some reporters.
-	(let ((counter (make-count-reporter)))
+	(let ((global-pass #t)
+	      (counter (make-count-reporter)))
 	  (register-reporter (car counter))
 	  (register-reporter (make-log-reporter log-port))
 	  (register-reporter user-reporter)
+	  (register-reporter (lambda results
+			       (case (car results)
+				 ((fail upass unresolved error)
+				  (set! global-pass #f)))))
 
 	  ;; Run the tests.
 	  (for-each (lambda (test)
 		      (with-test-prefix test
-			(load (test-file-name test))))
+			(load (test-file-name test-suite test))))
 		    tests)
 
 	  ;; Display the final counts, both to the user and in the log
@@ -153,7 +198,8 @@
 	    (print-counts counts)
 	    (print-counts counts log-port))
 
-	  (close-port log-port))))))
+	  (close-port log-port)
+	  (quit global-pass))))))
 
 
 ;;; Local Variables: