gdb.exp

lwip在ucos上的移植

    }
    set sendthis [lindex $args 0]
    if $verbose>2 then {
	send_user "Sending \"$sendthis\" to gdb\n"
	send_user "Looking to match \"$expectthis\"\n"
    }
    send_gdb "$sendthis\n"
    #FIXME: Should add timeout as parameter.
    gdb_expect {
	-re "A .* in expression.*\\.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "Invalid syntax in expression.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "Junk after end of expression.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "Invalid number.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "Invalid character constant.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "No symbol table is loaded.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "No symbol .* in current context.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re "$expectthis.*$gdb_prompt $" {
	    pass "reject $sendthis"
	    return 1
	}
	-re ".*$gdb_prompt $" {
	    fail "reject $sendthis"
	    return 1
	}
	default {
	    fail "reject $sendthis (eof or timeout)"
	    return 0
	}
    }
}

# Given an input string, adds backslashes as needed to create a
# regexp that will match the string.

proc string_to_regexp {str} {
    set result $str
    regsub -all {[]*+.|()^$\[]} $str {\\&} result
    return $result
}

# Same as gdb_test, but the second parameter is not a regexp,
# but a string that must match exactly.

proc gdb_test_exact { args } {
    upvar timeout timeout

    set command [lindex $args 0]

    # This applies a special meaning to a null string pattern.  Without
    # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
    # messages from commands that should have no output except a new
    # prompt.  With this, only results of a null string will match a null
    # string pattern.

    set pattern [lindex $args 1]
    if [string match $pattern ""] {
	set pattern [string_to_regexp [lindex $args 0]]
    } else {
	set pattern [string_to_regexp [lindex $args 1]]
    }

    # It is most natural to write the pattern argument with only
    # embedded \n's, especially if you are trying to avoid Tcl quoting
    # problems.  But gdb_expect really wants to see \r\n in patterns.  So
    # transform the pattern here.  First transform \r\n back to \n, in
    # case some users of gdb_test_exact already do the right thing.
    regsub -all "\r\n" $pattern "\n" pattern
    regsub -all "\n" $pattern "\r\n" pattern
    if [llength $args]==3 then {
	set message [lindex $args 2]
    } else {
	set message $command
    }

    return [gdb_test $command $pattern $message]
}

proc gdb_reinitialize_dir { subdir } {
    global gdb_prompt

    if [is_remote host] {
	return "";
    }
    send_gdb "dir\n"
    gdb_expect 60 {
	-re "Reinitialize source path to empty.*y or n. " {
	    send_gdb "y\n"
	    gdb_expect 60 {
		-re "Source directories searched.*$gdb_prompt $" {
		    send_gdb "dir $subdir\n"
		    gdb_expect 60 {
			-re "Source directories searched.*$gdb_prompt $" {
			    verbose "Dir set to $subdir"
			}
			-re "$gdb_prompt $" {
			    perror "Dir \"$subdir\" failed."
			}
		    }
		}
		-re "$gdb_prompt $" {
		    perror "Dir \"$subdir\" failed."
		}
	    }
	}
	-re "$gdb_prompt $" {
	    perror "Dir \"$subdir\" failed."
	}
    }
}

#
# gdb_exit -- exit the GDB, killing the target program if necessary
#
proc default_gdb_exit {} {
    global GDB
    global GDBFLAGS
    global verbose
    global gdb_spawn_id;

    gdb_stop_suppressing_tests;

    if ![info exists gdb_spawn_id] {
	return;
    }

    verbose "Quitting $GDB $GDBFLAGS"

    if { [is_remote host] && [board_info host exists fileid] } {
	send_gdb "quit\n";
	gdb_expect 10 {
	    -re "y or n" {
		send_gdb "y\n";
		exp_continue;
	    }
	    -re "DOSEXIT code" { }
	    default { }
	}
    }

    if ![is_remote host] {
	remote_close host;
    }
    unset gdb_spawn_id
}

#
# load a file into the debugger.
# return a -1 if anything goes wrong.
#
proc gdb_file_cmd { arg } {
    global verbose
    global loadpath
    global loadfile
    global GDB
    global gdb_prompt
    upvar timeout timeout

    if [is_remote host] {
	set arg [remote_download host $arg];
	if { $arg == "" } {
	    error "download failed"
	    return -1;
	}
    }

    send_gdb "file $arg\n"
    gdb_expect 120 {
        -re "Reading symbols from.*done.*$gdb_prompt $" {
            verbose "\t\tLoaded $arg into the $GDB"
            return 0
        }
        -re "has no symbol-table.*$gdb_prompt $" {
            perror "$arg wasn't compiled with \"-g\""
            return -1
        }
        -re "A program is being debugged already.*Kill it.*y or n. $" {
            send_gdb "y\n"
                verbose "\t\tKilling previous program being debugged"
            exp_continue
        }
        -re "Load new symbol table from \".*\".*y or n. $" {
            send_gdb "y\n"
            gdb_expect 120 {
                -re "Reading symbols from.*done.*$gdb_prompt $" {
                    verbose "\t\tLoaded $arg with new symbol table into $GDB"
                    return 0
                }
                timeout {
                    perror "(timeout) Couldn't load $arg, other program already loaded."
                    return -1
                }
            }
	}
        -re "No such file or directory.*$gdb_prompt $" {
            perror "($arg) No such file or directory\n"
            return -1
        }
        -re "$gdb_prompt $" {
            perror "couldn't load $arg into $GDB."
            return -1
            }
        timeout {
            perror "couldn't load $arg into $GDB (timed out)."
            return -1
        }
        eof {
            # This is an attempt to detect a core dump, but seems not to
            # work.  Perhaps we need to match .* followed by eof, in which
            # gdb_expect does not seem to have a way to do that.
            perror "couldn't load $arg into $GDB (end of file)."
            return -1
        }
    }
}

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

# * For crosses, the CHILL runtime doesn't build because it can't find
# setjmp.h, stdio.h, etc.
# * For AIX (as of 16 Mar 95), (a) there is no language code for
# CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
# does not get along with AIX's too-clever linker.
# * On Irix5, there is a bug whereby set of bool, etc., don't get
# TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
# work with stub types.
# Lots of things seem to fail on the PA, and since it's not a supported
# chill target at the moment, don't run the chill tests.

proc skip_chill_tests {} {
    if ![info exists do_chill_tests] {
	return 1;
    }
    eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
    verbose "Skip chill tests is $skip_chill"
    return $skip_chill
}

# 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*"]} {
	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;
}

proc gdb_compile {source dest type options} {
    global GDB_TESTCASE_OPTIONS;

    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"

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

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

#
#

proc gdb_expect { args } {
    # allow -notransfer expect flag specification,
    # used by gdb_test routine for multi-line commands.
    # packed with gtimeout when fed to remote_expect routine,
    # which is a hack but due to what looks like a res and orig
    # parsing problem in remote_expect routine (dejagnu/lib/remote.exp):
    # what's fed into res is not removed from orig.
    # - guo
    if { [lindex $args 0] == "-notransfer" } {
	set notransfer -notransfer;
	set args [lrange $args 1 end];
    } else {
	set notransfer "";
    }