gdb.exp

这个是LINUX下的GDB调度工具的源码

# 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
}

# Return a 1 if I don't even want to try to test FORTRAN.

proc skip_fortran_tests {} {
    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
}

set compiler_info		"unknown"
set gcc_compiled		0
set hp_cc_compiler		0
set hp_aCC_compiler		0

# Figure out what compiler I am using.
#
# BINFILE is a "compiler information" output file.  This implementation
# does not use BINFILE.
#
# ARGS can be empty or "C++".  If empty, "C" is assumed.
#
# There are several ways to do this, with various problems.
#
# [ gdb_compile -E $ifile -o $binfile.ci ]
# source $binfile.ci
#
#   Single Unix Spec v3 says that "-E -o ..." together are not
#   specified.  And in fact, the native compiler on hp-ux 11 (among
#   others) does not work with "-E -o ...".  Most targets used to do
#   this, and it mostly worked, because it works with gcc.
#
# [ catch "exec $compiler -E $ifile > $binfile.ci" exec_output ]
# source $binfile.ci
# 
#   This avoids the problem with -E and -o together.  This almost works
#   if the build machine is the same as the host machine, which is
#   usually true of the targets which are not gcc.  But this code does
#   not figure which compiler to call, and it always ends up using the C
#   compiler.  Not good for setting hp_aCC_compiler.  Targets
#   hppa*-*-hpux* and mips*-*-irix* used to do this.
#
# [ gdb_compile -E $ifile > $binfile.ci ]
# source $binfile.ci
#
#   dejagnu target_compile says that it supports output redirection,
#   but the code is completely different from the normal path and I
#   don't want to sweep the mines from that path.  So I didn't even try
#   this.
#
# set cppout [ gdb_compile $ifile "" preprocess $args quiet ]
# eval $cppout
#
#   I actually do this for all targets now.  gdb_compile runs the right
#   compiler, and TCL captures the output, and I eval the output.
#
#   Unfortunately, expect logs the output of the command as it goes by,
#   and dejagnu helpfully prints a second copy of it right afterwards.
#   So I turn off expect logging for a moment.
#   
# [ gdb_compile $ifile $ciexe_file executable $args ]
# [ remote_exec $ciexe_file ]
# [ source $ci_file.out ]
#
#   I could give up on -E and just do this.
#   I didn't get desperate enough to try this.
#
# -- chastain 2004-01-06

proc get_compiler_info {binfile args} {
    # For compiler.c and compiler.cc
    global srcdir

    # I am going to play with the log to keep noise out.
    global outdir
    global tool

    # These come from compiler.c or compiler.cc
    global compiler_info

    # Legacy global data symbols.
    global gcc_compiled
    global hp_cc_compiler
    global hp_aCC_compiler

    # Choose which file to preprocess.
    set ifile "${srcdir}/lib/compiler.c"
    if { [llength $args] > 0 && [lindex $args 0] == "c++" } {
	set ifile "${srcdir}/lib/compiler.cc"
    }

    # Run $ifile through the right preprocessor.
    # Toggle gdb.log to keep the compiler output out of the log.
    log_file
    set cppout [ gdb_compile "${ifile}" "" preprocess [list "$args" quiet] ]
    log_file -a "$outdir/$tool.log" 

    # Eval the output.
    set unknown 0
    foreach cppline [ split "$cppout" "\n" ] {
	if { [ regexp "^#" "$cppline" ] } {
	    # line marker
	} elseif { [ regexp "^\[\n\r\t \]*$" "$cppline" ] } {
	    # blank line
	} elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } {
	    # eval this line
	    verbose "get_compiler_info: $cppline" 2
	    eval "$cppline"
	} else {
	    # unknown line
	    verbose -log "get_compiler_info: $cppline"
	    set unknown 1
	}
    }

    # Reset to unknown compiler if any diagnostics happened.
    if { $unknown } {
	set compiler_info "unknown"
    }

    # Set the legacy symbols.
    set gcc_compiled     0
    set hp_cc_compiler   0
    set hp_aCC_compiler  0
    if { [regexp "^gcc-1-" "$compiler_info" ] } { set gcc_compiled 1 }
    if { [regexp "^gcc-2-" "$compiler_info" ] } { set gcc_compiled 2 }
    if { [regexp "^gcc-3-" "$compiler_info" ] } { set gcc_compiled 3 }
    if { [regexp "^gcc-4-" "$compiler_info" ] } { set gcc_compiled 4 }
    if { [regexp "^gcc-5-" "$compiler_info" ] } { set gcc_compiled 5 }
    if { [regexp "^hpcc-"  "$compiler_info" ] } { set hp_cc_compiler 1 }
    if { [regexp "^hpacc-" "$compiler_info" ] } { set hp_aCC_compiler 1 }

    # Log what happened.
    verbose -log "get_compiler_info: $compiler_info"

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

    # Use of aCC results in boolean results being displayed as
    # "true" or "false"
    if { $hp_aCC_compiler } {
      uplevel \#0 { set true true }
      uplevel \#0 { set false false }
    }

    return 0;
}

proc test_compiler_info { compiler } {
    global compiler_info
    return [string match $compiler $compiler_info]
}

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;
	}
    }

    if {$code == 1} {
        global errorInfo errorCode;

	return -code error -errorinfo $errorInfo -errorcode $errorCode $string
    } elseif {$code == 2} {
	return -code return $string
    } elseif {$code == 3} {
	return
    } elseif {$code > 4} {
	return -code $code $string
    }
}

# 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.
# SENTINEL: Is the terminal pattern indicating that output has finished.
# LIST: is the sequence of outputs to match.
# If the sentinel is recognized early, it is considered an error.
#
# Returns:
#    1 if the test failed,
#    0 if the test passes,
#   -1 if there was an internal error.
#
proc gdb_expect_list {test sentinel list} {
    global gdb_prompt
    global suppress_flag
    set index 0
    set ok 1
    if { $suppress_flag } {
	set ok 0
	unresolved "${test}"
    }
    while { ${index} < [llength ${list}] } {
	set pattern [lindex ${list} ${index}]
        set index [expr ${index} + 1]
	if { ${index} == [llength ${list}] } {
	    if { ${ok} } {
		gdb_expect {
		    -re "${pattern}${sentinel}" {
			# pass "${test}, pattern ${index} + sentinel"
		    }
		    -re "${sentinel}" {
			fail "${test} (pattern ${index} + sentinel)"
			set ok 0
		    }
		    -re ".*A problem internal to GDB has been detected" {
			fail "${test} (GDB internal error)"
			set ok 0
			gdb_internal_error_resync
		    }
		    timeout {
			fail "${test} (pattern ${index} + sentinel) (timeout)"
			set ok 0
		    }
		}
	    } else {
		# unresolved "${test}, pattern ${index} + sentinel"
	    }
	} else {
	    if { ${ok} } {
		gdb_expect {
		    -re "${pattern}" {
			# pass "${test}, pattern ${index}"
		    }
		    -re "${sentinel}" {
			fail "${test} (pattern ${index})"
			set ok 0
		    }
		    -re ".*A problem internal to GDB has been detected" {