This is the merge of the Itcl3.0 gdbtk development branch into the

trunk.  To build it, you will have to do update -dP in the itcl
directory, and update tcl, tk, tix and libgui as well.

1 files changed, 222 insertions, 5 deletions

diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 3103f86..b2f3ba9 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -101,7 +101,7 @@ proc gdb_unload {} {
     global gdb_prompt
     send_gdb "file\n"
     gdb_expect 60 {
-	-re "No exec file now\[^\r\n\]*\[\r\n\]" { exp_continue }
+	-re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
 	-re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
 	-re "A program is being debugged already..*Kill it.*y or n. $"\
 	    { send_gdb "y\n"
@@ -406,6 +406,13 @@ proc gdb_test { args } {
 	}
     }
     gdb_expect $tmt {
+	 -re "\\*\\*\\* DOSEXIT code.*" {
+	     if { $message != "" } {
+		 fail "$message";
+	     }
+	     gdb_suppress_entire_file "GDB died";
+	     return -1;
+	 }
 	 -re "Ending remote debugging.*$gdb_prompt$" {
 	    if ![isnative] then {
 		warning "Can`t communicate to remote target."
@@ -827,23 +834,128 @@ proc skip_chill_tests {} {
     return $skip_chill
 }
 
-proc get_compiler_info {binfile} {
+# skip all the tests in the file if you are not on an hppa running hpux target.
+# and you compiled with gcc
+proc skip_hp_tests {gcc_used} {
+  #  if ![info exists do_hp_tests] {
+  #	return 1;
+  #  }
+    eval set skip_hp [expr ![isnative] || ![istarget "hppa*-*-hpux*"] || $gcc_used!=0 ]
+    verbose "Skip hp tests is $skip_hp"
+    return $skip_hp
+}
+
+proc get_compiler_info {binfile args} {
     # Create and source the file that provides information about the compiler
     # used to compile the test case.
+    # Compiler_type can be null or c++. If null we assume c.
     global srcdir
     global subdir
     # These two come from compiler.c.
     global signed_keyword_not_used
     global gcc_compiled
 
-    if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
-	perror "Couldn't make ${binfile}.ci file"
-	return 1;
+    if {![istarget "hppa*-*-hpux*"]} {
+	if { [llength $args] > 0 } {
+	    if {$args == "c++"} {
+	if { [gdb_compile "${srcdir}/${subdir}/compiler.cc" "${binfile}.ci" preprocess {}] != "" } {
+		    perror "Couldn't make ${binfile}.ci file"
+		    return 1;
+		}
+	    }
+	} else {
+	    if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
+		perror "Couldn't make ${binfile}.ci file"
+		return 1;
+	    }
+	}
+    } else {
+	if { [llength $args] > 0 } {
+	    if {$args == "c++"} {
+		if { [eval gdb_preprocess \
+			[list "${srcdir}/${subdir}/compiler.cc" "${binfile}.ci"] \
+			$args] != "" } {
+		    perror "Couldn't make ${binfile}.ci file"
+		    return 1;
+		}
+	    }
+	} else {
+	    if { [eval gdb_preprocess \
+		    [list "${srcdir}/${subdir}/compiler.c" "${binfile}.ci"] \
+		    $args] != "" } {
+		perror "Couldn't make ${binfile}.ci file"
+		return 1;
+	    }
+	}
     }
+    
     source ${binfile}.ci
     return 0;
 }
 
+proc gdb_preprocess {source dest args} {
+    global CC_FOR_TARGET
+    global CXX_FOR_TARGET
+
+    if { [llength $args] == 0 } {
+        set which_compiler "c"
+    } else {
+        if { $args =="c++" } {
+            set which_compiler "c++"
+        } else {
+	    perror "Unknown compiler type supplied to gdb_preprocess"
+	    return 1;
+        }
+    }
+
+    if [info exists CC_FOR_TARGET] {
+	if { $which_compiler == "c"} {
+	    set compiler $CC_FOR_TARGET;
+	}
+    }
+ 
+    if [info exists CXX_FOR_TARGET] {
+	if { $which_compiler == "c++"} {
+	    set compiler $CXX_FOR_TARGET;
+	}
+    }
+
+    if { ![info exists compiler] } {
+        if { $which_compiler == "c" } {
+	    if {[info exists CC]} {
+		set compiler $CC;
+	    }
+	}
+        if { $which_compiler == "c++" } {
+	    if {[info exists CXX]} {
+		set compiler $CXX;
+	    }
+	}
+	if {![info exists compiler]} {
+	    set compiler [board_info [target_info name] compiler];
+	    if { $compiler == "" } {
+		puts "default_target_compile: No compiler to compile with";
+		return "default_target_compile: No compiler to compile with";
+	    }
+	}
+    }
+
+    set cmdline "$compiler -E $source > $dest"
+
+    puts "Invoking $compiler -E $source > $dest"
+    verbose "Invoking $compiler -E $source > $dest"
+    verbose -log "Executing on local host: $cmdline" 2
+    set status [catch "exec ${cmdline}" exec_output]
+
+    set result [prune_warnings $exec_output]
+    regsub "\[\r\n\]*$" "$result" "" result;
+    regsub "^\[\r\n\]*" "$result" "" result;
+    if { $result != "" } {
+        clone_output "gdb compile failed, $result"
+    }
+    return $result;
+}
+
 proc gdb_compile {source dest type options} {
     global GDB_TESTCASE_OPTIONS;
 
@@ -862,6 +974,7 @@ proc gdb_compile {source dest type options} {
     }
     verbose "options are $options"
     verbose "source is $source $dest $type $options"
+
     set result [target_compile $source $dest $type $options];
     regsub "\[\r\n\]*$" "$result" "" result;
     regsub "^\[\r\n\]*" "$result" "" result;
@@ -1154,3 +1267,107 @@ proc gdb_step_for_stub { } {
 	default {}
     }
 }
+
+# start-sanitize-gdbtk
+# 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 [file join $srcdir .. gdbtcl2]
+  set env(GDBTK_LIBRARY) [pwd]
+  cd [file join $srcdir .. .. tcl library]
+  set env(TCL_LIBRARY) [pwd]
+  cd [file join $srcdir .. .. tk library]
+  set env(TK_LIBRARY) [pwd]
+  cd [file join $srcdir .. .. tix library]
+  set env(TIX_LIBRARY) [pwd]
+  cd [file join $srcdir .. .. itcl itcl library]
+  set env(ITCL_LIBRARY) [pwd]
+  cd [file join .. $srcdir .. .. libgui library]
+  set env(CYGNUS_GUI_LIBRARY) [pwd]
+  cd $wd
+  cd [file join $srcdir $subdir]
+  set env(DEFS) [file join [pwd] defs]
+  cd $wd
+  cd [file join $objdir $subdir]
+  set env(OBJDIR) [pwd]
+  cd $wd
+  cd $srcdir
+  set env(SRCDIR) [pwd]
+  cd $wd
+  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)"
+      }
+    }
+  }
+}
+# end-sanitize-gdbtk