gdb.exp

lwip在ucos上的移植

    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 $notransfer" $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
    }
    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
		    }
		    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
		    }
		    timeout {
			fail "${test}, pattern ${index} (timeout)"
			set ok 0
		    }
		}
	    } else {
		unresolved "${test}, pattern ${index}"
	    }
	}
    }
    if { ${ok} } {
	return 0
    } else {
	return 1
    }
}

#
#
proc gdb_suppress_entire_file { reason } {
    global suppress_flag;

    warning "$reason\n";
    set suppress_flag -1;
}

#
# Set suppress_flag, which will cause all subsequent calls to send_gdb and
# gdb_expect to fail immediately (until the next call to 
# gdb_stop_suppressing_tests).
#
proc gdb_suppress_tests { args } {
    global suppress_flag;

    return;  # fnf - disable pending review of results where
             # testsuite ran better without this
    incr suppress_flag;

    if { $suppress_flag == 1 } {
	if { [llength $args] > 0 } {
	    warning "[lindex $args 0]\n";
	} else {
	    warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n";
	}
    }
}

#
# Clear suppress_flag.
#
proc gdb_stop_suppressing_tests { } {
    global suppress_flag;

    if [info exists suppress_flag] {
	if { $suppress_flag > 0 } {
	    set suppress_flag 0;
	    clone_output "Tests restarted.\n";
	}
    } else {
	set suppress_flag 0;
    }
}

proc gdb_clear_suppressed { } {
    global suppress_flag;

    set suppress_flag 0;
}

proc gdb_start { } {
    default_gdb_start
}

proc gdb_exit { } {
    catch default_gdb_exit
}

#
# gdb_load -- load a file into the debugger.
#             return a -1 if anything goes wrong.
#
proc gdb_load { arg } {
    return [gdb_file_cmd $arg]
}

proc gdb_continue { function } {
    global decimal

    return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
}

proc default_gdb_init { args } {
    gdb_clear_suppressed;

    # Uh, this is lame. Really, really, really lame. But there's this *one*
    # testcase that will fail in random places if we don't increase this.
    match_max -d 20000

    # We want to add the name of the TCL testcase to the PASS/FAIL messages.
    if { [llength $args] > 0 } {
	global pf_prefix

	set file [lindex $args 0];

	set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:";
    }
    global gdb_prompt;
    if [target_info exists gdb_prompt] {
	set gdb_prompt [target_info gdb_prompt];
    } else {
	set gdb_prompt "\\(gdb\\)"
    }
}

proc gdb_init { args } {
    return [eval default_gdb_init $args];
}

proc gdb_finish { } {
    gdb_exit;
}

global debug_format
set debug_format "unknown"

# Run the gdb command "info source" and extract the debugging format
# information from the output and save it in debug_format.

proc get_debug_format { } {
    global gdb_prompt
    global verbose
    global expect_out
    global debug_format

    set debug_format "unknown"
    send_gdb "info source\n"
    gdb_expect 10 {
	-re "Compiled with (.*) debugging format.\r\n$gdb_prompt $" {
	    set debug_format $expect_out(1,string)
	    verbose "debug format is $debug_format"
	    return 1;
	}
	-re "No current source file.\r\n$gdb_prompt $" {
	    perror "get_debug_format used when no current source file"
	    return 0;
	}
	-re "$gdb_prompt $" {
	    warning "couldn't check debug format (no valid response)."
	    return 1;
	}
	timeout {
	    warning "couldn't check debug format (timed out)."
	    return 1;
	}
    }
}

# Like setup_xfail, but takes the name of a debug format (DWARF 1,
# COFF, stabs, etc).  If that format matches the format that the
# current test was compiled with, then the next test is expected to
# fail for any target.  Returns 1 if the next test or set of tests is
# expected to fail, 0 otherwise (or if it is unknown).  Must have
# previously called get_debug_format.

proc setup_xfail_format { format } {
    global debug_format

    if [string match $debug_format $format] then {
	setup_xfail "*-*-*"
	return 1;
    }
    return 0
}    

proc gdb_step_for_stub { } {
    global gdb_prompt;

    if ![target_info exists gdb,use_breakpoint_for_stub] {
	if [target_info exists gdb_stub_step_command] {
	    set command [target_info gdb_stub_step_command];
	} else {
	    set command "step";
	}
	send_gdb "${command}\n";
	set tries 0;
	gdb_expect 60 {
	    -re "(main.* at |.*in .*start).*$gdb_prompt" {
		return;
	    }
	    -re ".*$gdb_prompt" {
		incr tries;
		if { $tries == 5 } {
		    fail "stepping out of breakpoint function";
		    return;
		}
		send_gdb "${command}\n";
		exp_continue;
	    }
	    default {
		fail "stepping out of breakpoint function";
		return;
	    }
	}
    }
    send_gdb "where\n";
    gdb_expect {
	-re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" {
	    set file $expect_out(1,string);
	    set linenum [expr $expect_out(2,string) + 1];
	    set breakplace "${file}:${linenum}";
	}
	default {}
    }
    send_gdb "break ${breakplace}\n";
    gdb_expect 60 {
	-re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" {
	    set breakpoint $expect_out(1,string);
	}
	-re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" {
	    set breakpoint $expect_out(1,string);
	}
	default {}
    }
    send_gdb "continue\n";
    gdb_expect 60 {
	-re "Breakpoint ${breakpoint},.*$gdb_prompt" {
	    gdb_test "delete $breakpoint" ".*" "";
	    return;
	}
	default {}
    }
}

### gdb_get_line_number TEXT [FILE]
###
### Search the source file FILE, and return the line number of a line
### containing TEXT.  Use this function instead of hard-coding line
### numbers into your test script.
###
### Specifically, this function uses GDB's "search" command to search
### FILE for the first line containing TEXT, and returns its line
### number.  Thus, FILE must be a source file, compiled into the
### executable you are running.  If omitted, FILE defaults to the
### value of the global variable `srcfile'; most test scripts set
### `srcfile' appropriately at the top anyway.
###
### Use this function to keep your test scripts independent of the
### exact line numbering of the source file.  Don't write:
### 
###   send_gdb "break 20"
### 
### This means that if anyone ever edits your test's source file, 
### your test could break.  Instead, put a comment like this on the
### source file line you want to break at:
### 
###   /* breakpoint spot: frotz.exp: test name */
### 
### and then write, in your test script (which we assume is named
### frotz.exp):
### 
###   send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n"
###
### (Yes, Tcl knows how to handle the nested quotes and brackets.
### Try this:
### 	$ tclsh
### 	% puts "foo [lindex "bar baz" 1]"
### 	foo baz
### 	% 
### Tcl is quite clever, for a little stringy language.)

proc gdb_get_line_number {text {file /omitted/}} {
    global gdb_prompt;
    global srcfile;

    if {! [string compare $file /omitted/]} {
	set file $srcfile
    }

    set result -1;
    gdb_test "list ${file}:1,1" ".*" ""
    send_gdb "search ${text}\n"
    gdb_expect {
        -re "\[\r\n\]+(\[0-9\]+)\[ \t\].*${text}.*$gdb_prompt $" {
            set result $expect_out(1,string)
        }
        -re ".*$gdb_prompt $" {
            fail "find line number containing \"${text}\""
        }
        timeout {
            fail "find line number containing \"${text}\" (timeout)"
        }
    }
    return $result;
}

# gdb_continue_to_end:
#	The case where the target uses stubs has to be handled specially. If a
#       stub is used, we set a breakpoint at exit because we cannot rely on
#       exit() behavior of a remote target.
# 
# mssg is the error message that gets printed.

proc gdb_continue_to_end {mssg} {
  if [target_info exists use_gdb_stub] {
    if {![gdb_breakpoint "exit"]} {
      return 0
    }
    gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \
      "continue until exit at $mssg"
  } else {
    # Continue until we exit.  Should not stop again.
    # Don't bother to check the output of the program, that may be
    # extremely tough for some remote systems.
    gdb_test "continue"\
      "Continuing.\[\r\n0-9\]+Program exited normally\\..*"\
      "continue until exit at $mssg"
  }
}

proc rerun_to_main {} {
  global gdb_prompt

  if [target_info exists use_gdb_stub] {
    gdb_run_cmd
    gdb_expect {
      -re ".*Breakpoint .*main .*$gdb_prompt $"\
	      {pass "rerun to main" ; return 0}
      -re "$gdb_prompt $"\
	      {fail "rerun to main" ; return 0}
      timeout {fail "(timeout) rerun to main" ; return 0}
    }
  } else {
    send_gdb "run\n"
    gdb_expect {
      -re "Starting program.*$gdb_prompt $"\
	      {pass "rerun to main" ; return 0}
      -re "$gdb_prompt $"\
	      {fail "rerun to main" ; return 0}
      timeout {fail "(timeout) rerun to main" ; return 0}
    }
  }
}

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