gdb.exp

gdb-6.0 linux 下的调试工具

#
# start gdb -- start gdb running, default procedure
#
# When running over NFS, particularly if running many simultaneous
# tests on different hosts all using the same server, things can
# get really slow.  Give gdb at least 3 minutes to start up.
#
proc default_gdb_start { } {
    global verbose
    global GDB
    global GDBFLAGS
    global gdb_prompt
    global timeout
    global gdb_spawn_id;

    gdb_stop_suppressing_tests;

    verbose "Spawning $GDB -nw $GDBFLAGS"

    if [info exists gdb_spawn_id] {
	return 0;
    }

    if ![is_remote host] {
	if { [which $GDB] == 0 } then {
	    perror "$GDB does not exist."
	    exit 1
	}
    }
    set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"];
    if { $res < 0 || $res == "" } {
	perror "Spawning $GDB failed."
	return 1;
    }
    gdb_expect 360 {
	-re "\[\r\n\]$gdb_prompt $" {
	    verbose "GDB initialized."
	}
	-re "$gdb_prompt $"	{
	    perror "GDB never initialized."
	    return -1
	}
	timeout	{
	    perror "(timeout) GDB never initialized after 10 seconds."
	    remote_close host;
	    return -1
	}
    }
    set gdb_spawn_id -1;
    # force the height to "unlimited", so no pagers get used

    send_gdb "set height 0\n"
    gdb_expect 10 {
	-re "$gdb_prompt $" { 
	    verbose "Setting height to 0." 2
	}
	timeout {
	    warning "Couldn't set the height to 0"
	}
    }
    # force the width to "unlimited", so no wraparound occurs
    send_gdb "set width 0\n"
    gdb_expect 10 {
	-re "$gdb_prompt $" {
	    verbose "Setting width to 0." 2
	}
	timeout {
	    warning "Couldn't set the width to 0."
	}
    }
    return 0;
}

# Return a 1 for configurations for which we don't even want to try to
# test C++.

proc skip_cplus_tests {} {
    if { [istarget "d10v-*-*"] } {
	return 1
    }
    if { [istarget "h8300-*-*"] } {
	return 1
    }

    # The C++ IO streams are too large for HC11/HC12 and are thus not
    # available.  The gdb C++ tests use them and don't compile.
    if { [istarget "m6811-*-*"] } {
	return 1
    }
    if { [istarget "m6812-*-*"] } {
	return 1
    }
    return 0
}

# Skip all the tests in the file if you are not on an hppa running
# hpux target.

proc skip_hp_tests {} {
    eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ]
    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 {![istarget "hppa*-*-hpux*"] && ![istarget "mips*-*-irix*"]} {
	if { [llength $args] > 0 } {
	    if {$args == "c++"} {
		if { [gdb_compile "${srcdir}/lib/compiler.cc" "${binfile}.ci" preprocess {}] != "" } {
		    perror "Couldn't make ${binfile}.ci file"
		    return 1;
		}
	    }
	} else {
	    if { [gdb_compile "${srcdir}/lib/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}/lib/compiler.cc" "${binfile}.ci"] \
			$args] != "" } {
		    perror "Couldn't make ${binfile}.ci file"
		    return 1;
		}
	    }
	} elseif { $args != "f77" } {
	    if { [eval gdb_preprocess \
		    [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \
		    $args] != "" } {
		perror "Couldn't make ${binfile}.ci file"
		return 1;
	    }
	}
    }
    
    uplevel \#0 { set gcc_compiled 0 }

    if { [llength $args] == 0 || $args != "f77" } {
        source ${binfile}.ci
    }

    # Most compilers will evaluate comparisons and other boolean
    # operations to 0 or 1.
    uplevel \#0 { set true 1 }
    uplevel \#0 { set false 0 }

    uplevel \#0 { set hp_cc_compiler 0 }
    uplevel \#0 { set hp_aCC_compiler 0 }
    uplevel \#0 { set hp_f77_compiler 0 }
    uplevel \#0 { set hp_f90_compiler 0 }
    if { !$gcc_compiled && [istarget "hppa*-*-hpux*"] } {
	# Check for the HP compilers
	set compiler [lindex [split [get_compiler $args] " "] 0]
	catch "exec what $compiler" output
	if [regexp ".*HP aC\\+\\+.*" $output] {
	    uplevel \#0 { set hp_aCC_compiler 1 }
	    # Use of aCC results in boolean results being displayed as
	    # "true" or "false"
	    uplevel \#0 { set true true }
	    uplevel \#0 { set false false }
	} elseif [regexp ".*HP C Compiler.*" $output] {
	    uplevel \#0 { set hp_cc_compiler 1 }
	} elseif [regexp ".*HP-UX f77.*" $output] {
	    uplevel \#0 { set hp_f77_compiler 1 }
	} elseif [regexp ".*HP-UX f90.*" $output] {
	    uplevel \#0 { set hp_f90_compiler 1 }
	}
    }

    return 0;
}

proc get_compiler {args} {
    global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET

    if { [llength $args] == 0 
	 || ([llength $args] == 1 && [lindex $args 0] == "") } {
        set which_compiler "c"
    } else {
        if { $args =="c++" } {
            set which_compiler "c++"
	} elseif { $args =="f77" } {
	    set which_compiler "f77"
        } else {
	    perror "Unknown compiler type supplied to gdb_preprocess"
	    return ""
        }
    }

    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 F77_FOR_TARGET] {
	if {$which_compiler == "f77"} {
	    set compiler $F77_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 == "" } {
		perror "get_compiler: No compiler found"
		return ""
	    }
	}
    }

    return $compiler
}

proc gdb_preprocess {source dest args} {
    set compiler [get_compiler "$args"]
    if { $compiler == "" } {
	return 1
    }

    set cmdline "$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;
}

set gdb_wrapper_initialized 0

proc gdb_wrapper_init { args } {
    global gdb_wrapper_initialized;
    global gdb_wrapper_file;
    global gdb_wrapper_flags;

    if { $gdb_wrapper_initialized == 1 } { return; }

    if {[target_info exists needs_status_wrapper] && \
	    [target_info needs_status_wrapper] != "0"} {
	set result [build_wrapper "testglue.o"];
	if { $result != "" } {
	    set gdb_wrapper_file [lindex $result 0];
	    set gdb_wrapper_flags [lindex $result 1];
	} else {
	    warning "Status wrapper failed to build."
	}
    }
    set gdb_wrapper_initialized 1
}

proc gdb_compile {source dest type options} {
    global GDB_TESTCASE_OPTIONS;
    global gdb_wrapper_file;
    global gdb_wrapper_flags;
    global gdb_wrapper_initialized;

    if [target_info exists gdb_stub] {
	set options2 { "additional_flags=-Dusestubs" }
	lappend options "libs=[target_info gdb_stub]";
	set options [concat $options2 $options]
    }
    if [target_info exists is_vxworks] {
	set options2 { "additional_flags=-Dvxworks" }
	lappend options "libs=[target_info gdb_stub]";
	set options [concat $options2 $options]
    }
    if [info exists GDB_TESTCASE_OPTIONS] {
	lappend options "additional_flags=$GDB_TESTCASE_OPTIONS";
    }
    verbose "options are $options"
    verbose "source is $source $dest $type $options"

    if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init }

    if {[target_info exists needs_status_wrapper] && \
	    [target_info needs_status_wrapper] != "0" && \
	    [info exists gdb_wrapper_file]} {
	lappend options "libs=${gdb_wrapper_file}"
	lappend options "ldflags=${gdb_wrapper_flags}"
    }

    set result [target_compile $source $dest $type $options];
    regsub "\[\r\n\]*$" "$result" "" result;
    regsub "^\[\r\n\]*" "$result" "" result;
    if { $result != "" && [lsearch $options quiet] == -1} {
	clone_output "gdb compile failed, $result"
    }
    return $result;
}


# This is just like gdb_compile, above, except that it tries compiling
# against several different thread libraries, to see which one this
# system has.
proc gdb_compile_pthreads {source dest type options} {
    set built_binfile 0
    set why_msg "unrecognized error"
    foreach lib {-lpthreads -lpthread -lthread} {
        # This kind of wipes out whatever libs the caller may have
        # set.  Or maybe theirs will override ours.  How infelicitous.
        set options_with_lib [concat $options [list libs=$lib quiet]]
        set ccout [gdb_compile $source $dest $type $options_with_lib]
        switch -regexp -- $ccout {
            ".*no posix threads support.*" {
                set why_msg "missing threads include file"
                break
            }
            ".*cannot open -lpthread.*" {
                set why_msg "missing runtime threads library"
            }
            ".*Can't find library for -lpthread.*" {
                set why_msg "missing runtime threads library"
            }
            {^$} {
                pass "successfully compiled posix threads test case"
                set built_binfile 1
                break
            }
        }
    }
    if {!$built_binfile} {
        unsupported "Couldn't compile $source: ${why_msg}"
        return -1
    }
}

# This is just like gdb_compile_pthreads, above, except that we always add the
# objc library for compiling Objective-C programs
proc gdb_compile_objc {source dest type options} {
    set built_binfile 0
    set why_msg "unrecognized error"
    foreach lib {-lobjc -lpthreads -lpthread -lthread solaris} {
        # This kind of wipes out whatever libs the caller may have
        # set.  Or maybe theirs will override ours.  How infelicitous.
        if { $lib == "solaris" } {
            set lib "-lpthread -lposix4"
	}
        if { $lib != "-lobjc" } {
	  set lib "-lobjc $lib"
	}
        set options_with_lib [concat $options [list libs=$lib quiet]]
        set ccout [gdb_compile $source $dest $type $options_with_lib]
        switch -regexp -- $ccout {
            ".*no posix threads support.*" {
                set why_msg "missing threads include file"
                break
            }
            ".*cannot open -lpthread.*" {
                set why_msg "missing runtime threads library"
            }
            ".*Can't find library for -lpthread.*" {
                set why_msg "missing runtime threads library"
            }
            {^$} {
                pass "successfully compiled objc with posix threads test case"
                set built_binfile 1
                break
            }
        }
    }
    if {!$built_binfile} {
        unsupported "Couldn't compile $source: ${why_msg}"
        return -1
    }
}

proc send_gdb { string } {
    global suppress_flag;
    if { $suppress_flag } {
	return "suppressed";
    }
    return [remote_send host "$string"];
}

#
#

proc gdb_expect { args } {
    if { [llength $args] == 2  && [lindex $args 0] != "-re" } {
	set gtimeout [lindex $args 0];
	set expcode [list [lindex $args 1]];
    } else {
	upvar timeout timeout;

	set expcode $args;
	if [target_info exists gdb,timeout] {
	    if [info exists timeout] {
		if { $timeout < [target_info gdb,timeout] } {
		    set gtimeout [target_info gdb,timeout];
		} else {
		    set gtimeout $timeout;
		}
	    } else {
		set gtimeout [target_info gdb,timeout];
	    }
	}

	if ![info exists gtimeout] {
	    global timeout;
	    if [info exists timeout] {
		set gtimeout $timeout;
	    } else {
		# Eeeeew.
		set gtimeout 60;
	    }
	}
    }
    global suppress_flag;
    global remote_suppress_flag;
    if [info exists remote_suppress_flag] {
	set old_val $remote_suppress_flag;
    }
    if [info exists suppress_flag] {
	if { $suppress_flag } {
	    set remote_suppress_flag 1;
	}
    }
    set code [catch \
	{uplevel remote_expect host $gtimeout $expcode} string];
    if [info exists old_val] {
	set remote_suppress_flag $old_val;
    } else {
	if [info exists remote_suppress_flag] {
	    unset remote_suppress_flag;