* lib/gdb.exp: Move all insight-related functionality into
separate file. * lib/insight-support.exp: New file.
This commit is contained in:
Keith Seitz
parent
ee8a3a3be4
commit
4c32cc04d2
@ -1,3 +1,9 @@
|
||||
2001-08-30 Keith Seitz <keiths@redhat.com>
|
||||
|
||||
* lib/gdb.exp: Move all insight-related functionality into
|
||||
separate file.
|
||||
* lib/insight-support.exp: New file.
|
||||
|
||||
2001-08-29 Frank Ch. Eigler <fche@redhat.com>
|
||||
|
||||
* config/sid.exp (sid_start): Never set sid verbosity; disable
|
||||
|
||||
@ -1603,286 +1603,6 @@ proc rerun_to_main {} {
|
||||
}
|
||||
}
|
||||
|
||||
# Initializes the display for gdbtk testing.
|
||||
# Returns 1 if tests should run, 0 otherwise.
|
||||
proc gdbtk_initialize_display {} {
|
||||
global _using_windows
|
||||
|
||||
# This is hacky, but, we don't have much choice. When running
|
||||
# expect under Windows, tcl_platform(platform) is "unix".
|
||||
if {![info exists _using_windows]} {
|
||||
set _using_windows [expr {![catch {exec cygpath --help}]}]
|
||||
}
|
||||
|
||||
if {![_gdbtk_xvfb_init]} {
|
||||
if {$_using_windows} {
|
||||
untested "No GDB_DISPLAY -- skipping tests"
|
||||
} else {
|
||||
untested "No GDB_DISPLAY or Xvfb -- skipping tests"
|
||||
}
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
return 1
|
||||
}
|
||||
|
||||
# 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]
|
||||
|
||||
# Find absolute path to test
|
||||
set test [to_tcl_path -abs $test]
|
||||
|
||||
# Set some environment variables
|
||||
cd $srcdir
|
||||
set abs_srcdir [pwd]
|
||||
set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]]
|
||||
|
||||
cd $wd
|
||||
cd [file join $objdir $subdir]
|
||||
set env(OBJDIR) [pwd]
|
||||
cd $wd
|
||||
|
||||
# Set info about target into env
|
||||
_gdbtk_export_target_info
|
||||
|
||||
set env(SRCDIR) $abs_srcdir
|
||||
set env(GDBTK_VERBOSE) 1
|
||||
set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]]
|
||||
|
||||
set err [catch {exec $GDB -nx -q --tclcommand=$test} res]
|
||||
if { $err } {
|
||||
perror "Execing $GDB failed: $res"
|
||||
exit 1;
|
||||
}
|
||||
return $res
|
||||
}
|
||||
|
||||
# Start xvfb when using it.
|
||||
# The precedence is:
|
||||
# 1. If GDB_DISPLAY is set (and not ""), use it
|
||||
# 2. If Xvfb exists, use it (not on cygwin)
|
||||
# 3. Skip tests
|
||||
proc _gdbtk_xvfb_init {} {
|
||||
global env spawn_id _xvfb_spawn_id _using_windows
|
||||
|
||||
if {[info exists env(GDB_DISPLAY)]} {
|
||||
if {$env(GDB_DISPLAY) != ""} {
|
||||
set env(DISPLAY) $env(GDB_DISPLAY)
|
||||
} else {
|
||||
# Suppress tests
|
||||
return 0
|
||||
}
|
||||
} elseif {!$_using_windows && [which Xvfb] != 0} {
|
||||
set screen ":[getpid]"
|
||||
set pid [spawn Xvfb $screen]
|
||||
set _xvfb_spawn_id $spawn_id
|
||||
set env(DISPLAY) $screen
|
||||
} else {
|
||||
# No Xvfb found -- skip test
|
||||
return 0
|
||||
}
|
||||
|
||||
return 1
|
||||
}
|
||||
|
||||
# Kill xvfb
|
||||
proc _gdbtk_xvfb_exit {} {
|
||||
global objdir subdir env _xvfb_spawn_id
|
||||
|
||||
if {[info exists _xvfb_spawn_id]} {
|
||||
exec kill [exp_pid -i $_xvfb_spawn_id]
|
||||
wait -i $_xvfb_spawn_id
|
||||
}
|
||||
}
|
||||
|
||||
# help proc for setting tcl-style paths from unix-style paths
|
||||
# pass "-abs" to make it an absolute path
|
||||
proc to_tcl_path {unix_path {arg {}}} {
|
||||
global _using_windows
|
||||
|
||||
if {[string compare $unix_path "-abs"] == 0} {
|
||||
set unix_path $arg
|
||||
set wd [pwd]
|
||||
cd [file dirname $unix_path]
|
||||
set dirname [pwd]
|
||||
set unix_name [file join $dirname [file tail $unix_path]]
|
||||
cd $wd
|
||||
}
|
||||
|
||||
if {$_using_windows} {
|
||||
set unix_path [exec cygpath -aw $unix_path]
|
||||
set unix_path [join [split $unix_path \\] /]
|
||||
}
|
||||
|
||||
return $unix_path
|
||||
}
|
||||
|
||||
# Set information about the target into the environment
|
||||
# variable TARGET_INFO. This array will contain a list
|
||||
# of commands that are necessary to run a target.
|
||||
#
|
||||
# This is mostly devined from how dejagnu works, what
|
||||
# procs are defined, and analyzing unix.exp, monitor.exp,
|
||||
# and sim.exp.
|
||||
#
|
||||
# Array elements exported:
|
||||
# Index Meaning
|
||||
# ----- -------
|
||||
# init list of target/board initialization commands
|
||||
# target target command for target/board
|
||||
# load load command for target/board
|
||||
# run run command for target_board
|
||||
proc _gdbtk_export_target_info {} {
|
||||
global env
|
||||
|
||||
# Figure out what "target class" the testsuite is using,
|
||||
# i.e., sim, monitor, native
|
||||
if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} {
|
||||
# Using a monitor/remote target
|
||||
set target monitor
|
||||
} elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} {
|
||||
# Using a simulator target
|
||||
set target simulator
|
||||
} else {
|
||||
# Assume native
|
||||
set target native
|
||||
}
|
||||
|
||||
# Now setup the array to be exported.
|
||||
set info(init) {}
|
||||
set info(target) {}
|
||||
set info(load) {}
|
||||
set info(run) {}
|
||||
|
||||
switch $target {
|
||||
simulator {
|
||||
set opts "[target_info gdb,target_sim_options]"
|
||||
set info(target) "target sim $opts"
|
||||
set info(load) "load"
|
||||
set info(run) "run"
|
||||
}
|
||||
|
||||
monitor {
|
||||
# Setup options for the connection
|
||||
if {[target_info exists baud]} {
|
||||
lappend info(init) "set remotebaud [target_info baud]"
|
||||
}
|
||||
if {[target_info exists binarydownload]} {
|
||||
lappend info(init) "set remotebinarydownload [target_info binarydownload]"
|
||||
}
|
||||
if {[target_info exists disable_x_packet]} {
|
||||
lappend info(init) "set remote X-packet disable"
|
||||
}
|
||||
if {[target_info exists disable_z_packet]} {
|
||||
lappend info(init) "set remote Z-packet disable"
|
||||
}
|
||||
|
||||
# Get target name and connection info
|
||||
if {[target_info exists gdb_protocol]} {
|
||||
set targetname "[target_info gdb_protocol]"
|
||||
} else {
|
||||
set targetname "not_specified"
|
||||
}
|
||||
if {[target_info exists gdb_serial]} {
|
||||
set serialport "[target_info gdb_serial]"
|
||||
} elseif {[target_info exists netport]} {
|
||||
set serialport "[target_info netport]"
|
||||
} else {
|
||||
set serialport "[target_info serial]"
|
||||
}
|
||||
|
||||
set info(target) "target $targetname $serialport"
|
||||
set info(load) "load"
|
||||
set info(run) "continue"
|
||||
}
|
||||
|
||||
native {
|
||||
set info(run) "run"
|
||||
}
|
||||
}
|
||||
|
||||
# Export the array to the environment
|
||||
set env(TARGET_INFO) [array get info]
|
||||
}
|
||||
|
||||
# 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)"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc gdbtk_done {{results {}}} {
|
||||
global _xvfb_spawn_id
|
||||
gdbtk_analyze_results $results
|
||||
|
||||
# Kill off xvfb if using it
|
||||
if {[info exists _xvfb_spawn_id]} {
|
||||
_gdbtk_xvfb_exit
|
||||
}
|
||||
}
|
||||
|
||||
# Print a message and return true if a test should be skipped
|
||||
# due to lack of floating point suport.
|
||||
|
||||
|
||||
293
gdb/testsuite/lib/insight-support.exp
Normal file
293
gdb/testsuite/lib/insight-support.exp
Normal file
@ -0,0 +1,293 @@
|
||||
# GDB Testsuite Support for Insight.
|
||||
#
|
||||
# Copyright 2001 Red Hat, Inc.
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify it
|
||||
# under the terms of the GNU General Public License (GPL) as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or (at
|
||||
# your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# Initializes the display for gdbtk testing.
|
||||
# Returns 1 if tests should run, 0 otherwise.
|
||||
proc gdbtk_initialize_display {} {
|
||||
global _using_windows
|
||||
|
||||
# This is hacky, but, we don't have much choice. When running
|
||||
# expect under Windows, tcl_platform(platform) is "unix".
|
||||
if {![info exists _using_windows]} {
|
||||
set _using_windows [expr {![catch {exec cygpath --help}]}]
|
||||
}
|
||||
|
||||
if {![_gdbtk_xvfb_init]} {
|
||||
if {$_using_windows} {
|
||||
untested "No GDB_DISPLAY -- skipping tests"
|
||||
} else {
|
||||
untested "No GDB_DISPLAY or Xvfb -- skipping tests"
|
||||
}
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
return 1
|
||||
}
|
||||
|
||||
# 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]
|
||||
|
||||
# Find absolute path to test
|
||||
set test [to_tcl_path -abs $test]
|
||||
|
||||
# Set some environment variables
|
||||
cd $srcdir
|
||||
set abs_srcdir [pwd]
|
||||
set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]]
|
||||
|
||||
cd $wd
|
||||
cd [file join $objdir $subdir]
|
||||
set env(OBJDIR) [pwd]
|
||||
cd $wd
|
||||
|
||||
# Set info about target into env
|
||||
_gdbtk_export_target_info
|
||||
|
||||
set env(SRCDIR) $abs_srcdir
|
||||
set env(GDBTK_VERBOSE) 1
|
||||
set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]]
|
||||
|
||||
set err [catch {exec $GDB -nx -q --tclcommand=$test} res]
|
||||
if { $err } {
|
||||
perror "Execing $GDB failed: $res"
|
||||
exit 1;
|
||||
}
|
||||
return $res
|
||||
}
|
||||
|
||||
# Start xvfb when using it.
|
||||
# The precedence is:
|
||||
# 1. If GDB_DISPLAY is set (and not ""), use it
|
||||
# 2. If Xvfb exists, use it (not on cygwin)
|
||||
# 3. Skip tests
|
||||
proc _gdbtk_xvfb_init {} {
|
||||
global env spawn_id _xvfb_spawn_id _using_windows
|
||||
|
||||
if {[info exists env(GDB_DISPLAY)]} {
|
||||
if {$env(GDB_DISPLAY) != ""} {
|
||||
set env(DISPLAY) $env(GDB_DISPLAY)
|
||||
} else {
|
||||
# Suppress tests
|
||||
return 0
|
||||
}
|
||||
} elseif {!$_using_windows && [which Xvfb] != 0} {
|
||||
set screen ":[getpid]"
|
||||
set pid [spawn Xvfb $screen]
|
||||
set _xvfb_spawn_id $spawn_id
|
||||
set env(DISPLAY) $screen
|
||||
} else {
|
||||
# No Xvfb found -- skip test
|
||||
return 0
|
||||
}
|
||||
|
||||
return 1
|
||||
}
|
||||
|
||||
# Kill xvfb
|
||||
proc _gdbtk_xvfb_exit {} {
|
||||
global objdir subdir env _xvfb_spawn_id
|
||||
|
||||
if {[info exists _xvfb_spawn_id]} {
|
||||
exec kill [exp_pid -i $_xvfb_spawn_id]
|
||||
wait -i $_xvfb_spawn_id
|
||||
}
|
||||
}
|
||||
|
||||
# help proc for setting tcl-style paths from unix-style paths
|
||||
# pass "-abs" to make it an absolute path
|
||||
proc to_tcl_path {unix_path {arg {}}} {
|
||||
global _using_windows
|
||||
|
||||
if {[string compare $unix_path "-abs"] == 0} {
|
||||
set unix_path $arg
|
||||
set wd [pwd]
|
||||
cd [file dirname $unix_path]
|
||||
set dirname [pwd]
|
||||
set unix_name [file join $dirname [file tail $unix_path]]
|
||||
cd $wd
|
||||
}
|
||||
|
||||
if {$_using_windows} {
|
||||
set unix_path [exec cygpath -aw $unix_path]
|
||||
set unix_path [join [split $unix_path \\] /]
|
||||
}
|
||||
|
||||
return $unix_path
|
||||
}
|
||||
|
||||
# Set information about the target into the environment
|
||||
# variable TARGET_INFO. This array will contain a list
|
||||
# of commands that are necessary to run a target.
|
||||
#
|
||||
# This is mostly devined from how dejagnu works, what
|
||||
# procs are defined, and analyzing unix.exp, monitor.exp,
|
||||
# and sim.exp.
|
||||
#
|
||||
# Array elements exported:
|
||||
# Index Meaning
|
||||
# ----- -------
|
||||
# init list of target/board initialization commands
|
||||
# target target command for target/board
|
||||
# load load command for target/board
|
||||
# run run command for target_board
|
||||
proc _gdbtk_export_target_info {} {
|
||||
global env
|
||||
|
||||
# Figure out what "target class" the testsuite is using,
|
||||
# i.e., sim, monitor, native
|
||||
if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} {
|
||||
# Using a monitor/remote target
|
||||
set target monitor
|
||||
} elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} {
|
||||
# Using a simulator target
|
||||
set target simulator
|
||||
} else {
|
||||
# Assume native
|
||||
set target native
|
||||
}
|
||||
|
||||
# Now setup the array to be exported.
|
||||
set info(init) {}
|
||||
set info(target) {}
|
||||
set info(load) {}
|
||||
set info(run) {}
|
||||
|
||||
switch $target {
|
||||
simulator {
|
||||
set opts "[target_info gdb,target_sim_options]"
|
||||
set info(target) "target sim $opts"
|
||||
set info(load) "load"
|
||||
set info(run) "run"
|
||||
}
|
||||
|
||||
monitor {
|
||||
# Setup options for the connection
|
||||
if {[target_info exists baud]} {
|
||||
lappend info(init) "set remotebaud [target_info baud]"
|
||||
}
|
||||
if {[target_info exists binarydownload]} {
|
||||
lappend info(init) "set remotebinarydownload [target_info binarydownload]"
|
||||
}
|
||||
if {[target_info exists disable_x_packet]} {
|
||||
lappend info(init) "set remote X-packet disable"
|
||||
}
|
||||
if {[target_info exists disable_z_packet]} {
|
||||
lappend info(init) "set remote Z-packet disable"
|
||||
}
|
||||
|
||||
# Get target name and connection info
|
||||
if {[target_info exists gdb_protocol]} {
|
||||
set targetname "[target_info gdb_protocol]"
|
||||
} else {
|
||||
set targetname "not_specified"
|
||||
}
|
||||
if {[target_info exists gdb_serial]} {
|
||||
set serialport "[target_info gdb_serial]"
|
||||
} elseif {[target_info exists netport]} {
|
||||
set serialport "[target_info netport]"
|
||||
} else {
|
||||
set serialport "[target_info serial]"
|
||||
}
|
||||
|
||||
set info(target) "target $targetname $serialport"
|
||||
set info(load) "load"
|
||||
set info(run) "continue"
|
||||
}
|
||||
|
||||
native {
|
||||
set info(run) "run"
|
||||
}
|
||||
}
|
||||
|
||||
# Export the array to the environment
|
||||
set env(TARGET_INFO) [array get info]
|
||||
}
|
||||
|
||||
# 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)"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc gdbtk_done {{results {}}} {
|
||||
global _xvfb_spawn_id
|
||||
gdbtk_analyze_results $results
|
||||
|
||||
# Kill off xvfb if using it
|
||||
if {[info exists _xvfb_spawn_id]} {
|
||||
_gdbtk_xvfb_exit
|
||||
}
|
||||
}
|
||||
Loading…
x
Reference in New Issue
Block a user