X-Git-Url: http://drtracing.org/?a=blobdiff_plain;f=gdb%2Ftestsuite%2Flib%2Fgdb.exp;h=c7990d1c7f5d50f7374d9b35c1002d2d8ea6d66d;hb=930764990dffdc53fe322f7db4ac952fd5d0446f;hp=a1a839a0baaf26f975f590067f7bdc9a1abe0110;hpb=4ce44c668ddc0a909c3f081d98c68bea90a93af9;p=deliverable%2Fbinutils-gdb.git

diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index a1a839a0ba..c7990d1c7f 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -63,6 +63,16 @@ if ![info exists gdb_prompt] then {
     set gdb_prompt "\[(\]gdb\[)\]"
 }
 
+# Needed for some tests under Cygwin.
+global EXEEXT
+global env
+
+if ![info exists env(EXEEXT)] {
+    set EXEEXT ""
+} else {
+    set EXEEXT $env(EXEEXT)
+}
+
 ### Only procedures should come after this point.
 
 #
@@ -1189,7 +1199,7 @@ proc gdb_expect { args } {
     }
 }
 
-# gdb_expect_list MESSAGE SENTINAL LIST -- expect a sequence of outputs
+# gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs
 #
 # Check for long sequence of output by parts.
 # MESSAGE: is the test message to be printed with the test success/fail.
@@ -1202,7 +1212,7 @@ proc gdb_expect { args } {
 #    0 if the test passes,
 #   -1 if there was an internal error.
 #
-proc gdb_expect_list {test sentinal list} {
+proc gdb_expect_list {test sentinel list} {
     global gdb_prompt
     global suppress_flag
     set index 0
@@ -1216,16 +1226,20 @@ proc gdb_expect_list {test sentinal list} {
 	if { ${index} == [llength ${list}] } {
 	    if { ${ok} } {
 		gdb_expect {
-		    -re "${pattern}${sentinal}" {
-			pass "${test}, pattern ${index} + sentinal"
+		    -re "${pattern}${sentinel}" {
+			pass "${test}, pattern ${index} + sentinel"
+		    }
+		    -re "${sentinel}" {
+			fail "${test}, pattern ${index} + sentinel"
+			set ok 0
 		    }
 		    timeout {
-			fail "${test}, pattern ${index} + sentinal (timeout)"
+			fail "${test}, pattern ${index} + sentinel (timeout)"
 			set ok 0
 		    }
 		}
 	    } else {
-		fail "${test}, pattern ${index} + sentinal"
+		unresolved "${test}, pattern ${index} + sentinel"
 	    }
 	} else {
 	    if { ${ok} } {
@@ -1233,7 +1247,7 @@ proc gdb_expect_list {test sentinal list} {
 		    -re "${pattern}" {
 			pass "${test}, pattern ${index}"
 		    }
-		    -re "${sentinal}" {
+		    -re "${sentinel}" {
 			fail "${test}, pattern ${index}"
 			set ok 0
 		    }
@@ -1243,7 +1257,7 @@ proc gdb_expect_list {test sentinal list} {
 		    }
 		}
 	    } else {
-		fail "${test}, pattern ${index}"
+		unresolved "${test}, pattern ${index}"
 	    }
 	}
     }
@@ -1580,3 +1594,133 @@ proc rerun_to_main {} {
   }
 }
 
+# From dejagnu:
+# srcdir = testsuite src dir (e.g., devo/gdb/testsuite)
+# objdir = testsuite obj dir (e.g., gdb/testsuite)
+# subdir = subdir of testsuite (e.g., gdb.gdbtk)
+#
+# To gdbtk:
+# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs)
+# env(SRCDIR)=directory containing the test code (e.g., *.test)
+# env(OBJDIR)=directory which contains any executables
+#            (e.g., gdb/testsuite/gdb.gdbtk)
+proc gdbtk_start {test} {
+  global verbose
+  global GDB
+  global GDBFLAGS
+  global env srcdir subdir objdir
+
+  gdb_stop_suppressing_tests;
+
+  verbose "Starting $GDB -nx -q --tclcommand=$test"
+
+  set real_test [which $test]
+  if {$real_test == 0} {
+    perror "$test is not found"
+    exit 1
+  }
+
+  if {![is_remote host]} {
+    if { [which $GDB] == 0 } {
+      perror "$GDB does not exist."
+      exit 1
+    }
+  }
+
+  
+  set wd [pwd]
+  cd $srcdir
+  set abs_srcdir [pwd]
+  cd [file join $abs_srcdir .. gdbtk library]
+  set env(GDBTK_LIBRARY) [pwd]
+  cd [file join $abs_srcdir .. .. tcl library]
+  set env(TCL_LIBRARY) [pwd]
+  cd [file join $abs_srcdir .. .. tk library]
+  set env(TK_LIBRARY) [pwd]
+  cd [file join $abs_srcdir .. .. tix library]
+  set env(TIX_LIBRARY) [pwd]
+  cd [file join $abs_srcdir .. .. itcl itcl library]
+  set env(ITCL_LIBRARY) [pwd]
+  cd [file join .. $abs_srcdir .. .. libgui library]
+  set env(CYGNUS_GUI_LIBRARY) [pwd]
+  cd $wd
+  cd [file join $abs_srcdir $subdir]
+  set env(DEFS) [file join [pwd] defs]
+  cd $wd
+  cd [file join $objdir $subdir]
+  set env(OBJDIR) [pwd]
+  cd $wd
+
+  set env(SRCDIR) $abs_srcdir
+  set env(GDBTK_VERBOSE) 1
+  set env(GDBTK_LOGFILE) [file join $objdir gdb.log]
+  set env(GDBTK_TEST_RUNNING) 1
+  set err [catch {exec $GDB -nx -q --tclcommand=$test} res]
+  if { $err } {
+    perror "Execing $GDB failed: $res"
+    exit 1;
+  }
+  return $res
+}
+
+# gdbtk tests call this function to print out the results of the
+# tests. The argument is a proper list of lists of the form:
+# {status name description msg}. All of these things typically
+# come from the testsuite harness.
+proc gdbtk_analyze_results {results} {
+  foreach test $results {
+    set status [lindex $test 0]
+    set name [lindex $test 1]
+    set description [lindex $test 2]
+    set msg [lindex $test 3]
+
+    switch $status {
+      PASS {
+	pass "$description ($name)"
+      }
+
+      FAIL {
+	fail "$description ($name)"
+      }
+
+      ERROR {
+	perror "$name"
+      }
+
+      XFAIL {
+	xfail "$description ($name)"
+      }
+
+      XPASS {
+	xpass "$description ($name)"
+      }
+    }
+  }
+}
+
+# Print a message and return true if a test should be skipped
+# due to lack of floating point suport.
+
+proc gdb_skip_float_test { msg } {
+    if [target_info exists gdb,skip_float_tests] {
+	verbose "Skipping test '$msg': no float tests.";
+	return 1;
+    }
+    return 0;
+}
+
+# Print a message and return true if a test should be skipped
+# due to lack of stdio support.
+
+proc gdb_skip_stdio_test { msg } {
+    if [target_info exists gdb,noinferiorio] {
+	verbose "Skipping test '$msg': no inferior i/o.";
+	return 1;
+    }
+    return 0;
+}
+
+proc gdb_skip_bogus_test { msg } {
+    return 0;
+}
+