PATCH: More improvements for DejaGnu internal unit tests

This patch adds two procedures for use with the run_tests procedure in 
default_procs.tcl and adjusts the DejaGnu internal unit tests to 
actually use run_tests where applicable.  The new procedures allow 
run_tests to verify return values against regexps and to verify boolean 
return values.  The use of [subst {...}] as the parameter to run_tests 
allows variable and command substitutions to be performed on the list of 
tests in the calling context.

There was a FIXME comment in config.test that has been there since the 
code was imported in 2001 that this patch finally fixes.  ChangeLog-1992 
suggests that it may go all the way back to January 1996 when 
config.test was added.  There is no mention of default_procs.tcl in 
ChangeLog-1992.  I will say:  Fixed after 22 years.  :-)

This also fixes the "getdirs" tests that have actually been failing for 
who-knows-how-long, but were reported as passing because the testing 
logic had the sense of the result from lib_pat_test inverted.  :-)

ChangeLog entries:
----
	* testsuite/runtest.all/default_procs.tcl (lib_bool_test): New.
	(lib_regexp_test): New.
	(lib_pat_test): Brace "if" conditions.
	(lib_pat_test): Remove spurious quotes in debugging output.
	(run_tests): Add support for comments in lists of procedure tests.

	* testsuite/runtest.all/config.test: Adjust to use run_tests
	procedure.  Fixes issue cited in FIXME comment.

	* testsuite/runtest.all/utils.test (getdirs tests): Fix these.
	The old tests had the sense of the return value from lib_pat_test
	inverted and were actually failing but reported "PASS" anyway.
	(find tests, relative_filename tests, runtest_file_p tests):
	Adjust to use run_tests procedure.
----
patch:
----
diff --git a/testsuite/runtest.all/config.test b/testsuite/runtest.all/config.test
index 55af4d4..6443cb4 100644
--- a/testsuite/runtest.all/config.test
+++ b/testsuite/runtest.all/config.test
@@ -28,132 +28,65 @@ set target_cpu i586
 set target_os linux
 set build_triplet i586-unknown-linux
 
-# FIXME: should use run_tests here, but due to Tcl's weird scoping rules, I get
-# problems.
-
 #
 # Tests for a native configuration
 #
-if [isbuild $build_triplet] {
-    puts "PASSED: isbuild, native"
-} else {
-    puts "FAILED: isbuild, native"
-}
-
-if [isbuild $target_cpu-*-$target_os ] {
-    puts "PASSED: isbuild, native regexp"
-} else {
-    puts "FAILED: isbuild, native regexp"
-}
-
-if [isbuild hppa-ibm-macos ] {
-    puts "FAILED: isbuild, native bogus config string"
-} else {
-    puts "PASSED: isbuild, native bogus config string"
-}
-
-# test default argument for isbuild
-if {[isbuild] ne $build_triplet} {
-   puts "FAILED: isbuild with no arguments"
-} else {
-   puts "PASSED: isbuild with no arguments"
-}
-
-# ishost tests
-if [ishost $host_triplet] {
-    puts "PASSED: ishost, native"
-} else {
-    puts "FAILED: ishost, native"
-}
-
-if [ishost $target_cpu-*-$target_os] {
-    puts "PASSED: ishost, native regexp"
-} else {
-    puts "FAILED: ishost, native regexp"
-}
-
-if [ishost hppa-ibm-macos] {
-    puts "FAILED: ishost, native bogus config string"
-} else {
-    puts "PASSED: ishost, native bogus config string"
-}
-
-# test default argument for ishost
-if {[ishost] ne $host_triplet} {
-   puts "FAILED: ishost with no arguments"
-} else {
-   puts "PASSED: ishost with no arguments"
-}
-
-# istarget tests
-if [istarget $target_triplet] {
-    puts "PASSED: istarget, native"
-} else {
-    puts "FAILED: istarget, native"
-}
-
-if [istarget $target_cpu-*-$target_os] {
-    puts "PASSED: istarget, native regexp"
-} else {
-    puts "FAILED: istarget, native regexp"
-}
-
-if [istarget hppa-ibm-macos] {
-    puts "FAILED: istarget, native bogus config string"
-} else {
-    puts "PASSED: istarget, native bogus config string"
-}
-
-# test default argument for istarget
-if {[istarget] ne $target_triplet} {
-   puts "FAILED: istarget with no arguments"
-} else {
-   puts "PASSED: istarget with no arguments"
-}
-
-# native tests
-if [isnative] {
-    puts "PASSED: isnative, native"
-} else {
-    puts "FAILED: isnative, native"
-}
-
-if [is3way] {
-     puts "FAILED: is3way, native"
-} else {
-    puts "PASSED: is3way, native"
+run_tests [subst {
+    { lib_bool_test isbuild {$build_triplet} true
+	"isbuild, native" }
+    { lib_bool_test isbuild {$target_cpu-*-$target_os} true
+	"isbuild, native regexp" }
+    { lib_bool_test isbuild {hppa-ibm-macos} false
+	"isbuild, native bogus config string" }
+
+    { "#" "test default argument for isbuild" }
+    { lib_ret_test isbuild {} $build_triplet
+	"isbuild with no arguments" }
+
+    { "#" "ishost tests" }
+    { lib_bool_test ishost {$host_triplet} true
+	"ishost, native" }
+    { lib_bool_test ishost {$target_cpu-*-$target_os} true
+	"ishost, native regexp" }
+    { lib_bool_test ishost {hppa-ibm-macos} false
+	"ishost, native bogus config string" }
+
+    { "#" "test default argument for ishost" }
+    { lib_ret_test ishost {} $host_triplet
+	"ishost with no arguments" }
+
+    { "#" "istarget tests" }
+    { lib_bool_test istarget {$target_triplet} true
+	"istarget, native" }
+    { lib_bool_test istarget {$target_cpu-*-$target_os} true
+	"istarget, native regexp" }
+    { lib_bool_test istarget {hppa-ibm-macos} false
+	"istarget, native bogus config string" }
+
+    { "#" "test default argument for istarget" }
+    { lib_ret_test istarget {} $target_triplet
+	"istarget with no arguments" }
+}]
+
+run_tests {
+    { lib_bool_test isnative {} true	"isnative, native" }
+    { lib_bool_test is3way {} false	"is3way, native" }
 }
 
 #
 # Tests for a normal cross configuration
 #
 set target_triplet m68k-unknown-elf
-if [isnative] {
-    puts "FAILED: isnative, cross"
-} else {
-    puts "PASSED: isnative, cross"
-}
-
-if [is3way] {
-     puts "FAILED: is3way, cross"
-} else {
-    puts "PASSED: is3way, cross"
+run_tests {
+    { lib_bool_test isnative {} false	"isnative, cross" }
+    { lib_bool_test is3way {} false	"is3way, cross" }
 }
 
 #
 # Tests for a canadian cross configuration
 #
 set host_triplet  i386-unknown-winnt
-if [isnative] {
-    puts "FAILED: isnative, canadian cross"
-} else {
-    puts "PASSED: isnative, canadian cross"
-}
-
-if [is3way] {
-     puts "PASSED: is3way, canadian cross"
-} else {
-    puts "FAILED: is3way, canadian cross"
+run_tests {
+    { lib_bool_test isnative {} false	"isnative, canadian cross" }
+    { lib_bool_test is3way {} true	"is3way, canadian cross" }
 }
-
-
diff --git a/testsuite/runtest.all/default_procs.tcl b/testsuite/runtest.all/default_procs.tcl
index c5e4099..ebb0daf 100644
--- a/testsuite/runtest.all/default_procs.tcl
+++ b/testsuite/runtest.all/default_procs.tcl
@@ -5,12 +5,29 @@ set errno ""
 # this tests a proc for a returned pattern
 proc lib_pat_test { cmd arglist pattern } {
     catch { eval [list $cmd] $arglist } result
-    puts "CMD(lib_pat_test) was: $cmd \"$arglist\""
+    puts "CMD(lib_pat_test) was: $cmd $arglist"
     puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
-    if [ regexp -- "with too many" $result ] {
+
+    if { [regexp -- "with too many" $result] } {
+	return -1
+    }
+    if { [string match "$pattern" $result] } {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# this tests a proc for a returned regexp
+proc lib_regexp_test { cmd arglist pattern } {
+    catch { eval [list $cmd] $arglist } result
+    puts "CMD(lib_pat_test) was: $cmd $arglist"
+    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
+
+    if { [regexp -- "with too many" $result] } {
 	return -1
     }
-    if [ string match "$pattern" $result ] {
+    if { [regexp -- "$pattern" $result] } {
 	return 1
     } else {
 	return 0
@@ -30,6 +47,19 @@ proc lib_ret_test { cmd arglist val } {
     }
 }
 
+# this tests a proc for an expected boolean result
+proc lib_bool_test { cmd arglist val } {
+    catch { eval [list $cmd] $arglist } result
+    puts "CMD(lib_bool_test) was: $cmd $arglist"
+    puts "RESULT(lib_bool_test) was: \"$result\" expecting \"$val\"."
+
+    if { $val } {
+	if { $result } { return 1 } else { return 0 }
+    } else {
+	if { $result } { return 0 } else { return 1 }
+    }
+}
+
 #
 # This runs a standard test for a proc. The list is set up as:
 # |test proc|proc being tested|args|pattern|message|
@@ -37,6 +67,8 @@ proc lib_ret_test { cmd arglist val } {
 #
 proc run_tests { tests } {
     foreach test $tests {
+	# skip comments in test lists
+	if { [lindex $test 0] eq "#" } { continue }
 	set result [eval [lrange $test 0 3]]
 	switch -- $result {
 	    "-1" {
diff --git a/testsuite/runtest.all/utils.test b/testsuite/runtest.all/utils.test
index 22356b4..878e601 100644
--- a/testsuite/runtest.all/utils.test
+++ b/testsuite/runtest.all/utils.test
@@ -24,60 +24,46 @@ if [ file exists $file] {
 
 # Test getdirs:
 #
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all"} "runtest.all/topdir" ] {
-    puts "FAILED: getdirs toplevel, no arguments"
-} else {
-    puts "PASSED: getdirs toplevel, no arguments"
-}
-
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all top*"} "runtest.all/topdir" ] {
-    puts "FAILED: getdirs toplevel, one subdir"
-} else {
-    puts "PASSED: getdirs toplevel, one subdir"
-}
-
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all/topdir"} "subdir1*subdir2" ] {
-    puts "FAILED: getdirs toplevel, two subdirs"
-} else {
-    puts "PASSED: getdirs toplevel, two subdirs"
-}
+run_tests [subst {
+    { lib_pat_test getdirs
+	{[file join ${srcdir} runtest.all]}
+	[file join ${srcdir} runtest.all topdir]
+	"getdirs toplevel, no arguments" }
+    { lib_pat_test getdirs
+	{[file join ${srcdir} runtest.all] "top*"}
+	[file join ${srcdir} runtest.all topdir]
+	"getdirs toplevel, one subdir" }
+    { lib_pat_test getdirs
+	{[file join ${srcdir} runtest.all topdir]}
+	"*topdir*subdir1*topdir*subdir2"
+	"getdirs toplevel, two subdirs" }
+}]
 
 # Test relative_filename:
 #
-if { [relative_filename "/foo/test" "/foo/test/bar/baz" ] == "bar/baz" } {
-    puts "PASSED: relative_filename, simple prefix"
-} else {
-    puts "FAILED: relative_filename, simple prefix"
-}
-if { [relative_filename "/foo/test" "/bar/test" ] == "../../bar/test" } {
-    puts "PASSED: relative_filename, up to top"
-} else {
-    puts "FAILED: relative_filename, up to top"
-}
-if { [relative_filename "/tmp/foo-test" "/tmp/bar/test" ] == "../bar/test" } {
-    puts "PASSED: relative_filename, up one level"
-} else {
-    puts "FAILED: relative_filename, up one level"
-}
-if { [relative_filename "/tmp/foo-test" "/tmp/foo-test" ] == "" } {
-    puts "PASSED: relative_filename, same name"
-} else {
-    puts "FAILED: relative_filename, same name"
+run_tests {
+    { lib_ret_test relative_filename {"/foo/test" "/foo/test/bar/baz"} "bar/baz"
+	"relative_filename, simple prefix" }
+    { lib_ret_test relative_filename {"/foo/test" "/bar/test"} "../../bar/test"
+	"relative_filename, up to top" }
+    { lib_ret_test relative_filename {"/tmp/foo-test" "/tmp/bar/test"} "../bar/test"
+	"relative_filename, up one level" }
+    { lib_ret_test relative_filename {"/tmp/foo-test" "/tmp/foo-test"} ""
+	"relative_filename, same name" }
 }
 
 # Test find:
 #
-if [string match "*/subdir2/subfile2" "[find ${srcdir}/runtest.all/topdir/subdir2 sub*]"] {
-    puts "PASSED: find, only one level deep"
-} else {
-    puts "FAILED: find, only one level deep"
-}
-
-if [regexp ".*/subdir1/subsubdir1/subsubfile1( |$)" "[find ${srcdir}/runtest.all/topdir/subdir1 sub*]"] {
-    puts "PASSED: find, two levels deep"
-} else {
-    puts "FAILED: find, two  levels deep"
-}
+run_tests [subst {
+    { lib_pat_test find
+	{[file join ${srcdir} runtest.all topdir subdir2] "sub*"}
+	"*/subdir2/subfile2"
+	"find, only one level deep" }
+    { lib_regexp_test find
+	{[file join ${srcdir} runtest.all topdir subdir1] "sub*"}
+	".*/subdir1/subsubdir1/subsubfile1( |$)"
+	"find, two levels deep" }
+}]
 
 # Environment varible utility tests.
 #
@@ -215,26 +201,13 @@ file delete -force diff1.txt diff2.txt
 
 # Test runtest_file_p.
 
-if {[runtest_file_p {foo.exp} foo.c]} {
-  pass "runtest_file_p, bare foo.exp matches foo.c"
-} else {
-  fail "runtest_file_p, bare foo.exp matches foo.c"
-}
-
-if {[runtest_file_p {foo.exp foo.c} foo.c]} {
-  pass "runtest_file_p, foo.exp=foo.c matches foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=foo.c matches foo.c"
-}
-
-if {[runtest_file_p {foo.exp foo.*} foo.c]} {
-  pass "runtest_file_p, foo.exp=foo.* matches foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=foo.* matches foo.c"
-}
-
-if {![runtest_file_p {foo.exp bar.*} foo.c]} {
-  pass "runtest_file_p, foo.exp=bar.* excludes foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=bar.* excludes foo.c"
+run_tests {
+    { lib_bool_test runtest_file_p {{foo.exp} foo.c} true
+	"runtest_file_p, bare foo.exp matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp foo.c} foo.c} true
+	"runtest_file_p, foo.exp=foo.c matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp foo.*} foo.c} true
+	"runtest_file_p, foo.exp=foo.* matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp bar.*} foo.c} false
+	"runtest_file_p, foo.exp=bar.* excludes foo.c" }
 }
----


-- Jacob