diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/debugger.exp | 244 | ||||
-rw-r--r-- | lib/dg.exp | 922 | ||||
-rw-r--r-- | lib/framework.exp | 898 | ||||
-rw-r--r-- | lib/ftp.exp | 246 | ||||
-rw-r--r-- | lib/kermit.exp | 180 | ||||
-rw-r--r-- | lib/libgloss.exp | 843 | ||||
-rw-r--r-- | lib/mondfe.exp | 213 | ||||
-rw-r--r-- | lib/remote.exp | 1265 | ||||
-rw-r--r-- | lib/rlogin.exp | 173 | ||||
-rw-r--r-- | lib/rsh.exp | 258 | ||||
-rw-r--r-- | lib/standard.exp | 42 | ||||
-rw-r--r-- | lib/target.exp | 759 | ||||
-rw-r--r-- | lib/targetdb.exp | 113 | ||||
-rw-r--r-- | lib/telnet.exp | 243 | ||||
-rw-r--r-- | lib/tip.exp | 184 | ||||
-rw-r--r-- | lib/util-defs.exp | 101 | ||||
-rw-r--r-- | lib/utils.exp | 441 | ||||
-rw-r--r-- | lib/xsh.exp | 322 |
18 files changed, 7447 insertions, 0 deletions
diff --git a/lib/debugger.exp b/lib/debugger.exp new file mode 100644 index 0000000..f00076d --- /dev/null +++ b/lib/debugger.exp @@ -0,0 +1,244 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Dump the values of a shell expression representing variable +# names. +proc dumpvars { args } { + uplevel 1 [list foreach i [uplevel 1 "info vars $args"] { + if { [catch "array names $i" names ] } { + eval "puts \"${i} = \$${i}\"" + } else { + foreach k $names { + eval "puts \"$i\($k\) = \$$i\($k\)\"" + } + } + } + ] +} + +# +# dump the values of a shell expression representing variable +# names. +proc dumplocals { args } { + uplevel 1 [list foreach i [uplevel 1 "info locals $args"] { + if { [catch "array names $i" names ] } { + eval "puts \"${i} = \$${i}\"" + } else { + foreach k $names { + eval "puts \"$i\($k\) = \$$i\($k\)\"" + } + } + } + ] +} +# +# Dump the body of procedures specified by a regexp. +# +proc dumprocs { args } { + foreach i [info procs $args] { + puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}" + } +} + +# +# Dump all the current watchpoints +# +proc dumpwatch { args } { + foreach i [uplevel 1 "info vars $args"] { + set tmp "" + if { [catch "uplevel 1 array name $i" names] } { + set tmp [uplevel 1 trace vinfo $i] + if ![string match "" $tmp] { + puts "$i $tmp" + } + } else { + foreach k $names { + set tmp [uplevel 1 trace vinfo [set i]($k)] + if ![string match "" $tmp] { + puts "[set i]($k) = $tmp" + } + } + } + } +} + +# +# Trap a watchpoint for an array +# +proc watcharray { element type} { + upvar [set array]($element) avar + case $type { + "w" { puts "New value of [set array]($element) is $avar" } + "r" { puts "[set array]($element) (= $avar) was just read" } + "u" { puts "[set array]($element) (= $avar) was just unset" } + } +} + +proc watchvar { v type } { + upvar $v var + case $type { + "w" { puts "New value of $v is $var" } + "r" { puts "$v (=$var) was just read" } + "u" { puts "$v (=$var) was just unset" } + } +} + +# +# Watch when a variable is written +# +proc watchunset { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg u watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) u watcharray + } + } +} + +# +# Watch when a variable is written +# +proc watchwrite { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg w watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) w watcharray + } + } +} + +# +# Watch when a variable is read +# +proc watchread { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg r watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) r watcharray + } + } +} + +# +# Delete a watch point +# +proc watchdel { args } { + foreach i [uplevel 1 "info vars $args"] { + set tmp "" + if { [catch "uplevel 1 array name $i" names] } { + catch "uplevel 1 trace vdelete $i w watchvar" + catch "uplevel 1 trace vdelete $i r watchvar" + catch "uplevel 1 trace vdelete $i u watchvar" + } else { + foreach k $names { + catch "uplevel 1 trace vdelete [set i]($k) w watcharray" + catch "uplevel 1 trace vdelete [set i]($k) r watcharray" + catch "uplevel 1 trace vdelete [set i]($k) u watcharray" + } + } + } +} + +# +# This file creates GDB style commands for the Tcl debugger +# +proc print { var } { + puts "$var" +} + +proc quit { } { + log_and_exit; +} + +proc bt { } { + puts "[w]" +} + +# +# create some stub procedures since we can't alias the command names +# +proc dp { args } { + uplevel 1 dumprocs $args +} + +proc dv { args } { + uplevel 1 dumpvars $args +} + +proc dl { args } { + uplevel 1 dumplocals $args +} + +proc dw { args } { + uplevel 1 dumpwatch $args +} + +proc q { } { + quit +} + +proc p { args } { + uplevel 1 print $args +} + +proc wu { args } { + uplevel 1 watchunset $args +} + +proc ww { args } { + uplevel 1 watchwrite $args +} + +proc wr { args } { + uplevel 1 watchread $args +} + +proc wd { args } { + uplevel 1 watchdel $args +} diff --git a/lib/dg.exp b/lib/dg.exp new file mode 100644 index 0000000..35c4afa --- /dev/null +++ b/lib/dg.exp @@ -0,0 +1,922 @@ +# `dg' general purpose testcase driver. +# Copyright (C) 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# dje@cygnus.com. + +# This file was written by Doug Evans (dje@cygnus.com). + +# This file is based on old-dejagnu.exp. It is intended to be more extensible +# without incurring the overhead that old-dejagnu.exp can. All test framework +# commands appear in the testcase as "{ dg-xxx args ... }". We pull them out +# with one grep, and then run the function(s) named by "dg-xxx". When running +# dg-xxx, the line number that it occurs on is always passed as the first +# argument. We also support different kinds of tools via callbacks. +# +# The currently supported options are: +# +# dg-prms-id N +# set prms_id to N +# +# dg-options "options ..." [{ target selector }] +# specify special options to pass to the tool (eg: compiler) +# +# dg-do do-what-keyword [{ target/xfail selector }] +# `do-what-keyword' is tool specific and is passed unchanged to +# ${tool}-dg-test. An example is gcc where `keyword' can be any of: +# preprocess|compile|assemble|link|run +# and will do one of: produce a .i, produce a .s, produce a .o, +# produce an a.out, or produce an a.out and run it (the default is +# compile). +# +# dg-error regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate an error message <regexp> is expected on this line +# (the test fails if it doesn't occur) +# Linenum=0 for general tool messages (eg: -V arg missing). +# "." means the current line. +# +# dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate a warning message <regexp> is expected on this line +# (the test fails if it doesn't occur) +# +# dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate a bogus error message <regexp> use to occur here +# (the test fails if it does occur) +# +# dg-build regexp comment [{ target/xfail selector }] +# indicate the build use to fail for some reason +# (errors covered here include bad assembler generated, tool crashes, +# and link failures) +# (the test fails if it does occur) +# +# dg-excess-errors comment [{ target/xfail selector }] +# indicate excess errors are expected (any line) +# (this should only be used sparingly and temporarily) +# +# dg-output regexp [{ target selector }] +# indicate the expected output of the program is <regexp> +# (there may be multiple occurrences of this, they are concatenated) +# +# dg-final { tcl code } +# add some tcl code to be run at the end +# (there may be multiple occurrences of this, they are concatenated) +# (unbalanced braces must be \-escaped) +# +# "{ target selector }" is a list of expressions that determine whether the +# test succeeds or fails for a particular target, or in some cases whether the +# option applies for a particular target. If the case of `dg-do' it specifies +# whether the testcase is even attempted on the specified target. +# +# The target selector is always optional. The format is one of: +# +# { xfail *-*-* ... } - the test is expected to fail for the given targets +# { target *-*-* ... } - the option only applies to the given targets +# +# At least one target must be specified, use *-*-* for "all targets". +# At present it is not possible to specify both `xfail' and `target'. +# "native" may be used in place of "*-*-*". +# +# Example: +# +# [ ... some complicated code ... ] +# return a; /* { dg-build "fatal" "ran out of spill regs" { xfail i386-*-* } } */ +# +# In this example, the compiler use to crash on the "return a;" for some +# target and that it still does crash on i386-*-*. Admittedly, this is a +# contrived example. +# +# ??? It might be possible to add additional optional arguments by having +# something like: { dg-error ".*syntax.*" "syntax error" { { foo 1 } ... } } +# +# Callbacks +# +# ${tool}-dg-test testfile do-what-keyword extra-flags +# +# Run the test, be it compiler, assembler, or whatever. +# +# ${tool}-dg-prune target_triplet text +# +# Optional callback to delete output from the tool that can occur +# even in successful ("pass") situations and interfere with output +# pattern matching. This also gives the tool an opportunity to review +# the output and check for any conditions which indicate an "untested" +# or "unresolved" state. An example is if a testcase is too big and +# fills all available ram (which can happen for 16 bit cpus). The +# result is either the pruned text or +# "::untested|unresolved|unsupported::message" +# (eg: "::unsupported::memory full"). +# +# Notes: +# 1) All runnable testcases must return 0 from main() for success. +# You can't rely on getting any return code from target boards, and the +# `exec' command says a program fails if it returns non-zero. +# +# Language independence is (theoretically) achieved by: +# +# 1) Using global $tool to indicate the language (eg: gcc, g++, gas, etc.). +# This should only be used to look up other objects. We don't want to +# have to add code for each new language that is supported. If this is +# done right, no code needs to be added here for each new language. +# +# 2) Passing tool options in as arguments. +# +# Earlier versions of ${tool}_start (eg: gcc_start) would only take the name +# of the file to compile as an argument. Newer versions accept a list of +# one or two elements, the second being a string of *all* options to pass +# to the tool. We require this facility. +# +# 3) Callbacks. +# +# Try not to do anything else that makes life difficult. +# +# The normal way to write a testsuite is to have a .exp file containing: +# +# load_lib ${tool}-dg.exp +# dg-init +# dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/foo*]] ... +# dg-finish + +# Global state variables. +# The defaults are for GCC. + +# The default do-what keyword. +set dg-do-what-default compile + +# When dg-interpreter-batch-mode is 1, no execution test or excess error +# tests are performed. +set dg-interpreter-batch-mode 0 + +# Line number format. This is how line numbers appear in program output. +set dg-linenum-format ":%d:" +proc dg-format-linenum { linenum } { + global dg-linenum-format + return [format ${dg-linenum-format} $linenum] +} + +# Useful subroutines. + +# dg-get-options -- pick out the dg-xxx options in a testcase +# +# PROG is the file name of the testcase. +# The result is a list of options found. +# +# Example: For the following testcase: +# +# /* { dg-prms-id 1234 } */ +# int foo { return 0; } /* { dg-build fatal "some comment" } */ +# +# we return: +# +# { dg-prms-id 1 1234 } { dg-build 2 fatal "some comment" } + +proc dg-get-options { prog } { + set result "" + + set tmp [grep $prog "{\[ \t\]\+dg-\[-a-z\]\+\[ \t\]\+.*\[ \t\]\+}" line] + if ![string match "" $tmp] { + foreach i $tmp { + #send_user "Found: $i\n" + # FIXME: When to use "+" and "\+" isn't clear. + # Seems to me it took awhile to get this to work. + regexp "(\[0-9\]\+)\[ \t\]\+{\[ \t\]+(dg-\[-a-z\]+)\[ \t\]\+(.*)\[ \t\]+}\[^\}\]*(\n|$)" $i i line cmd args + #send_user "Found: $cmd $line $args\n" + append result " { $cmd $line $args }" + } + } + + #send_user "Returning: $result\n" + return $result +} + +# +# Process optional xfail/target arguments +# +# SELECTOR is "xfail target-triplet-1 ..." or "target target-triplet-1 ..." +# `target-triplet' may be "native". +# For xfail, the result is "F" (expected to Fail) if the current target is +# affected, otherwise "P" (expected to Pass). +# For target, the result is "S" (target is Selected) if the target is selected, +# otherwise "N" (target is Not selected). +# +proc dg-process-target { selector } { + global target_triplet + + set isnative [isnative] + set triplet_match 0 + + #send_user "dg-process-target: $selector\n" + + set selector [string trim $selector] + if [regexp "^xfail " $selector] { + set what xfail + } elseif [regexp "^target " $selector] { + set what target + } else { + # The use of error here and in other dg-xxx utilities is intentional. + # dg-test will catch them and do the right thing. + error "syntax error in target selector \"$selector\"" + } + + # ??? This should work but it doesn't. tcl bug? + #if [regexp "^${what}(( \[^ \]+-\[^ \]+-\[^ \]+)|( native))+$" $selector tmp selector] + if [regexp "^${what}( \[^ \]+-\[^ \]+-\[^ \]+| native)+$" $selector] { + regsub "^${what} " $selector "" selector + #send_user "selector: $selector\n" + foreach triplet $selector { + if [string match $triplet $target_triplet] { + set triplet_match 1 + } elseif { $isnative && $triplet == "native" } { + set triplet_match 1 + } + } + } else { + error "syntax error in target selector \"$selector\"" + } + + if { $triplet_match } { + return [expr { $what == "xfail" ? "F" : "S" }] + } else { + return [expr { $what == "xfail" ? "P" : "N" }] + } +} + +# Predefined user option handlers. +# The line number is always the first element. +# Note that each of these are varargs procs (they have an `args' argument). +# Tests for optional arguments are coded with ">=" to simplify adding new ones. + +proc dg-prms-id { args } { + global prms_id ;# this is a testing framework variable + + if { [llength $args] > 2 } { + error "[lindex $args 0]: too many arguments" + return + } + + set prms_id [lindex $args 1] +} + +# +# Set tool options +# +# Different options can be used for different targets by having multiple +# instances, selecting a different target each time. Since options are +# processed in order, put the default value first. Subsequent occurrences +# will override previous ones. +# + +proc dg-options { args } { + upvar dg-extra-tool-flags extra-tool-flags + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "S" { set extra-tool-flags [lindex $args 1] } + "N" { } + "F" { error "[lindex $args 0]: `xfail' not allowed here" } + "P" { error "[lindex $args 0]: `xfail' not allowed here" } + } + } else { + set extra-tool-flags [lindex $args 1] + } +} + +# +# Record what to do (compile/run/etc.) +# +# Multiple instances are supported (since we don't support target and xfail +# selectors on one line), though it doesn't make much sense to change the +# compile/assemble/link/run field. Nor does it make any sense to have +# multiple lines of target selectors (use one line). +# +proc dg-do { args } { + upvar dg-do-what do-what + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + set selected [lindex ${do-what} 1] ;# selected? (""/S/N) + set expected [lindex ${do-what} 2] ;# expected to pass/fail (P/F) + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "S" { + set selected "S" + } + "N" { + # Don't deselect a target if it's been explicitly selected, + # but indicate a specific target has been selected (so don't + # do this testcase if it's not appropriate for this target). + # The user really shouldn't have multiple lines of target + # selectors, but try to do the intuitive thing (multiple lines + # are OR'd together). + if { $selected != "S" } { + set selected "N" + } + } + "F" { set expected "F" } + "P" { + # There's nothing to do for "P". We don't want to clobber a + # previous xfail for this target. + } + } + } else { + # Note: A previous occurrence of `dg-do' with target/xfail selectors + # is a user mistake. We clobber previous values here. + set selected S + set expected P + } + + switch [lindex $args 1] { + "preprocess" { } + "compile" { } + "assemble" { } + "link" { } + "run" { } + default { + error "[lindex $args 0]: syntax error" + } + } + set do-what [list [lindex $args 1] $selected $expected] +} + +proc dg-error { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this error doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}ERROR" [lindex $args 1] [lindex $args 2]] +} + +proc dg-warning { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this warning doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}WARNING" [lindex $args 1] [lindex $args 2]] +} + +proc dg-bogus { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this message doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}BOGUS" [lindex $args 1] [lindex $args 2]] +} + +proc dg-build { args } { + upvar dg-messages messages + + if { [llength $args] > 4 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [ llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this lossage doesn't apply to us so ignore it. + return + } + } + } + + lappend messages [list [lindex $args 0] "${xfail}BUILD" [lindex $args 1] [lindex $args 2]] +} + +proc dg-excess-errors { args } { + upvar dg-excess-errors-flag excess-errors-flag + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "F" { set excess-errors-flag 1 } + "S" { set excess-errors-flag 1 } + } + } else { + set excess-errors-flag 1 + } +} + +# +# Indicate expected program output +# +# We support multiple occurrences, but we do not implicitly insert newlines +# between them. +# +# Note that target boards don't all support this kind of thing so it's a good +# idea to specify the target all the time. If one or more targets are +# explicitly selected, the test won't be performed if we're not one of them +# (as long as we were never mentioned). +# +# If you have target dependent output and want to set an xfail for one or more +# of them, use { dg-output "" { xfail a-b-c ... } }. The "" won't contribute +# to the expected output. +# +proc dg-output { args } { + upvar dg-output-text output-text + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + # Allow target dependent output. + + set expected [lindex ${output-text} 0] + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "N" { return } + "S" { } + "F" { set expected "F" } + # Don't override a previous xfail. + "P" { } + } + } + + if { [llength ${output-text}] == 1 } { + # First occurrence. + set output-text [list $expected [lindex $args 1]] + } else { + set output-text [list $expected "[lindex ${output-text} 1][lindex $args 1]"] + } +} + +proc dg-final { args } { + upvar dg-final-code final-code + + if { [llength $args] > 2 } { + error "[lindex $args 0]: too many arguments" + return + } + + #send_user "dg-final: $args\n" + append final-code "[lindex $args 1]\n" +} + +# +# Set up our environment +# +# There currently isn't much to do, but always calling it allows us to add +# enhancements without having to update our callers. +# It must be run before calling `dg-test'. + +proc dg-init { } { +} + +# dg-runtest -- simple main loop useful to most testsuites +# +# FLAGS is a set of options to always pass. +# DEFAULT_EXTRA_FLAGS is a set of options to pass if the testcase doesn't +# specify any (with dg-option). +# ??? We're flipping between "flag" and "option" here. + +proc dg-runtest { testcases flags default-extra-flags } { + global runtests + + foreach testcase $testcases { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] { + continue + } + verbose "Testing [file tail [file dirname $testcase]]/[file tail $testcase]" + dg-test $testcase $flags ${default-extra-flags} + } +} + +# dg-trim-dirname -- rip DIR_NAME out of FILE_NAME +# +# Syntax: dg-trim-dirname dir_name file_name +# We need to go through this contorsion in order to properly support +# directory-names which might have embedded regexp special characters. + +proc dg-trim-dirname { dir_name file_name } { + set special_character "\[\?\+\-\.\(\)\$\|\]" + regsub -all $special_character $dir_name "\\\\&" dir_name + regsub "^$dir_name/?" $file_name "" file_name + return $file_name +} + +# dg-test -- runs a new style DejaGnu test +# +# Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags +# +# PROG is the full path name of the file to pass to the tool (eg: compiler). +# TOOL_FLAGS is a set of options to always pass. +# DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none. + +#proc dg-test { prog tool_flags default_extra_tool_flags } { +proc dg-test { args } { + global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format + global errorCode errorInfo + global tool + global srcdir ;# eg: /calvin/dje/devo/gcc/./testsuite/ + global host_triplet target_triplet + + set keep 0 + set i 0 + + if { [string index [lindex $args 0] 0] == "-" } { + for { set i 0 } { $i < [llength $args] } { incr i } { + if { [lindex $args $i] == "--" } { + incr i + break + } elseif { [lindex $args $i] == "-keep-output" } { + set keep 1 + } elseif { [string index [lindex $args $i] 0] == "-" } { + clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]" + return + } else { + break + } + } + } + + if { $i + 3 != [llength $args] } { + clone_output "ERROR: dg-test: missing arguments in call" + return + } + set prog [lindex $args $i] + set tool_flags [lindex $args [expr $i + 1]] + set default_extra_tool_flags [lindex $args [expr $i + 2]] + + set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*" + + set name [dg-trim-dirname $srcdir $prog] + # If we couldn't rip $srcdir out of `prog' then just do the best we can. + # The point is to reduce the unnecessary noise in the logs. Don't strip + # out too much because different testcases with the same name can confuse + # `test-tool'. + if [string match "/*" $name] { + set name "[file tail [file dirname $prog]]/[file tail $prog]" + } + + # Process any embedded dg options in the testcase. + + # Use "" for the second element of dg-do-what so we can tell if it's been + # explicitly set to "S". + set dg-do-what [list ${dg-do-what-default} "" P] + set dg-excess-errors-flag 0 + set dg-messages "" + set dg-extra-tool-flags $default_extra_tool_flags + set dg-final-code "" + + # `dg-output-text' is a list of two elements: pass/fail and text. + # Leave second element off for now (indicates "don't perform test") + set dg-output-text "P" + + # Define our own "special function" `unknown' so we catch spelling errors. + # But first rename the existing one so we can restore it afterwards. + catch {rename dg-save-unknown ""} + rename unknown dg-save-unknown + proc unknown { args } { + return -code error "unknown dg option: $args" + } + + set tmp [dg-get-options $prog] + foreach op $tmp { + verbose "Processing option: $op" 3 + set status [catch "$op" errmsg] + if { $status != 0 } { + if { 0 && [info exists errorInfo] } { + # This also prints a backtrace which will just confuse + # testcase writers, so it's disabled. + perror "$name: $errorInfo\n" + } else { + perror "$name: $errmsg for \"$op\"\n" + } + # ??? The call to unresolved here is necessary to clear `errcnt'. + # What we really need is a proc like perror that doesn't set errcnt. + # It should also set exit_status to 1. + unresolved "$name: $errmsg for \"$op\"" + return + } + } + + # Restore normal error handling. + rename unknown "" + rename dg-save-unknown unknown + + # If we're not supposed to try this test on this target, we're done. + if { [lindex ${dg-do-what} 1] == "N" } { + unsupported "$name" + verbose "$name not supported on this target, skipping it" 3 + return + } + + # Run the tool and analyze the results. + # The result of ${tool}-dg-test is in a bit of flux. + # Currently it is the name of the output file (or "" if none). + # If we need more than this it will grow into a list of things. + # No intention is made (at this point) to preserve upward compatibility + # (though at some point we'll have to). + + set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"]; + + set comp_output [lindex $results 0]; + set output_file [lindex $results 1]; + + #send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n" + #send_user "\nold_dejagnu.exp: message = :$message:\n\n" + #send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n" + + foreach i ${dg-messages} { + verbose "Scanning for message: $i" 4 + + # Remove all error messages for the line [lindex $i 0] + # in the source file. If we find any, success! + set line [lindex $i 0] + set pattern [lindex $i 2] + set comment [lindex $i 3] + #send_user "Before:\n$comp_output\n" + if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] { + set comp_output [string trimleft $comp_output] + set ok pass + set uhoh fail + } else { + set ok fail + set uhoh pass + } + #send_user "After:\n$comp_output\n" + + # $line will either be a formatted line number or a number all by + # itself. Delete the formatting. + scan $line ${dg-linenum-format} line + switch [lindex $i 1] { + "ERROR" { + $ok "$name $comment (test for errors, line $line)" + } + "XERROR" { + x$ok "$name $comment (test for errors, line $line)" + } + "WARNING" { + $ok "$name $comment (test for warnings, line $line)" + } + "XWARNING" { + x$ok "$name $comment (test for warnings, line $line)" + } + "BOGUS" { + $uhoh "$name $comment (test for bogus messages, line $line)" + } + "XBOGUS" { + x$uhoh "$name $comment (test for bogus messages, line $line)" + } + "BUILD" { + $uhoh "$name $comment (test for build failure, line $line)" + } + "XBUILD" { + x$uhoh "$name $comment (test for build failure, line $line)" + } + "EXEC" { } + "XEXEC" { } + } + #send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n" + } + #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n" + + # Remove messages from the tool that we can ignore. + #send_user "comp_output: $comp_output\n" + set comp_output [prune_warnings $comp_output] + + if { [info proc ${tool}-dg-prune] != "" } { + set comp_output [${tool}-dg-prune $target_triplet $comp_output] + switch -glob $comp_output { + "::untested::*" { + regsub "::untested::" $comp_output "" message + untested "$name: $message" + return + } + "::unresolved::*" { + regsub "::unresolved::" $comp_output "" message + unresolved "$name: $message" + return + } + "::unsupported::*" { + regsub "::unsupported::" $comp_output "" message + unsupported "$name: $message" + return + } + } + } + + # See if someone forgot to delete the extra lines. + regsub -all "\n+" $comp_output "\n" comp_output + regsub "^\n+" $comp_output "" comp_output + #send_user "comp_output: $comp_output\n" + + # Don't do this if we're testing an interpreter. + # FIXME: why? + if { ${dg-interpreter-batch-mode} == 0 } { + # Catch excess errors (new bugs or incomplete testcases). + if ${dg-excess-errors-flag} { + setup_xfail "*-*-*" + } + if ![string match "" $comp_output] { + fail "$name (test for excess errors)" + send_log "Excess errors:\n$comp_output\n" + } else { + pass "$name (test for excess errors)" + } + } + + # Run the executable image if asked to do so. + # FIXME: This is the only place where we assume a standard meaning to + # the `keyword' argument of dg-do. This could be cleaned up. + if { [lindex ${dg-do-what} 0] == "run" } { + if ![file exists $output_file] { + warning "$name compilation failed to produce executable" + } else { + set status -1 + set result [${tool}_load $output_file] + set status [lindex $result 0]; + set output [lindex $result 1]; + #send_user "After exec, status: $status\n" + if { [lindex ${dg-do-what} 2] == "F" } { + setup_xfail "*-*-*" + } + if { "$status" == "pass" } { + pass "$name execution test" + verbose "Exec succeeded." 3 + if { [llength ${dg-output-text}] > 1 } { + #send_user "${dg-output-text}\n" + if { [lindex ${dg-output-text} 0] == "F" } { + setup_xfail "*-*-*" + } + set texttmp [lindex ${dg-output-text} 1] + if { ![regexp $texttmp ${output}] } { + fail "$name output pattern test, is ${output}, should match $texttmp" + verbose "Failed test for output pattern $texttmp" 3 + } else { + pass "$name output pattern test, $texttmp" + verbose "Passed test for output pattern $texttmp" 3 + } + unset texttmp + } + } elseif { "$status" == "fail" } { + # It would be nice to get some info out of errorCode. + if [info exists errorCode] { + verbose "Exec failed, errorCode: $errorCode" 3 + } else { + verbose "Exec failed, errorCode not defined!" 3 + } + fail "$name execution test" + } else { + $status "$name execution test" + } + } + } + + # Are there any further tests to perform? + # Note that if the program has special run-time requirements, running + # of the program can be delayed until here. Ditto for other situations. + # It would be a bit cumbersome though. + + if ![string match ${dg-final-code} ""] { + regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code + # Note that the use of `args' here makes this a varargs proc. + proc dg-final-proc { args } ${dg-final-code} + verbose "Running dg-final tests." 3 + verbose "dg-final-proc:\n[info body dg-final-proc]" 4 + if [catch "dg-final-proc $prog" errmsg] { + perror "$name: error executing dg-final: $errmsg" + # ??? The call to unresolved here is necessary to clear `errcnt'. + # What we really need is a proc like perror that doesn't set errcnt. + # It should also set exit_status to 1. + unresolved "$name: error executing dg-final: $errmsg" + } + } + + # Do some final clean up. + # When testing an interpreter, we don't compile something and leave an + # output file. + if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } { + catch "exec rm -f $output_file" + } +} + +# +# Do any necessary cleanups +# +# This is called at the end to undo anything dg-init did (that needs undoing). +# +proc dg-finish { } { + # Reset this in case caller wonders whether s/he should. + global prms_id + set prms_id 0 + + # The framework doesn't like to see any error remnants, so remove them. + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } + + # If the tool has a "finish" routine, call it. + # There may be a bit of duplication (eg: resetting prms_id), leave it. + # Let's keep these procs robust. + global tool + if ![string match "" [info procs ${tool}_finish]] { + ${tool}_finish + } +} diff --git a/lib/framework.exp b/lib/framework.exp new file mode 100644 index 0000000..b72d38e --- /dev/null +++ b/lib/framework.exp @@ -0,0 +1,898 @@ +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2001 +# Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# These variables are local to this file. +# This or more warnings and a test fails. +set warning_threshold 3 +# This or more errors and a test fails. +set perror_threshold 1 + +proc mail_file { file to subject } { + if [file readable $file] { + catch "exec mail -s \"$subject\" $to < $file" + } +} + +# +# Open the output logs +# +proc open_logs { } { + global outdir + global tool + global sum_file + + if { ${tool} == "" } { + set tool testrun + } + catch "exec rm -f $outdir/$tool.sum" + set sum_file [open "$outdir/$tool.sum" w] + catch "exec rm -f $outdir/$tool.log" + log_file -a "$outdir/$tool.log" + verbose "Opening log files in $outdir" + if { ${tool} == "testrun" } { + set tool "" + } +} + + +# +# Close the output logs +# +proc close_logs { } { + global sum_file + + catch "close $sum_file" +} + +# +# Check build host triplet for pattern +# +# With no arguments it returns the triplet string. +# +proc isbuild { pattern } { + global build_triplet + global host_triplet + + if ![info exists build_triplet] { + set build_triplet ${host_triplet} + } + if [string match "" $pattern] { + return $build_triplet + } + verbose "Checking pattern \"$pattern\" with $build_triplet" 2 + + if [string match "$pattern" $build_triplet] { + return 1 + } else { + return 0 + } +} + +# +# Is $board remote? Return a non-zero value if so. +# +proc is_remote { board } { + global host_board; + global target_list; + + verbose "calling is_remote $board" 3; + # Remove any target variant specifications from the name. + set board [lindex [split $board "/"] 0]; + + # Map the host or build back into their short form. + if { [board_info build name] == $board } { + set board "build"; + } elseif { [board_info host name] == $board } { + set board "host"; + } + + # We're on the "build". The check for the empty string is just for + # paranoia's sake--we shouldn't ever get one. "unix" is a magic + # string that should really go away someday. + if { $board == "build" || $board == "unix" || $board == "" } { + verbose "board is $board, not remote" 3; + return 0; + } + + if { $board == "host" } { + if { [info exists host_board] && $host_board != "" } { + verbose "board is $board, is remote" 3; + return 1; + } else { + verbose "board is $board, host is local" 3; + return 0; + } + } + + if { $board == "target" } { + global current_target_name + + if [info exists current_target_name] { + # This shouldn't happen, but we'll be paranoid anyway. + if { $current_target_name != "target" } { + return [is_remote $current_target_name]; + } + } + return 0; + } + if [board_info $board exists isremote] { + verbose "board is $board, isremote is [board_info $board isremote]" 3; + return [board_info $board isremote]; + } + return 1; +} +# +# If this is a canadian (3 way) cross. This means the tools are +# being built with a cross compiler for another host. +# +proc is3way {} { + global host_triplet + global build_triplet + + if ![info exists build_triplet] { + set build_triplet ${host_triplet} + } + verbose "Checking $host_triplet against $build_triplet" 2 + if { "$build_triplet" == "$host_triplet" } { + return 0 + } + return 1 +} + +# +# Check host triplet for pattern +# +# With no arguments it returns the triplet string. +# +proc ishost { pattern } { + global host_triplet + + if [string match "" $pattern] { + return $host_triplet + } + verbose "Checking pattern \"$pattern\" with $host_triplet" 2 + + if [string match "$pattern" $host_triplet] { + return 1 + } else { + return 0 + } +} + +# +# Check target triplet for pattern +# +# With no arguments it returns the triplet string. +# Returns 1 if the target looked for, or 0 if not. +# +proc istarget { args } { + global target_triplet + + # if no arg, return the config string + if [string match "" $args] { + if [info exists target_triplet] { + return $target_triplet + } else { + perror "No target configuration names found." + } + } + + set triplet [lindex $args 0] + + # now check against the cannonical name + if [info exists target_triplet] { + verbose "Checking \"$triplet\" against \"$target_triplet\"" 2 + if [string match $triplet $target_triplet] { + return 1 + } + } + + # nope, no match + return 0 +} + +# +# Check to see if we're running the tests in a native environment +# +# Returns 1 if running native, 0 if on a target. +# +proc isnative { } { + global target_triplet + global build_triplet + + if [string match $build_triplet $target_triplet] { + return 1 + } + return 0 +} + +# +# unknown -- called by expect if a proc is called that doesn't exist +# +proc unknown { args } { + global errorCode + global errorInfo + global exit_status + + clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist." + if [info exists errorCode] { + send_error "The error code is $errorCode\n" + } + if [info exists errorInfo] { + send_error "The info on the error is:\n$errorInfo\n" + } + + set exit_status 1; + log_and_exit; +} + +# +# Print output to stdout (or stderr) and to log file +# +# If the --all flag (-a) option was used then all messages go the the screen. +# Without this, all messages that start with a keyword are written only to the +# detail log file. All messages that go to the screen will also appear in the +# detail log. This should only be used by the framework itself using pass, +# fail, xpass, xfail, warning, perror, note, untested, unresolved, or +# unsupported procedures. +# +proc clone_output { message } { + global sum_file + global all_flag + + if { $sum_file != "" } { + puts $sum_file "$message" + } + + regsub "^\[ \t\]*(\[^ \t\]+).*$" "$message" "\\1" firstword; + case "$firstword" in { + {"PASS:" "XFAIL:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} { + if $all_flag { + send_user "$message\n" + return "$message" + } else { + send_log "$message\n" + } + } + {"ERROR:" "WARNING:" "NOTE:"} { + send_error "$message\n" + return "$message" + } + default { + send_user "$message\n" + return "$message" + } + } +} + +# +# Reset a few counters. +# +proc reset_vars {} { + global test_names test_counts; + global warncnt errcnt; + + # other miscellaneous variables + global prms_id + global bug_id + + # reset them all + set prms_id 0; + set bug_id 0; + set warncnt 0; + set errcnt 0; + foreach x $test_names { + set test_counts($x,count) 0; + } + + # Variables local to this file. + global warning_threshold perror_threshold + set warning_threshold 3 + set perror_threshold 1 +} + +proc log_and_exit {} { + global exit_status; + global tool mail_logs outdir mailing_list; + + log_summary total; + # extract version number + if {[info procs ${tool}_version] != ""} { + if {[catch "${tool}_version" output]} { + warning "${tool}_version failed:\n$output" + } + } + close_logs + cleanup + verbose -log "runtest completed at [timestamp -format %c]" + if $mail_logs { + mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log" + } + remote_close host + remote_close target + exit $exit_status +} +# +# Print summary of all pass/fail counts +# +proc log_summary { args } { + global tool + global sum_file + global exit_status + global mail_logs + global outdir + global mailing_list + global current_target_name + global test_counts; + global testcnt; + + if { [llength $args] == 0 } { + set which "count"; + } else { + set which [lindex $args 0]; + } + + if { [llength $args] == 0 } { + clone_output "\n\t\t=== $tool Summary for $current_target_name ===\n" + } else { + clone_output "\n\t\t=== $tool Summary ===\n" + } + + # If the tool set `testcnt', it wants us to do a sanity check on the + # total count, so compare the reported number of testcases with the + # expected number. Maintaining an accurate count in `testcnt' isn't easy + # so it's not clear how often this will be used. + if [info exists testcnt] { + if { $testcnt > 0 } { + set totlcnt 0; + # total all the testcases reported + foreach x { FAIL PASS XFAIL XPASS UNTESTED UNRESOLVED UNSUPPORTED } { + incr totlcnt test_counts($x,$which); + } + set testcnt test_counts(total,$which); + + if { $testcnt>$totlcnt || $testcnt<$totlcnt } { + if { $testcnt > $totlcnt } { + set mismatch "unreported [expr $testcnt-$totlcnt]" + } + if { $testcnt < $totlcnt } { + set mismatch "misreported [expr $totlcnt-$testcnt]" + } + } else { + verbose "# of testcases run $testcnt" + } + + if [info exists mismatch] { + clone_output "### ERROR: totals do not equal number of testcases run" + clone_output "### ERROR: # of testcases expected $testcnt" + clone_output "### ERROR: # of testcases reported $totlcnt" + clone_output "### ERROR: # of testcases $mismatch\n" + } + } + } + foreach x { PASS FAIL XPASS XFAIL UNRESOLVED UNTESTED UNSUPPORTED } { + set val $test_counts($x,$which); + if { $val > 0 } { + set mess "# of $test_counts($x,name)"; + if { [string length $mess] < 24 } { + append mess "\t"; + } + clone_output "$mess\t$val"; + } + } +} + +# +# Close all open files, remove temp file and core files +# +proc cleanup {} { + global sum_file + global exit_status + global done_list + global subdir + + #catch "exec rm -f [glob xgdb core *.x *.o *_soc a.out]" + #catch "exec rm -f [glob -nocomplain $subdir/*.o $subdir/*.x $subdir/*_soc]" +} + +# +# Setup a flag to control whether a failure is expected or not +# +# Multiple target triplet patterns can be specified for targets +# for which the test fails. A bug report ID can be specified, +# which is a string without '-'. +# +proc setup_xfail { args } { + global xfail_flag + global xfail_prms + + set xfail_prms 0 + set argc [ llength $args ] + for { set i 0 } { $i < $argc } { incr i } { + set sub_arg [ lindex $args $i ] + # is a prms number. we assume this is a string with no '-' characters + if [regexp "^\[^\-\]+$" $sub_arg] { + set xfail_prms $sub_arg + continue + } + if [istarget $sub_arg] { + set xfail_flag 1 + continue + } + } +} + + +# check to see if a conditional xfail is triggered +# message {targets} {include} {exclude} +# +# +proc check_conditional_xfail { args } { + global compiler_flags + + set all_args [lindex $args 0] + + set message [lindex $all_args 0] + + set target_list [lindex $all_args 1] + verbose "Limited to targets: $target_list" 3 + + # get the list of flags to look for + set includes [lindex $all_args 2] + verbose "Will search for options $includes" 3 + + # get the list of flags to exclude + if { [llength $all_args] > 3 } { + set excludes [lindex $all_args 3] + verbose "Will exclude for options $excludes" 3 + } else { + set excludes "" + } + + # loop through all the targets, checking the options for each one + verbose "Compiler flags are: $compiler_flags" 2 + + set incl_hit 0 + set excl_hit 0 + foreach targ $target_list { + if [istarget $targ] { + # look through the compiler options for flags we want to see + # this is really messy cause each set of options to look for + # may also be a list. We also want to find each element of the + # list, regardless of order to make sure they're found. + # So we look for lists in side of lists, and make sure all + # the elements match before we decide this is legit. + for { set i 0 } { $i < [llength $includes] } { incr i } { + set incl_hit 0 + set opt [lindex $includes $i] + verbose "Looking for $opt to include in the compiler flags" 2 + foreach j "$opt" { + if [string match "* $j *" $compiler_flags] { + verbose "Found $j to include in the compiler flags" 2 + incr incl_hit + } + } + # if the number of hits we get is the same as the number of + # specified options, then we got a match + if {$incl_hit == [llength $opt]} { + break + } else { + set incl_hit 0 + } + } + # look through the compiler options for flags we don't + # want to see + for { set i 0 } { $i < [llength $excludes] } { incr i } { + set excl_hit 0 + set opt [lindex $excludes $i] + verbose "Looking for $opt to exclude in the compiler flags" 2 + foreach j "$opt" { + if [string match "* $j *" $compiler_flags] { + verbose "Found $j to exclude in the compiler flags" 2 + incr excl_hit + } + } + # if the number of hits we get is the same as the number of + # specified options, then we got a match + if {$excl_hit == [llength $opt]} { + break + } else { + set excl_hit 0 + } + } + + # if we got a match for what to include, but didn't find any reasons + # to exclude this, then we got a match! So return one to turn this into + # an expected failure. + if {$incl_hit && ! $excl_hit } { + verbose "This is a conditional match" 2 + return 1 + } else { + verbose "This is not a conditional match" 2 + return 0 + } + } + } + return 0 +} + +# +# Clear the xfail flag for a particular target +# +proc clear_xfail { args } { + global xfail_flag + global xfail_prms + + set argc [ llength $args ] + for { set i 0 } { $i < $argc } { incr i } { + set sub_arg [ lindex $args $i ] + case $sub_arg in { + "*-*-*" { # is a configuration triplet + if [istarget $sub_arg] { + set xfail_flag 0 + set xfail_prms 0 + } + continue + } + } + } +} + +# +# Record that a test has passed or failed (perhaps unexpectedly) +# +# This is an internal procedure, only used in this file. +# +proc record_test { type message args } { + global exit_status + global prms_id bug_id + global xfail_flag xfail_prms + global errcnt warncnt + global warning_threshold perror_threshold + global pf_prefix + + if { [llength $args] > 0 } { + set count [lindex $args 0]; + } else { + set count 1; + } + if [info exists pf_prefix] { + set message [concat $pf_prefix " " $message]; + } + + # If we have too many warnings or errors, + # the output of the test can't be considered correct. + if { $warning_threshold > 0 && $warncnt >= $warning_threshold + || $perror_threshold > 0 && $errcnt >= $perror_threshold } { + verbose "Error/Warning threshold exceeded: \ + $errcnt $warncnt (max. $perror_threshold $warning_threshold)" + set type UNRESOLVED + } + + incr_count $type; + + switch $type { + PASS { + if $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + FAIL { + set exit_status 1 + if $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + XPASS { + set exit_status 1 + if { $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } + } + XFAIL { + if { $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } + } + UNTESTED { + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + UNRESOLVED { + set exit_status 1 + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + UNSUPPORTED { + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + default { + perror "record_test called with bad type `$type'" + set errcnt 0 + return + } + } + + if $bug_id { + set message [concat $message "\t(BUG $bug_id)"] + } + + global multipass_name + if { $multipass_name != "" } { + set message [format "$type: %s: $message" "$multipass_name"] + } else { + set message "$type: $message" + } + clone_output "$message" + + # If a command name exists in the $local_record_procs associative + # array for this type of result, then invoke it. + + set lowcase_type [string tolower $type] + global local_record_procs + if {[info exists local_record_procs($lowcase_type)]} { + $local_record_procs($lowcase_type) "$message" + } + + # Reset these so they're ready for the next test case. We don't reset + # prms_id or bug_id here. There may be multiple tests for them. Instead + # they are reset in the main loop after each test. It is also the + # testsuite driver's responsibility to reset them after each testcase. + set warncnt 0 + set errcnt 0 + set xfail_flag 0 + set xfail_prms 0 +} + +# +# Record that a test has passed +# +proc pass { message } { + global xfail_flag compiler_conditional_xfail_data + + # if we have a conditional xfail setup, then see if our compiler flags match + if [ info exists compiler_conditional_xfail_data ] { + if [check_conditional_xfail $compiler_conditional_xfail_data] { + set xfail_flag 1 + } + unset compiler_conditional_xfail_data + } + + if $xfail_flag { + record_test XPASS $message + } else { + record_test PASS $message + } +} + +# +# Record that a test has failed +# +proc fail { message } { + global xfail_flag compiler_conditional_xfail_data + + # if we have a conditional xfail setup, then see if our compiler flags match + if [ info exists compiler_conditional_xfail_data ] { + if [check_conditional_xfail $compiler_conditional_xfail_data] { + set xfail_flag 1 + } + unset compiler_conditional_xfail_data + } + + if $xfail_flag { + record_test XFAIL $message + } else { + record_test FAIL $message + } +} + +# +# Record that a test has passed unexpectedly +# +proc xpass { message } { + record_test XPASS $message +} + +# +# Record that a test has failed unexpectedly +# +proc xfail { message } { + record_test XFAIL $message +} + +# +# Set warning threshold +# +proc set_warning_threshold { threshold } { + set warning_threshold $threshold +} + +# +# Get warning threshold +# +proc get_warning_threshold { } { + return $warning_threshold +} + +# +# Prints warning messages +# These are warnings from the framework, not from the tools being tested. +# It takes a string, and an optional number and returns nothing. +# +proc warning { args } { + global warncnt + + if { [llength $args] > 1 } { + set warncnt [lindex $args 1] + } else { + incr warncnt + } + set message [lindex $args 0] + + clone_output "WARNING: $message" + + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } +} + +# +# Prints error messages +# These are errors from the framework, not from the tools being tested. +# It takes a string, and an optional number and returns nothing. +# +proc perror { args } { + global errcnt + + if { [llength $args] > 1 } { + set errcnt [lindex $args 1] + } else { + incr errcnt + } + set message [lindex $args 0] + + clone_output "ERROR: $message" + + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } +} + +# +# Prints informational messages +# +# These are messages from the framework, not from the tools being tested. +# This means that it is currently illegal to call this proc outside +# of dejagnu proper. +# +proc note { message } { + clone_output "NOTE: $message" + + # ??? It's not clear whether we should do this. Let's not, and only do + # so if we find a real need for it. + #global errorInfo + #if [info exists errorInfo] { + # unset errorInfo + #} +} + +# +# untested -- mark the test case as untested +# +proc untested { message } { + record_test UNTESTED $message +} + +# +# Mark the test case as unresolved +# +proc unresolved { message } { + record_test UNRESOLVED $message +} + +# +# Mark the test case as unsupported +# +# Usually this is used for a test that is missing OS support. +# +proc unsupported { message } { + record_test UNSUPPORTED $message +} + +# +# Set up the values in the test_counts array (name and initial totals). +# +proc init_testcounts { } { + global test_counts test_names; + set test_counts(TOTAL,name) "testcases run" + set test_counts(PASS,name) "expected passes" + set test_counts(FAIL,name) "unexpected failures" + set test_counts(XFAIL,name) "expected failures" + set test_counts(XPASS,name) "unexpected successes" + set test_counts(WARNING,name) "warnings" + set test_counts(ERROR,name) "errors" + set test_counts(UNSUPPORTED,name) "unsupported tests" + set test_counts(UNRESOLVED,name) "unresolved testcases" + set test_counts(UNTESTED,name) "untested testcases" + set j ""; + + foreach i [lsort [array names test_counts]] { + regsub ",.*$" "$i" "" i; + if { $i == $j } { + continue; + } + set test_counts($i,total) 0; + lappend test_names $i; + set j $i; + } +} + +# +# Increment NAME in the test_counts array; the amount to increment can be +# is optional (defaults to 1). +# +proc incr_count { name args } { + global test_counts; + + if { [llength $args] == 0 } { + set count 1; + } else { + set count [lindex $args 0]; + } + if [info exists test_counts($name,count)] { + incr test_counts($name,count) $count; + incr test_counts($name,total) $count; + } else { + perror "$name doesn't exist in incr_count" + } +} + + +# +# Create an exp_continue proc if it doesn't exist +# +# For compatablity with old versions. +# +global argv0 +if ![info exists argv0] { + proc exp_continue { } { + continue -expect + } +} diff --git a/lib/ftp.exp b/lib/ftp.exp new file mode 100644 index 0000000..641f112 --- /dev/null +++ b/lib/ftp.exp @@ -0,0 +1,246 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# +# Support downloading files using ftp. +# + +# +# Open a connection to HOST. +# +proc ftp_open { host } { + set prompt "ftp>" + global board_info + + if [board_info $host exists name] { + set host [board_info $host name]; + } + + if [board_info $host exists ftp_fileid] { + return [board_info $host ftp_fileid]; + } + + if [board_info $host exists hostname] { + set remotehost [board_info $host hostname]; + } else { + set remotehost $host; + } + + # LoseQVT tends to get stuck sometimes; we'll loop around a few million + # times when it gets a "connection refused". + set spawn_id -1; + set count 3; + while { $spawn_id < 0 && $count >= 0 } { + spawn ftp -n $remotehost; + expect { + -i $spawn_id -re ".*220.*$prompt" { } + -i $spawn_id -re ".*Connection refused.*$prompt" { + sleep 2; + send "open $remotehost\n"; + exp_continue + } + -i $spawn_id default { + close -i $spawn_id; + wait -i $spawn_id; + set spawn_id -1; + } + } + incr count -1; + } + if { $spawn_id < 0 } { + return -1; + } + set board_info($host,ftp_fileid) $spawn_id; + if [board_info $host exists ftp_username] { + if [board_info $host exists ftp_password] { + set command "user [board_info $host ftp_username] [board_info $host ftp_password]\n"; + } else { + set command "user [board_info $host ftp_username]\n"; + } + send "$command" + expect { + -i $spawn_id -re ".*230.*$prompt" { } + -i $spawn_id default { + close -i $spawn_id; + wait -i $spawn_id; + return -1; + } + } + } + set timeout 15 + send -i $spawn_id "binary\n" + expect { + -i $spawn_id -re "200.*$prompt" { } + -i $spawn_id timeout { + close -i $spawn_id; + wait -i $spawn_id; + return -1 + } + } + if [board_info $host exists ftp_directory] { + send "cd [board_info $host ftp_directory]\n"; + expect { + -i $spawn_id -re "250.*$prompt" { } + -i $spawn_id default { + close -i $spawn_id; + wait -i $spawn_id; + return -1; + } + } + } + + if [board_info $host exists ftp_no_passive] { + send "passive\n"; + expect { + -i $spawn_id -re "Passive mode off.*$prompt" { } + -i $spawn_id -re "Passive mode on.*$prompt" { + send "passive\n"; + exp_continue; + } + -i $spawn_id -re ".*$prompt" { } + } + } + + set board_info($host,ftp_fileid) $spawn_id; + return $spawn_id; +} + +# +# Grab REMOTEFILE from HOST and store it as LOCALFILE. +# +proc ftp_upload { host remotefile localfile } { + set prompt "ftp>" + + verbose "ftping $remotefile from $host to $localfile" + set timeout 15 + set spawn_id [ftp_open $host]; + if { $spawn_id < 0 } { + return ""; + } + set loop 1; + + while { $loop } { + send -i $spawn_id "get $remotefile $localfile\n"; + expect { + -i $spawn_id -re ".*Too many open files.*$prompt" { + ftp_close $host; + } + -i $spawn_id -re ".*No such file or directory.*$prompt" { + set loop 0; + set remotefile ""; + } + -i $spawn_id -re "(^|\[\r\n\])226.*$prompt" { set loop 0; } + -i $spawn_id -re "(^|\[\r\n\])\[0-9\]\[0-9\]\[0-9\].*$prompt" { + set loop 0; + set remotefile ""; + } + -i $spawn_id default { + ftp_close $host; + } + } + if { $loop } { + set spawn_id [ftp_open $host]; + if { $spawn_id < 0 } { + return ""; + } + } + } + return $localfile; +} + +# +# Download LOCALFILE to HOST as REMOTEFILE. +# +proc ftp_download { host localfile remotefile } { + set prompt "ftp>" + + verbose "putting $localfile $remotefile" + + if [board_info $host exists hostname] { + set remotehost [board_info $host hostname]; + } else { + set remotehost $host; + } + + set spawn_id [ftp_open $host]; + if { $spawn_id < 0 } { + return ""; + } + set loop 1; + + while { $loop } { + send -i $spawn_id "put $localfile $remotefile\n" + expect { + -i $spawn_id -re ".*Too many open files.*$prompt" { + ftp_close $host; + } + -i $spawn_id -re ".*No such file or directory.*$prompt" { + set loop 0; + set remotefile ""; + } + -re "(^|\[\r\n\])150.*connection for (.*) \[(\]\[0-9.,\]+\\)\[\r\n\]" { + set remotefile $expect_out(2,string); + exp_continue; + } + -i $spawn_id -re "(^|\[\r\n\])226.*$prompt" { + set loop 0; + } + -i $spawn_id -re "Timeout.*$prompt" { + ftp_close $host; + } + -i $spawn_id -re "(^|\[\r\n\])\[0-9\]\[0-9\]\[0-9\].*$prompt" { + set loop 0; + set remotefile ""; + } + -i $spawn_id default { + ftp_close $host; + } + } + if { $loop } { + set spawn_id [ftp_open $host]; + if { $spawn_id < 0 } { + return ""; + } + } + } + return $remotefile; +} + +# +# Close the connection. +# +proc ftp_close { host } { + global board_info + + if [board_info $host exists name] { + set host [board_info $host name]; + } + + if ![board_info $host exists ftp_fileid] { + return ""; + } + + set spawn_id [board_info $host ftp_fileid]; + unset board_info($host,ftp_fileid); + + send -i $spawn_id "quit\n" + close -i $spawn_id + wait -i $spawn_id; + return ""; +} diff --git a/lib/kermit.exp b/lib/kermit.exp new file mode 100644 index 0000000..6e1ac37 --- /dev/null +++ b/lib/kermit.exp @@ -0,0 +1,180 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# +# Connect to DEST using kermit. Note that we're just using kermit as a +# simple serial or network connect program; we don't actually use Kermit +# protocol to do downloads. +# returns -1 if it failed, otherwise it returns +# the spawn_id. +# +proc kermit_open { dest args } { + global spawn_id + global board_info + + if [board_info $dest exists name] { + set dest [board_info $dest name]; + } + if [board_info ${dest} exists serial] { + set port [board_info ${dest} serial]; + set device "-l [board_info ${dest} serial]" + if [board_info ${dest} exists baud] { + append device " -b [board_info ${dest} baud]" + } + } else { + set port [board_info ${dest} netport]; + set device "-j [board_info ${dest} netport]"; + } + + set tries 0 + set result -1 + verbose "kermit $device" + eval spawn kermit $device + if { $spawn_id < 0 } { + perror "invalid spawn id from kermit" + return -1 + } + + expect { + -re ".*ermit.*>.*$" { + send "c\n" + expect { + -re "Connecting to.*$port.*Type the escape character followed by C to.*options.*\[\r\n\]$" { + verbose "Got prompt\n" + set result 0 + incr tries + } + timeout { + warning "Never got prompt from Kermit." + set result -1 + incr tries + if { $tries <= 2 } { + exp_continue + } + } + } + } + -re "Connection Closed.*$" { + perror "Never connected." + set result -1 + incr tries + if { $tries <= 2 } { + exp_continue + } + } + timeout { + warning "Timed out trying to connect." + set result -1 + incr tries + if { $tries<=2 } { + exp_continue + } + } + } + + if { $result < 0 } { + perror "Couldn't connect after $tries tries." + if [info exists board_info($dest,fileid)] { + unset board_info($dest,fileid); + } + return -1 + } else { + verbose "Kermit connection established with spawn_id $spawn_id." + set board_info($dest,fileid) $spawn_id + kermit_command $dest "set file type binary" "set transfer display none" + if [board_info $dest exists transmit_pause] { + kermit_command $dest "set transmit pause [board_info $dest transmit_pause]" + } + return $spawn_id + } +} + +# +# Send a list of commands to the Kermit session connected to DEST. +# +proc kermit_command { dest args } { + if [board_info $dest exists name] { + set dest [board_info $dest name]; + } + set shell_id [board_info $dest fileid]; + # Sometimes we have to send multiple ^\c sequences. Don't know + # why. + set timeout 2; + for { set i 1; } {$i<=5} {incr i} { + send -i $shell_id "c"; + expect { + -i $shell_id -re ".*Back at.*ermit.*>.*$" { set i 10;} + -i $shell_id timeout { + if { $i > 2 } { + warning "Unable to get prompt from kermit."; + } + } + } + } + foreach command $args { + set timeout 120 + send -i $shell_id "${command}\r"; + expect { + -i $shell_id -re ".*ermit.*>.*$" { } + -i $shell_id timeout { + perror "Response failed from kermit."; + return -1; + } + } + } + send -i $shell_id "c\r"; + expect { + -i $shell_id -re ".*other options.\[\r\n\]+" { } + -i $shell_id timeout { + perror "Unable to resume kermit connection."; + return -1; + } + } + return 0; +} + + +# +# Send STRING to DEST. +# +proc kermit_send { dest string args } { + if [board_info $dest exists transmit_pause] { + set f [open "/tmp/fff" "w"]; + puts -nonewline $f "$string"; + close $f; + set result [remote_transmit $dest /tmp/fff]; + remote_file build delete "/tmp/fff"; + return "$result"; + } else { + return [standard_send $dest $string]; + } +} + +# +# Transmit FILE directly to DEST as raw data. No translation is +# performed. +# +proc kermit_transmit { dest file args } { + if [board_info $dest exists transmit_pause] { + kermit_command $dest "transmit $file"; + return ""; + } else { + return [standard_transmit $dest $file]; + } +} diff --git a/lib/libgloss.exp b/lib/libgloss.exp new file mode 100644 index 0000000..8c5bf87 --- /dev/null +++ b/lib/libgloss.exp @@ -0,0 +1,843 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# this contains a list of gcc options and their respective directories. + +# +# Find the pieces of libgloss for testing the GNU development tools +# needed to link a set of object files into an executable. +# This usually means setting the -L and -B paths correctly. +# +proc libgloss_link_flags { args } { + global target_cpu + global srcdir + + # libgloss doesn't work native + if [isnative] { + return "" + } + + # if we're on a remote host, we can't search for the file, so we can only + # use an installed compiler, so we don't add any paths here. + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + # map the target_cpu to the proper libgloss directory. unfortunately, these + # directory names are hardcoded into libgloss. + switch -glob -- $target_cpu { + "sparc86x" { + set cpu sparc + } + "sparclite" { + set cpu sparc + } + "sparclet" { + set cpu sparc + } + "sparc64*" { + set cpu sparc + } + "hppa*" { + set cpu pa + } + "mips*" { + set cpu mips + } + "powerpc*" { + set cpu rs6000 + } + "d10v*" { + set cpu libnosys + } + default { + set cpu $target_cpu + } + } + + set gloss_srcdir "" + # look for the libgloss srcdir sp we can find the linker scripts + set gloss_srcdir [lookfor_file ${srcdir} libgloss/$cpu] + + # set the proper paths for gcc if the target subdir exists, else assume we + # have no libgloss support for this target. + if { $gloss_srcdir == "" } { + return "" + } + if [file exists $gccpath/libgloss/$cpu] { + verbose "Libgloss path is $gccpath/libgloss/$cpu" 2 + return "-B$gccpath/libgloss/$cpu/ -L$gccpath/libgloss/$cpu -L$gloss_srcdir" + } else { + verbose -log "No libgloss support for this target." 2 + return "" + } +} + +# There aren't any, but we'll be orthogonal here. + +proc libgloss_include_flags { args } { + return "" +} + +# +# Find the newlib libraries in the current source tree. +# +proc newlib_link_flags { args } { + global tool_root_dir + + # libgloss doesn't work native + if [isnative] { + return "" + } + + # if we're on a remote host, we can't search for the file, so we can only + # use an installed compiler, so we don't add any paths here. + if [is_remote host] { + return "" + } + + set ld_script_path [lookfor_file ${tool_root_dir} "ld/ldscripts"]; + if { $ld_script_path != "" } { + set result "-L[file dirname $ld_script_path]" + } else { + set result "" + } + + set gccpath "[get_multilibs]" + + verbose "Looking for $gccpath/newlib" + if [file exists $gccpath/newlib] { + verbose "Newlib path is $gccpath/newlib" + return "$result -B$gccpath/newlib/ -L$gccpath/newlib" + } else { + verbose "No newlib support for this target" + return "$result" + } +} + +proc newlib_include_flags { args } { + global srcdir + + if [isnative] { + return "" + } + + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + if [file exists $gccpath/newlib] { + verbose "Newlib path is $gccpath/newlib" + + set newlib_dir [lookfor_file ${srcdir} newlib/libc/include/assert.h] + if { ${newlib_dir} != "" } { + set newlib_dir [file dirname ${newlib_dir}] + } + return " -I$gccpath/newlib/targ-include -I${newlib_dir}" + } else { + verbose "No newlib support for this target" + } +} + +proc libio_include_flags { args } { + global srcdir + global tool_root_dir + + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + if { $gccpath == "" } { + set gccpath "$tool_root_dir"; + } + + set libio_bin_dir [lookfor_file ${gccpath} libio/_G_config.h]; + + # linux doesn't build _G_config.h and the test above fails, so + # we search for iostream.list too. + if { $libio_bin_dir == "" } { + set libio_bin_dir [lookfor_file ${gccpath} libio/iostream.list]; + } + + set libio_src_dir [lookfor_file ${srcdir} libio/Makefile.in] + if { $libio_bin_dir != "" && $libio_src_dir != "" } { + set libio_src_dir [file dirname ${libio_src_dir}] + set libio_bin_dir [file dirname ${libio_bin_dir}]; + return " -I${libio_src_dir} -I${libio_bin_dir}" + } else { + return "" + } +} + +proc libio_link_flags { args } { + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + set libio_dir [lookfor_file ${gccpath} libio/libio.a] + if { $libio_dir != "" } { + return "-L[file dirname ${libio_dir}]" + } else { + return "" + } +} + +proc g++_include_flags { args } { + global srcdir + + if [is_remote host] { + return "" + } + + set gccpath [get_multilibs] + set libio_dir "" + set flags "" + + set dir [lookfor_file ${srcdir} libg++] + if { ${dir} != "" } { + append flags "-I${dir} -I${dir}/src " + } + set dir [lookfor_file ${srcdir} libstdc++] + if { ${dir} != "" } { + append flags "-I${dir} -I${dir}/stl" + } + return "$flags" +} + +proc g++_link_flags { args } { + global srcdir + global ld_library_path + + set gccpath [get_multilibs]; + set libio_dir "" + set flags "" + set ld_library_path "." + + if { $gccpath != "" } { + if [file exists "${gccpath}/lib/libstdc++.a"] { + append ld_library_path ":${gccpath}/lib" + } + if [file exists "${gccpath}/libg++/libg++.a"] { + append flags "-L${gccpath}/libg++ " + append ld_library_path ":${gccpath}/libg++" + } + if [file exists "${gccpath}/libstdc++/libstdc++.a"] { + append flags "-L${gccpath}/libstdc++ " + append ld_library_path ":${gccpath}/libstdc++" + } + if [file exists "${gccpath}/libiberty/libiberty.a"] { + append flags "-L${gccpath}/libiberty " + } + if [file exists "${gccpath}/librx/librx.a"] { + append flags "-L${gccpath}/librx " + } + } else { + global tool_root_dir; + + set libgpp [lookfor_file ${tool_root_dir} libg++]; + if { $libgpp != "" } { + append flags "-L${libgpp} "; + append ld_library_path ":${libgpp}" + } + set libstdcpp [lookfor_file ${tool_root_dir} libstdc++]; + if { $libstdcpp != "" } { + append flags "-L${libstdcpp} "; + append ld_library_path ":${libstdcpp}" + } + set libiberty [lookfor_file ${tool_root_dir} libiberty]; + if { $libiberty != "" } { + append flags "-L${libiberty} "; + } + set librx [lookfor_file ${tool_root_dir} librx]; + if { $librx != "" } { + append flags "-L${librx} "; + } + } + return "$flags" +} + +proc libstdc++_include_flags { args } { + global srcdir + + if [is_remote host] { + return "" + } + + set gccpath [get_multilibs] + set libio_dir "" + set flags "" + + set dir [lookfor_file ${srcdir} libstdc++] + if { ${dir} != "" } { + append flags "-I${dir} -I${dir}/stl" + } + return "$flags" +} + +proc libstdc++_link_flags { args } { + global srcdir + global ld_library_path + + set gccpath [get_multilibs]; + set libio_dir "" + set flags "" + + if { $gccpath != "" } { + if [file exists "${gccpath}/libstdc++/libstdc++.a"] { + append flags "-L${gccpath}/libstdc++ " + append ld_library_path ":${gccpath}/libstdc++" + } + if [file exists "${gccpath}/libiberty/libiberty.a"] { + append flags "-L${gccpath}/libiberty " + } + if [file exists "${gccpath}/librx/librx.a"] { + append flags "-L${gccpath}/librx " + } + } else { + global tool_root_dir; + + set libstdcpp [lookfor_file ${tool_root_dir} libstdc++]; + if { $libstdcpp != "" } { + append flags "-L${libstdcpp} "; + append ld_library_path ":${libstdcpp}" + } + set libiberty [lookfor_file ${tool_root_dir} libiberty]; + if { $libiberty != "" } { + append flags "-L${libiberty} "; + } + set librx [lookfor_file ${tool_root_dir} librx]; + if { $librx != "" } { + append flags "-L${librx} "; + } + } + return "$flags" +} + +# +# Get the list of directories and -m options for gcc. This is kinda bogus that +# generic testing software needs support for gcc hardwired in, but to make +# testing the GNU tools work right, there didn't seem to be any other way. +# + +proc get_multilibs { args } { + global target_alias + global board + global board_info + + # if we're on a remote host, we can't search for the file, so we can only + # use an installed compiler, so we don't add any paths here. + if [is_remote host] { + return "" + } + + if [info exists board] { + set target_board $board; + } else { + set target_board [target_info name]; + } + + if { [llength $args] == 0 } { + if [board_info $target_board exists multitop] { + return "[board_info $target_board multitop]"; + } + + set board_info($target_board,multitop) "" + } + + if { [board_info $target_board exists compiler] } { + set compiler [board_info $target_board compiler]; + } else { + set compiler [find_gcc]; + } + + if { $compiler == "" } { + return ""; + } + + foreach x "$compiler" { + if [regexp "^-B" "$x"] { + regsub "^-B" "$x" "" comp_base_dir; + set comp_base_dir [file dirname $comp_base_dir]; + break; + } + } + if { [llength $args] > 0 } { + set mopts [lindex $args 0]; + } else { + if { [board_info $target_board exists multilib_flags] } { + set mopts [board_info $target_board multilib_flags]; + } else { + set mopts "" + } + } + + regsub "^-" $mopts "" moptions + regsub -all " -" $moptions " " dirty_moptions + set moptions "" + foreach x [split $dirty_moptions " "] { + if { $x != "" && [lsearch -exact $moptions $x] < 0 } { + lappend moptions $x + } + } + + regexp "/.* " $compiler compiler + set compiler [string trimright $compiler " "] + verbose "compiler is $compiler" + + if { [which $compiler] == 0 } { + return ""; + } + + if ![info exists comp_base_dir] { + set comp_base_dir [file dirname [file dirname [file dirname [file dirname [file dirname [exec $compiler --print-prog-name=cc1]]]]]]; + } + + # set output [exec $objdump_name --file-headers objfmtst.o ] + set default_multilib [exec $compiler --print-multi-lib] + set default_multilib [lindex $default_multilib 0]; + set extra [string trimleft $default_multilib "."] + + # extract the options and their directory names as know by gcc + foreach i "[exec $compiler --print-multi-lib]" { + if {$extra != ""} { + set i [string trimright $i $extra"] + } + set opts "" + set dir "" + regexp -- "\[a-z0-9=/\.-\]*;" $i dir + set dir [string trimright $dir "\;@"] + regexp -- "\;@*\[\@a-zA-Z0-9=/\.-\]*" $i opts + set opts [split [string trimleft $opts "\;@"] "@"] + lappend multilibs "$dir {$opts }" + } + + # extract the MULTILIB_MATCHES from dumpspecs + set multimatches "" + set lines [split [exec $compiler -dumpspecs] "\n"] + for {set i 0} {$i <= [llength $lines] - 1} {incr i 1} { + if {"*multilib_matches:" == "[lindex $lines $i]"} { + set multimatches [lindex $lines [expr $i + 1]] + break + } + } + # if we find some + if {$multimatches != ""} { + # Split it into a list of pairs. If an moptions are the first + # of a pair, then replace it with the second. If an moption + # is not in multimatches, we assume it's not a multilib option + + set splitmatches [split $multimatches ";"] + set multimatches "" + foreach i $splitmatches { + lappend multimatches [split $i " "] + } + verbose "multimatches: $multimatches" 3 + + verbose "options before multimatches: $moptions" 3 + set toptions $moptions + set moptions "" + foreach i $toptions { + foreach j $multimatches { + verbose "comparing [lindex $j 0] == $i" 3 + if {[lindex $j 0] == $i} { + lappend moptions [lindex $j 1] + } + } + } + verbose "options after multimatches: $moptions" 3 + } + + # search for the top level multilib directory + set multitop [lookfor_file "${comp_base_dir}" "${target_alias}"] + if { $multitop == "" } { + set multitop [lookfor_file "${comp_base_dir}" "libraries"] + if { $multitop == "" } { + set multitop "[lookfor_file ${comp_base_dir} gcc/xgcc]" + if { $multitop != "" } { + set multitop [file dirname [file dirname $multitop]]; + } else { + return "" + } + } + } + + # make a list of -m<foo> options from the various compiler config variables + set gccpath "" + + # compare the lists of gcc options with the list of support multilibs + verbose "Supported multilibs are: $multilibs" 3 + set best 0; + foreach i "$multilibs" { + set hits 0 + set opts [lindex $i 1]; + if { [llength $opts] <= [llength $moptions] } { + foreach j "$moptions" { + # see if all the -m<foo> options match any of the multilibs + verbose "Looking in $i for $j" 3 + if { [lsearch -exact $opts $j] >= 0 } { + incr hits + } + } + + if { $hits > $best } { + verbose "[lindex $i 0] is better, using as gcc path" 2 + set gccpath "[lindex $i 0]" + set best $hits; + } + } + } + if ![info exists multitop] { + return ""; + } + + verbose "gccpath is $gccpath" 3 + + if [file exists $multitop/$gccpath] { + verbose "GCC path is $multitop/$gccpath" 3 + if { [llength $args] == 0 } { + set board_info($target_board,multitop) "$multitop/$gccpath" + } + return "$multitop/$gccpath" + } else { + verbose "GCC path is $multitop" 3 + if { [llength $args] == 0 } { + set board_info($target_board,multitop) "$multitop" + } + return "$multitop" + } +} + +proc find_binutils_prog { name } { + global tool_root_dir; + + if ![is_remote host] { + + set file [lookfor_file $tool_root_dir $name]; + if { $file == "" } { + set file [lookfor_file $tool_root_dir ${name}-new]; + } + if { $file == "" } { + set file [lookfor_file $tool_root_dir binutils/$name]; + } + if { $file == "" } { + set file [lookfor_file $tool_root_dir binutils/${name}-new]; + } + if { $file != "" } { + set NAME "$file"; + } else { + set NAME [transform $name]; + } + } else { + set NAME [transform $name] + } + return $NAME; +} + +proc find_gcc {} { + global tool_root_dir + + if ![is_remote host] { + set file [lookfor_file $tool_root_dir xgcc]; + if { $file == "" } { + set file [lookfor_file $tool_root_dir gcc/xgcc]; + } + if { $file != "" } { + set CC "$file -B[file dirname $file]/"; + } else { + set CC [transform gcc]; + } + } else { + set CC [transform gcc] + } + return $CC; +} + +proc find_gcj {} { + global tool_root_dir + + if ![is_remote host] { + set file [lookfor_file $tool_root_dir gcj]; + if { $file == "" } { + set file [lookfor_file $tool_root_dir gcc/gcj]; + } + if { $file != "" } { + set CC "$file -B[file dirname $file]/"; + } else { + set CC [transform gcj]; + } + } else { + set CC [transform gcj] + } + return $CC; +} + +proc find_g++ {} { + global tool_root_dir + + if ![is_remote host] { + set file [lookfor_file $tool_root_dir g++]; + if { $file == "" } { + set file [lookfor_file $tool_root_dir gcc/g++]; + } + if { $file != "" } { + set CC "$file -B[file dirname $file]/"; + } else { + set CC [transform g++]; + } + } else { + set CC [transform g++] + } + return $CC; +} + +proc find_g77 {} { + global tool_root_dir + + if ![is_remote host] { + set file [lookfor_file $tool_root_dir g77]; + if { $file == "" } { + set file [lookfor_file $tool_root_dir gcc/g77]; + } + if { $file != "" } { + set CC "$file -B[file dirname $file]/"; + } else { + set CC [transform g77]; + } + } else { + set CC [transform g77] + } + return $CC; +} + +proc find_nm {} { + global tool_root_dir + + set NM "" + if ![is_remote host] { + set NM [lookfor_file $tool_root_dir nm-new] + if {$NM == ""} { + set NM [lookfor_file $tool_root_dir binutils/nm-new] + } + } + if { $NM == ""} { + set NM [transform nm]; + } + return $NM; +} + +proc process_multilib_options { args } { + global board; + global board_variant_list; + global is_gdb_remote; + + set is_gdb_remote 0; + + if [board_info $board exists multilib_flags] { + return; + } + eval add_multilib_option $args; + + set multilib_flags ""; + + foreach x $board_variant_list { + regsub -all "^\[ \t\]*" "$x" "" x; + regsub -all "\[ \t\]*$" "$x" "" x; + + if { $x == "" } { + continue; + } + case $x in { + { aout } { + set_board_info obj_format "a.out"; + } + { elf } { + set_board_info obj_format "elf"; + } + { pe } { + set_board_info obj_format "pe"; + } + { ecoff } { + set_board_info obj_format "ecoff"; + } + { stabs } { + set_board_info debug_flags "-gstabs"; + } + { dwarf2 } { + set_board_info debug_flags "-gdwarf2"; + } + { gdb:*=* } { + regsub "^gdb:\[^=\]*=(.*)$" "$x" "\\1" value; + regsub "^gdb:(\[^=\]*)=.*$" "$x" "\\1" variable; + set_board_info $variable "$value"; + } + { gdb*remote } { + set is_gdb_remote 1; + } + { little*endian el EL } { + append multilib_flags " -EL"; + } + { big*endian eb EB } { + append multilib_flags " -EB"; + } + { "soft*float" } { + append multilib_flags " -msoft-float" + } + { "-*" } { + append multilib_flags " $x"; + } + default { + append multilib_flags " -m$x"; + } + } + } + set_board_info multilib_flags $multilib_flags; +} + +proc add_multilib_option { args } { + global board_variant_list + + if ![info exists board_variant_list] { + set board_variant_list "" + } + set board_variant_list [concat $args $board_variant_list]; +} + +proc find_gas { } { + global tool_root_dir + + set AS "" + + if ![is_remote host] { + set AS [lookfor_file $tool_root_dir as-new]; + if { $AS == "" } { + set AS [lookfor_file $tool_root_dir gas/as-new]; + } + } + if { $AS == "" } { + set AS [transform as]; + } + return $AS; +} + +proc find_ld { } { + global tool_root_dir + + set LD "" + + if ![is_remote host] { + set LD [lookfor_file $tool_root_dir ld-new]; + if { $LD == "" } { + set LD [lookfor_file $tool_root_dir ld/ld-new]; + } + } + if { $LD == "" } { + set LD [transform ld]; + } + return $LD; +} + +proc build_wrapper { gluefile } { + global libdir + + if [target_info exists wrap_m68k_aout] { + set flags "additional_flags=-DWRAP_M68K_AOUT"; + set result ""; + } elseif [target_info exists uses_underscores] { + set flags "additional_flags=-DUNDERSCORES"; + set result "-Wl,-wrap,__exit -Wl,-wrap,_main -Wl,-wrap,_abort"; + } else { + set flags ""; + if [target_info exists is_vxworks] { + set flags "additional_flags=-DVXWORKS"; + } + set result "-Wl,-wrap,exit -Wl,-wrap,main -Wl,-wrap,abort"; + } + if [target_info exists wrap_compile_flags] { + lappend flags "additional_flags=[target_info wrap_compile_flags]"; + } + if { [target_compile ${libdir}/testglue.c ${gluefile} object $flags] == "" } { + set gluefile [remote_download host ${gluefile} testglue.o]; + return [list $gluefile $result]; + } else { + return "" + } +} + + +proc winsup_include_flags { args } { + global srcdir + + if [isnative] { + return "" + } + + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + if [file exists $gccpath/winsup] { + verbose "Winsup path is $gccpath/winsup" + + set winsup_dir [lookfor_file ${srcdir} winsup/include/windows.h] + if { ${winsup_dir} != "" } { + set winsup_dir [file dirname ${winsup_dir}] + return " -I${winsup_dir}" + } + } + verbose "No winsup support for this target" + +} +# +# Find the winsup libraries in the current source tree. +# +proc winsup_link_flags { args } { + # libgloss doesn't work native + if [isnative] { + return "" + } + + # if we're on a remote host, we can't search for the file, so we can only + # use an installed compiler, so we don't add any paths here. + if [is_remote host] { + return "" + } + + set gccpath "[get_multilibs]" + + verbose "Looking for $gccpath/winsup" + if [file exists $gccpath/winsup] { + verbose "Winsup path is $gccpath/newlib" + return "-B$gccpath/winsup/ -L$gccpath/winsup" + } else { + verbose "No winsup support for this target" + return "" + } +} diff --git a/lib/mondfe.exp b/lib/mondfe.exp new file mode 100644 index 0000000..b46484e --- /dev/null +++ b/lib/mondfe.exp @@ -0,0 +1,213 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Connect to udi using mondfe +# +# HOSTNAME can be `iss' to talk to the simulator. +# The result is the value of `spawn_id' or -1 for failure. +# +proc mondfe_open { hostname } { + global spawn_id + global board_info + + set retries 0 + set result -1 + + set shell_prompt [board_info $hostname shell_prompt] + if ![board_info $hostname exists mondfe,name] { + perror "Must set board_info(${hostname},mondfe,name)" + return -1; + } + if [board_info $hostname exists mondfe] { + set mondfe [board_info $hostname mondfe]; + } else { + set mondfe "mondfe" + } + + set remote_host [board_info $hostname mondfe,name]; + + if [board_info $hostname exists mondfe_host] { + set rh [board_info $hostname mondfe_host]; + } else { + verbose "Attempting to connect to $hostname via mondfe." + set rh "host"; + } + + set shell_id [remote_spawn $rh "$mondfe -D -TIP $remote_host"]; + + remote_expect $rh 60 { + "$shell_prompt" { + verbose "Got prompt" + set result 0 + } + "*server bind*failed: Address already in use*" { + warning "Socket file already exists." + incr retries + if { $retries <= 2 } { + exp_continue; + } + } + -indices -re ".*(UDIERROR\[^\r\n\]*)\[\r\n\]" { + warning "$expect_out(1,string)" + exp_continue; + } + -indices -re ".*(DFEERROR\[^\r\n\]*)\[\r\n\]" { + warning "$expect_out(1,string)" + exp_continue; + } + timeout { + warning "Timed out trying to connect." + set result -1 + incr retries + if { $retries <= 2 } { + remote_send $rh "\n" + exp_continue; + } + } + } + + if { $result < 0 } { + perror "Couldn't connect after $retries retries." + remote_close $rh; + return -1 + } else { + set board_info($hostname,fileid) $shell_id; + return $shell_id; + } +} + +# +# Downloads using the y (yank) command in mondfe +# +# FILE is a full path name to the file to download. +# Returns 1 if an error occured, 0 otherwise. +# +proc mondfe_ld { dest_machine file } { + global decimal # Regexp to match a decimal number. + + if ![file exists $file] { + perror "$file doesn't exist." + return "" + } + + set shell_prompt [board_info $dest_machine shell_prompt] + + if [board_info $dest_machine exists mondfe_host] { + set remote_host [board_info $dest_machine mondfe_host]; + set file [remote_download $remote_host $file montest] + } else { + set remote_host "host"; + } + + verbose "Downloading $file." 2 + verbose "Shell prompt is $shell_prompt." 3 + set result 1 + remote_send $remote_host "y $file\n" + remote_expect $remote_host 60 { + "y $file" { + exp_continue; + } + -re "loading $file\[\r\n\]+" { + exp_continue; + } + -re "Load(ing|ed) *TEXT section from\[^\r\n\]*\[\r\n\]+" { + verbose -n "." 2 + exp_continue; + } + -re "Load(ing|ed) *LIT section from\[^\r\n\]*\[\r\n\]+" { + verbose -n "." 2 + exp_continue; + } + -re "Load(ing|ed) *DATA section from\[^\r\n\]*\[\r\n\]+" { + verbose -n "." 2 + exp_continue; + } + -re "Clear(ing|ed) *BSS section from\[^\r\n\]*\[\r\n\]+" { + verbose -n "." 2 + exp_continue; + } + -re "(^|\[\r\n\]+)$shell_prompt$" { + verbose "Downloaded $file successfully." 2 + set result 0 + } + -re "Command failed.*$shell_prompt$" { + set result 1 + } + -re "DFEWARNING: $decimal : EMMAGIC: Bad COFF file magic number.*Command failed.*$shell_prompt$" { + warning "Bad COFF file magic number" + set result 1 + } + -re "Ignoring COMMENT section \($decimal bytes\)\[^\r\n\]*\[\r\n\]+" { + verbose "Ignoring COMMENT section" 2 + exp_continue; + } + timeout { + perror "Timed out trying to download $file." + set result 1 + } + } + + if { $result && [info exists expect_out(buffer)] } { + send_log $expect_out(buffer) + } + + if [board_info $dest_machine exists mondfe_host] { + remote_file $remote_machine delete $file + } + + return $result +} + +# +# Exit the remote shell +# +proc mondfe_close { hostname } { + global board_info + + if [board_info $hostname exists mondfe_host] { + set remote_host [board_info $hostname mondfe_host]; + } else { + set remote_host "host"; + } + + if ![board_info $hostname exists fileid] { + return 0; + } + + if [board_info $remote_host exists fileid] { + remote_send $remote_host "q\n" + remote_expect $remote_host 30 { + "Goodbye." { + verbose "Exited mondfe." + } + timeout { + warning "mondfe didn't exit cleanly." + } + } + + remote_close $remote_host; + } + + unset board_info($hostname,fileid); + + return 0; +} diff --git a/lib/remote.exp b/lib/remote.exp new file mode 100644 index 0000000..0bc8ed0 --- /dev/null +++ b/lib/remote.exp @@ -0,0 +1,1265 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# load various protocol support modules + +load_lib "mondfe.exp" +load_lib "xsh.exp" +load_lib "telnet.exp" +load_lib "rlogin.exp" +load_lib "kermit.exp" +load_lib "tip.exp" +load_lib "rsh.exp" +load_lib "ftp.exp" + +# +# Open a connection to a remote host or target. This requires the target_info +# array be filled in with the proper info to work. +# +# type is either "build", "host", "target", or the name of a board loaded +# into the board_info array. The default is target if no name is supplied. +# It returns the spawn id of the process that is the connection. +# + +proc remote_open { args } { + global reboot + + if { [llength $args] == 0 } { + set type "target" + } else { + set type $args + } + + # Shudder... + if { $reboot && $type == "target" } { + reboot_target; + } + + return [call_remote "" open $type]; +} + +proc remote_raw_open { args } { + return [eval call_remote raw open $args]; +} + +# Run the specified COMMANDLINE on the local machine, redirecting input +# to file INP (if non-empty), redirecting output to file OUTP (if non-empty), +# and waiting TIMEOUT seconds for the command to complete before killing +# it. A two-member list is returned; the first member is the exit status +# of the command, the second is any output produced from the command +# (if output is redirected, this may or may not be empty). If output is +# redirected, both stdout and stderr will appear in the specified file. +# +# Caveats: A pipeline is used if input or output is redirected. There +# will be problems with killing the program if a pipeline is used. Either +# the "tee" command or the "cat" command is used in the pipeline if input +# or output is redirected. If the program needs to be killed, /bin/sh and +# the kill command will be invoked. +# +proc local_exec { commandline inp outp timeout } { + # TCL's exec is a pile of crap. It does two very inappropriate things; + # firstly, it has no business returning an error if the program being + # executed happens to write to stderr. Secondly, it appends its own + # error messages to the output of the command if the process exits with + # non-zero status. + # + # So, ok, we do this funny stuff with using spawn sometimes and + # open others because of spawn's inability to invoke commands with + # redirected I/O. We also hope that nobody passes in a command that's + # a pipeline, because spawn can't handle it. + # + # We want to use spawn in most cases, because tcl's pipe mechanism + # doesn't assign process groups correctly and we can't reliably kill + # programs that bear children. We can't use tcl's exec because it has + # no way to timeout programs that hang. *sigh* + # + if { "$inp" == "" && "$outp" == "" } { + set id -1; + set result [catch "eval spawn \{${commandline}\}" pid]; + if { $result == 0 } { + set result2 0; + } else { + set pid 0; + set result2 5; + } + } else { + # Can you say "uuuuuugly"? I knew you could! + # All in the name of non-infinite hangs. + if { $inp != "" } { + set inp "< $inp"; + set mode "r"; + } else { + set mode "w"; + } + + set use_tee 0; + # We add |& cat so that TCL exec doesn't freak out if the + # program writes to stderr. + if { $outp == "" } { + set outp "|& cat" + } else { + set outpf "$outp"; + set outp "> $outp" + if { $inp != "" } { + set use_tee 1; + } + } + # Why do we use tee? Because open can't redirect both input and output. + if { $use_tee } { + set result [catch {open "| ${commandline} $inp |& tee $outpf" RDONLY} id] ; + } else { + set result [catch {open "| ${commandline} $inp $outp" $mode} id] ; + } + + if { $result != 0 } { + global errorInfo + return [list -1 "open of $commandline $inp $outp failed: $errorInfo"]; + } + set pid [pid $id]; + set result [catch "spawn -leaveopen $id" result2]; + } + # Prepend "-" to each pid, to generate the "process group IDs" needed by + # kill. + set pgid "-[join $pid { -}]"; + verbose "pid is $pid $pgid"; + if { $result != 0 || $result2 != 0 } { + # This shouldn't happen. + global errorInfo; + if [info exists errorInfo] { + set foo $errorInfo; + } else { + set foo ""; + } + verbose "spawn -open $id failed, $result $result2, $foo"; + catch "close $id"; + return [list -1 "spawn failed"]; + } + + set got_eof 0; + set output ""; + + # Wait for either $timeout seconds to elapse, or for the program to + # exit. + expect { + -i $spawn_id -timeout $timeout -re ".+" { + append output $expect_out(buffer); + if { [string length $output] < 512000 } { + exp_continue -continue_timer; + } + } + timeout { + warning "program timed out."; + } + eof { + set got_eof 1; + } + } + + # Uuuuuuugh. Now I'm getting really sick. + # If we didn't get an EOF, we have to kill the poor defenseless program. + # However, TCL has no kill primitive, so we have to execute an external + # command in order to execute the execution. (English. Gotta love it.) + if { ! $got_eof } { + verbose "killing $pid $pgid"; + exec sh -c "exec > /dev/null 2>&1 && (kill -2 $pgid || kill -2 $pid) && sleep 5 && (kill -15 $pgid || kill $pid) && sleep 5 && (kill -9 $pgid || kill -9 $pid)" &; + } + # This will hang if the kill doesn't work. Nothin' to do, and it's not ok. + catch "close -i $spawn_id"; + set r2 [catch "wait -i $spawn_id" wres]; + if { $id > 0 } { + set r2 [catch "close $id" res]; + } else { + verbose "waitres is $wres" 2; + if { $r2 == 0 } { + set r2 [lindex $wres 3]; + if { [llength $wres] > 4 } { + if { [lindex $wres 4] == "CHILDKILLED" } { + set r2 1; + } + } + if { $r2 != 0 } { + set res "$wres"; + } else { + set res ""; + } + } else { + set res "wait failed"; + } + } + if { $r2 != 0 || $res != "" || ! $got_eof } { + verbose "close result is $res"; + set status 1; + } else { + set status 0; + } + verbose "output is $output"; + if { $outp == "" } { + return [list $status $output]; + } else { + return [list $status ""]; + } +} + +# +# Execute the supplied program on HOSTNAME. There are four optional arguments; +# the first is a set of arguments to pass to PROGRAM, the second is an +# input file to feed to stdin of PROGRAM, the third is the name of an +# output file where the output from PROGRAM should be written, and +# the fourth is a timeout value (we give up after the specified # of seconds +# has elapsed). +# +# A two-element list is returned. The first value is the exit status of the +# program (-1 if the exec failed). The second is any output produced by +# the program (which may or may not be empty if output from the program was +# redirected). +# +proc remote_exec { hostname program args } { + if { [llength $args] > 0 } { + set pargs [lindex $args 0]; + } else { + set pargs "" + } + + if { [llength $args] > 1 } { + set inp "[lindex $args 1]"; + } else { + set inp "" + } + + if { [llength $args] > 2 } { + set outp "[lindex $args 2]"; + } else { + set outp "" + } + + # 300 is probably a lame default. + if { [llength $args] > 3 } { + set timeout "[lindex $args 3]"; + } else { + set timeout 300 + } + + verbose -log "Executing on $hostname: $program $pargs $inp $outp (timeout = $timeout)" 2; + + # Run it locally if appropriate. + if { ![is_remote $hostname] } { + return [local_exec "$program $pargs" $inp $outp $timeout]; + } else { + return [call_remote "" exec $hostname $program $pargs $inp $outp]; + } +} + +proc standard_exec { hostname args } { + return [eval rsh_exec \"$hostname\" $args]; +} + +# +# Close the remote connection. +# arg - This is the name of the machine whose connection we're closing, +# or target, host or build. +# + +proc remote_close { host } { + while { 1 } { + set result [call_remote "" close "$host"]; + if { [remote_pop_conn $host] != "pass" } { + break; + } + } + return $result; +} + +proc remote_raw_close { host } { + return [call_remote raw close "$host"]; +} + +proc standard_close { host } { + global board_info + + if [board_info ${host} exists fileid] { + set shell_id [board_info ${host} fileid]; + set pid -1; + + verbose "Closing the remote shell $shell_id" 2 + if [board_info ${host} exists fileid_origid] { + set oid [board_info ${host} fileid_origid]; + set pid [pid $oid]; + unset board_info(${host},fileid_origid); + } else { + set result [catch "exp_pid -i $shell_id" pid]; + if { $result != 0 || $pid <= 0 } { + set result [catch "pid $shell_id" pid]; + if { $result != 0 } { + set pid -1; + } + } + } + if { $pid > 0 } { + verbose "doing kill, pid is $pid"; + # This is very, very nasty. Then again, if after did something + # reasonable... + set pgid "-[join $pid { -}]"; + exec sh -c "exec > /dev/null 2>&1 && (kill -2 $pgid || kill -2 $pid) && sleep 5 && (kill $pgid || kill $pid) && sleep 5 && (kill -9 $pgid || kill -9 $pid)" &; + } + verbose "pid is $pid"; + catch "close -i $shell_id"; + if [info exists oid] { + catch "close $oid"; + } + catch "wait -i $shell_id"; + unset board_info(${host},fileid); + verbose "Shell closed."; + } + return 0; +} + +# +# Set the connection into "binary" mode, a.k.a. no processing of input +# characters. +# +proc remote_binary { host } { + return [call_remote "" binary "$host"]; +} + +proc remote_raw_binary { host } { + return [call_remote raw binary "$host"]; +} + + + +proc remote_reboot { host } { + clone_output "\nRebooting ${host}\n"; + # FIXME: don't close the host connection, or all the remote + # procedures will fail. + # remote_close $host; + set status [call_remote "" reboot "$host"]; + if [board_info $host exists name] { + set host [board_info $host name]; + } + if { [info proc ${host}_init] != "" } { + ${host}_init $host; + } + return $status; +} + +proc standard_reboot { host } { + return ""; +} +# +# Download file FILE to DEST. If the optional DESTFILE is specified, +# that file will be used on the destination board. It returns either +# "" (indicating that the download failed), or the name of the file on +# the destination machine. +# + +proc remote_download { dest file args } { + if { [llength $args] > 0 } { + set destfile [lindex $args 0]; + } else { + set destfile [file tail $file]; + } + + if { ![is_remote $dest] } { + if { $destfile == "" || $destfile == $file } { + return $file; + } else { + set result [catch "exec cp -p $file $destfile" output]; + if [regexp "same file|are identical" $output] { + set result 0 + set output "" + } else { + # try to make sure we can read it + # and write it (in case we copy onto it again) + catch {exec chmod u+rw $destfile} + } + if { $result != 0 || $output != "" } { + perror "remote_download to $dest of $file to $destfile: $output" + return ""; + } else { + return $destfile; + } + } + } + + return [call_remote "" download $dest $file $destfile]; +} + +# +# The default download procedure. Uses rcp to download to $dest. +# + +proc standard_download {dest file destfile} { + return [rsh_download $dest $file $destfile]; +} + +proc remote_upload {dest srcfile args} { + if { [llength $args] > 0 } { + set destfile [lindex $args 0]; + } else { + set destfile [file tail $srcfile]; + } + + if { ![is_remote $dest] } { + if { $destfile == "" || $srcfile == $destfile } { + return $srcfile; + } + set result [catch "exec cp -p $srcfile $destfile" output]; + return $destfile; + } + + return [call_remote "" upload $dest $srcfile $destfile]; +} + +proc standard_upload { dest srcfile destfile } { + return [rsh_upload $dest $srcfile $destfile]; +} + +# +# A standard procedure to call the appropriate function. It first looks +# for a board-specific version, then a version specific to the protocol, +# and then finally it will call standard_$proc. +# + +proc call_remote { type proc dest args } { + if [board_info $dest exists name] { + set dest [board_info $dest name]; + } + + if { $dest != "host" && $dest != "build" && $dest != "target" } { + if { ![board_info $dest exists name] } { + global board; + + if [info exists board] { + blooie + } + load_board_description $dest; + } + } + + set high_prot "" + if { $type != "raw" } { + if [board_info $dest exists protocol] { + set high_prot "${dest} [board_info $dest protocol]"; + } else { + set high_prot "${dest} [board_info $dest generic_name]"; + } + } + + verbose "call_remote $type $proc $dest $args " 3 + # Close has to be handled specially. + if { $proc == "close" || $proc == "open" } { + foreach try "$high_prot [board_info $dest connect] telnet standard" { + if { $try != "" } { + if { [info proc "${try}_${proc}"] != "" } { + verbose "call_remote calling ${try}_${proc}" 3 + set result [eval ${try}_${proc} \"$dest\" $args]; + break; + } + } + } + set ft "[board_info $dest file_transfer]" + if { [info proc "${ft}_${proc}"] != "" } { + verbose "calling ${ft}_${proc} $dest $args" 3 + set result2 [eval ${ft}_${proc} \"$dest\" $args]; + } + if ![info exists result] { + if [info exists result2] { + set result $result2; + } else { + set result ""; + } + } + return $result; + } + foreach try "${high_prot} [board_info $dest file_transfer] [board_info $dest connect] telnet standard" { + verbose "looking for ${try}_${proc}" 4 + if { $try != "" } { + if { [info proc "${try}_${proc}"] != "" } { + verbose "call_remote calling ${try}_${proc}" 3 + return [eval ${try}_${proc} \"$dest\" $args]; + } + } + } + if { $proc == "close" } { + return "" + } + error "No procedure for '$proc' in call_remote" + return -1; +} + +# +# Send FILE through the existing session established to DEST. +# +proc remote_transmit { dest file } { + return [call_remote "" transmit "$dest" "$file"]; +} + +proc remote_raw_transmit { dest file } { + return [call_remote raw transmit "$dest" "$file"]; +} + +# +# The default transmit procedure if no other exists. This feeds the +# supplied file directly into the connection. +# +proc standard_transmit {dest file} { + if [board_info ${dest} exists name] { + set dest [board_info ${dest} name]; + } + if [board_info ${dest} exists baud] { + set baud [board_info ${dest} baud]; + } else { + set baud 9600; + } + set shell_id [board_info ${dest} fileid]; + + set lines 0 + set chars 0; + set fd [open $file r] + while { [gets $fd cur_line] >= 0 } { + set errmess "" + catch "send -i $shell_id \"$cur_line\r\"" errmess + if [string match "write\(spawn_id=\[0-9\]+\):" $errmess] { + perror "sent \"$cur_line\" got expect error \"$errmess\"" + catch "close $fd" + return -1 + } + set chars [expr $chars + ([string length $cur_line] * 10)] + if { $chars > $baud } { + sleep 1; + set chars 0 + } + verbose "." 3 + verbose "Sent $cur_line" 4 + incr lines + } + verbose "$lines lines transmitted" 2 + close $fd + return 0 +} + +proc remote_send { dest string } { + return [call_remote "" send "$dest" "$string"]; +} + +proc remote_raw_send { dest string } { + return [call_remote raw send "$dest" "$string"]; +} + +proc standard_send { dest string } { + if ![board_info $dest exists fileid] { + perror "no fileid for $dest" + return "no fileid for $dest"; + } else { + set shell_id [board_info $dest fileid] + verbose "shell_id in standard_send is $shell_id" 3 + verbose "send -i [board_info $dest fileid] -- {$string}" 3 + if [catch "send -i [board_info $dest fileid] -- {$string}" errorInfo] { + return "$errorInfo"; + } else { + return ""; + } + } +} + +proc file_on_host { op file args } { + return [eval remote_file host \"$op\" '\$file\" $args]; +} + +proc file_on_build { op file args } { + return [eval remote_file build \"$op\" \"$file\" $args]; +} + +proc remote_file { dest args } { + return [eval call_remote \"\" file \"$dest\" $args]; +} + +proc remote_raw_file { dest args } { + return [eval call_remote raw file \"$dest\" $args]; +} + +# +# Perform the specified file op on a remote Unix board. +# + +proc standard_file { dest op args } { + set file [lindex $args 0]; + verbose "dest in standard_file is $dest"; + if { ![is_remote $dest] } { + switch $op { + cmp { + set otherfile [lindex $args 1]; + if { [file exists $file] && [file exists $otherfile] + && [file size $file] == [file size $otherfile] } { + set r [remote_exec build cmp "$file $otherfile"]; + if { [lindex $r 0] == 0 } { + return 0; + } + } + return 1; + } + tail { + return [file tail $file]; + } + dirname { + if { [file pathtype $file] == "relative" } { + set file [remote_file $dest absolute $file]; + } + set result [file dirname $file]; + if { $result == "" } { + return "/"; + } + return $result; + } + join { + return [file join [lindex $args 0] [lindex $args 1]]; + } + absolute { + return [unix_clean_filename $dest $file]; + } + exists { + return [file exists $file]; + } + delete { + foreach x $args { + if { [file exists $x] && [file isfile $x] } { + exec rm -f $x; + } + } + return; + } + } + } + switch $op { + exists { + # mmmm, quotes. + set status [remote_exec $dest "sh -c 'exit `\[ -f $file \]`'"]; + return [lindex $status 0]; + } + delete { + set file "" + # Allow multiple files to be deleted at once. + foreach x $args { + append file " $x"; + } + verbose "remote_file deleting $file" + set status [remote_exec $dest "rm -f $file"]; + return [lindex $status 0]; + } + } +} + +# +# Return an absolute version of the filename in $file, with . and .. +# removed. +# +proc unix_clean_filename { dest file } { + if { [file pathtype $file] == "relative" } { + set file [remote_file $dest join [pwd] $file]; + } + set result ""; + foreach x [split $file "/"] { + if { $x == "." || $x == "" } { + continue; + } + if { $x == ".." } { + set rlen [expr [llength $result] - 2]; + if { $rlen >= 0 } { + set result [lrange $result 0 $rlen]; + } else { + set result "" + } + continue; + } + lappend result $x; + } + return "/[join $result /]" +} + +# +# Start COMMANDLINE running on DEST. By default it is not possible to +# redirect I/O. If the optional keyword "readonly" is specified, input +# to the command may be redirected. If the optional keyword +# "writeonly" is specified, output from the command may be redirected. +# +# If the command is successfully started, a positive "spawn id" is returned. +# If the spawn fails, a negative value will be returned. +# +# Once the command is spawned, you can interact with it via the remote_expect +# and remote_wait functions. +# +proc remote_spawn { dest commandline args } { + global board_info + + if ![is_remote $dest] { + if [info exists board_info($dest,fileid)] { + unset board_info($dest,fileid); + } + verbose "remote_spawn is local" 3; + if [board_info $dest exists name] { + set dest [board_info $dest name]; + } + + verbose "spawning command $commandline" + + if { [llength $args] > 0 } { + if { [lindex $args 0] == "readonly" } { + set result [catch { open "| ${commandline} |& cat" "r" } id]; + if { $result != 0 } { + return -1; + } + } else { + set result [catch {open "| ${commandline}" "w"} id] ; + if { $result != 0 } { + return -1; + } + } + set result [catch "spawn -leaveopen $id" result2]; + if { $result == 0 && $result2 == 0} { + verbose "setting board_info($dest,fileid) to $spawn_id" 3 + set board_info($dest,fileid) $spawn_id; + set board_info($dest,fileid_origid) $id; + return $spawn_id; + } else { + # This shouldn't happen. + global errorInfo; + if [info exists errorInfo] { + set foo $errorInfo; + } else { + set foo ""; + } + verbose "spawn -open $id failed, $result $result2, $foo"; + catch "close $id"; + return -1; + } + } else { + set result [catch "spawn $commandline" pid]; + if { $result == 0 } { + verbose "setting board_info($dest,fileid) to $spawn_id" 3 + set board_info($dest,fileid) $spawn_id; + return $spawn_id; + } else { + verbose -log "spawn of $commandline failed"; + return -1; + } + } + } + + # Seems to me there should be a cleaner way to do this. + if { "$args" == "" } { + return [call_remote "" spawn "$dest" "$commandline"]; + } else { + return [call_remote "" spawn "$dest" "$commandline" $args]; + } +} + +proc remote_raw_spawn { dest commandline } { + return [call_remote raw spawn "$dest" "$commandline"]; +} + +# +# The default spawn procedure. Uses rsh to connect to $dest. +# +proc standard_spawn { dest commandline } { + global board_info + + if [board_info $dest exists hostname] { + set remote [board_info $dest hostname]; + } else { + set remote $dest; + } + spawn rsh $remote $commandline; + set board_info($dest,fileid) $spawn_id; + return $spawn_id; +} + +# +# Run PROG on DEST, with optional arguments, input and output files. +# It returns a list of two items. The first is ether "pass" if the program +# loaded, ran and exited with a zero exit status, or "fail" otherwise. +# The second argument is any output produced by the program while it was +# running. +# +proc remote_load { dest prog args } { + global tool + + set dname [board_info $dest name]; + set cache "[getenv REMOTELOAD_CACHE]/$tool/$dname/[file tail $prog]"; + set empty [is_remote $dest]; + if { [board_info $dest exists is_simulator] || [getenv REMOTELOAD_CACHE] == "" } { + set empty 0; + } else { + for { set x 0; } {$x < [llength $args] } {incr x} { + if { [lindex $args $x] != "" } { + set empty 0; + break; + } + } + } + if $empty { + global sum_program; + + if [info exists sum_program] { + if ![target_info exists objcopy] { + set_currtarget_info objcopy [find_binutils_prog objcopy]; + } + if [is_remote host] { + set dprog [remote_download host $prog "a.out"]; + } else { + set dprog $prog; + } + set status [remote_exec host "[target_info objcopy]" "-O srec $dprog ${dprog}.sum"]; + if [is_remote host] { + remote_file upload ${dprog}.sum ${prog}.sum; + } + if { [lindex $status 0] == 0 } { + set sumout [remote_exec build "$sum_program" "${prog}.sum"]; + set sum [lindex $sumout 1]; + regsub "\[\r\n \t\]+$" "$sum" "" sum; + } else { + set sumout [remote_exec build "$sum_program" "${prog}"]; + set sum [lindex $sumout 1]; + regsub "\[\r\n \t\]+$" "$sum" "" sum; + } + remote_file build delete ${prog}.sum; + } + if [file exists $cache] { + set same 0; + if [info exists sum_program] { + set id [open $cache "r"]; + set oldsum [read $id]; + close $id; + if { $oldsum == $sum } { + set same 1; + } + } else { + if { [remote_file build cmp $prog $cache] == 0 } { + set same 1; + } + } + if { $same } { + set fd [open "${cache}.res" "r"]; + gets $fd l1; + set result [list $l1 [read $fd]]; + close $fd; + } + } + } + if ![info exists result] { + set result [eval call_remote \"\" load \"$dname\" \"$prog\" $args]; + # Not quite happy about the "pass" condition, but it makes sense if + # you think about it for a while-- *why* did the test not pass? + if { $empty && [lindex $result 0] == "pass" } { + if { [getenv LOAD_REMOTECACHE] != "" } { + set dir "[getenv REMOTELOAD_CACHE]/$tool/$dname" + if ![file exists $dir] { + file mkdir $dir + } + if [file exists $dir] { + if [info exists sum_program] { + set id [open $cache "w"]; + puts -nonewline $id "$sum"; + close $id; + } else { + remote_exec build cp "$prog $cache"; + } + set id [open "${cache}.res" "w"]; + puts $id [lindex $result 0]; + puts -nonewline $id [lindex $result 1]; + close $id; + } + } + } + } + return $result; +} + +proc remote_raw_load { dest prog args } { + return [eval call_remote raw load \"$dest\" \"$prog\" $args ]; +} + +# +# The default load procedure if no other exists for $dest. It uses +# remote_download and remote_exec to load and execute the program. +# + +proc standard_load { dest prog args } { + if { [llength $args] > 0 } { + set pargs [lindex $args 0]; + } else { + set pargs "" + } + + if { [llength $args] > 1 } { + set inp "[lindex $args 1]"; + } else { + set inp "" + } + + if ![file exists $prog] then { + # We call both here because this should never happen. + perror "$prog does not exist in standard_load." + verbose -log "$prog does not exist." 3 + return "untested" + } + + if [is_remote $dest] { + set remotefile "/tmp/[file tail $prog].[pid]" + set remotefile [remote_download $dest $prog $remotefile]; + if { $remotefile == "" } { + verbose -log "Download of $prog to [board_info $dest name] failed." 3 + return "unresolved" + } + if [board_info $dest exists remote_link] { + if [[board_info $dest remote_link] $remotefile] { + verbose -log "Couldn't do remote link" + remote_file target delete $remotefile + return "unresolved" + } + } + set status [remote_exec $dest $remotefile $pargs $inp]; + remote_file $dest delete $remotefile; + } else { + set status [remote_exec $dest $prog $pargs $inp]; + } + if { [lindex $status 0] < 0 } { + verbose -log "Couldn't execute $prog, [lindex $status 1]" 3 + return "unresolved" + } + set output [lindex $status 1] + set status [lindex $status 0] + + verbose -log "Executed $prog, status $status" 2 + if ![string match "" $output] { + verbose -log -- "$output" 2 + } + if { $status == 0 } { + return [list "pass" $output]; + } else { + return [list "fail" $output]; + } +} + +# +# Loads PROG into DEST. +# +proc remote_ld { dest prog } { + return [eval call_remote \"\" ld \"$dest\" \"$prog\"]; +} + +proc remote_raw_ld { dest prog } { + return [eval call_remote raw ld \"$dest\" \"$prog\"]; +} + +# Wait up to TIMEOUT seconds for the last spawned command on DEST to +# complete. A list of two values is returned; the first is the exit +# status (-1 if the program timed out), and the second is any output +# produced by the command. + +proc remote_wait { dest timeout } { + return [eval call_remote \"\" wait \"$dest\" $timeout]; +} + +proc remote_raw_wait { dest timeout } { + return [eval call_remote raw wait \"$dest\" $timeout]; +} + +# The standard wait procedure, used for commands spawned on the local +# machine. +proc standard_wait { dest timeout } { + set output ""; + set status -1; + + if [info exists exp_close_result] { + unset exp_close_result; + } + remote_expect $dest $timeout { + -re ".+" { + append output $expect_out(buffer); + if { [string length $output] > 512000 } { + remote_close $dest; + set status 1; + } else { + exp_continue -continue_timer; + } + } + timeout { + warning "program timed out."; + } + eof { + if [board_info $dest exists fileid_origid] { + global board_info; + + set id [board_info $dest fileid]; + set oid [board_info $dest fileid_origid]; + verbose "$id $oid" + unset board_info($dest,fileid); + unset board_info($dest,fileid_origid); + catch "close -i $id"; + # I don't believe this. You HAVE to do a wait, even tho + # it won't work! stupid ()*$%*)(% expect... + catch "wait -i $id"; + set r2 [catch "close $oid" res]; + if { $r2 != 0 } { + verbose "close result is $res"; + set status 1; + } else { + set status 0; + } + } else { + set s [wait -i [board_info $dest fileid]]; + if { [lindex $s 0] != 0 && [lindex $s 2] == 0 } { + set status [lindex $s 3]; + if { [llength $s] > 4 } { + if { [lindex $s 4] == "CHILDKILLED" } { + set status 1; + } + } + } + } + } + } + + remote_close $dest; + return [list $status $output]; +} + +# This checks the value cotained in the variable named "variable" in +# the calling procedure for output from the status wrapper and returns +# a non-negative value if it exists; otherwise, it returns -1. The +# output from the wrapper is removed from the variable. + +proc check_for_board_status { variable } { + upvar $variable output; + + if [regexp "(^|\[\r\n\])\\*\\*\\* EXIT code" $output] { + regsub "^.*\\*\\*\\* EXIT code " $output "" result; + regsub "\[\r\n\].*$" $result "" result; + regsub -all "(^|\[\r\n\])\\*\\*\\* EXIT code \[^\r\n\]*(\[\r\n\]\[\r\n\]?|$)" $output "" output; + regsub "^\[^0-9\]*" $result "" result + regsub "\[^0-9\]*$" $result "" result + verbose "got board status $result" 3 + verbose "output is $output" 3 + if { $result == "" } { + return -1; + } else { + return [expr $result]; + } + } else { + return -1; + } +} + +# +# remote_expect works basically the same as standard expect, but it +# also takes care of getting the file descriptor from the specified +# host and also calling the timeout/eof/default section if there is an +# error on the expect call. +# + +proc remote_expect { board timeout args } { + global errorInfo errorCode; + global remote_suppress_flag; + + set spawn_id [board_info $board fileid]; + + if { [llength $args] == 1 } { + set args "[lindex $args 0]"; + } + + set res {} + set got_re 0; + set need_append 1; + + set orig "$args"; + + set error_sect ""; + set save_next 0; + + if { $spawn_id == "" } { + # This should be an invalid spawn id. + set spawn_id 1000; + } + + for { set i 0; } { $i < [llength $args] } { incr i ; } { + if { $need_append } { + append res "\n-i $spawn_id "; + set need_append 0; + } + + set x "[lrange $args $i $i]"; + regsub "^\n*\[ \]*" "$x" "" x; + + if { $x == "-i" || $x == "-timeout" || $x == "-ex" } { + append res "$x "; + set next [expr ${i}+1]; + append res "[lrange $args $next $next]"; + incr i; + continue; + } + if { $x == "-n" || $x == "-notransfer" || $x == "-nocase" || $x == "-indices" } { + append res "${x} "; + continue; + } + if { $x == "-re" } { + append res "${x} "; + set next [expr ${i}+1]; + set y [lrange $args $next $next]; + append res "${y} "; + set got_re 1; + incr i; + continue; + } + if { $got_re } { + set need_append 0; + append res "$x "; + set got_re 0; + if { $save_next } { + set save_next 0; + set error_sect [lindex $args $i]; + } + } else { + if { ${x} == "eof" } { + set save_next 1; + } elseif { ${x} == "default" || ${x} == "timeout" } { + if { $error_sect == "" } { + set save_next 1; + } + } + append res "${x} "; + set got_re 1; + } + } + + if [info exists remote_suppress_flag] { + if { $remote_suppress_flag } { + set code 1; + } + } + if ![info exists code] { + set res "\n-timeout $timeout $res"; + set body "expect \{\n-i $spawn_id -timeout $timeout $orig\}"; + set code [catch {uplevel $body} string]; + } + + if {$code == 1} { + if { $error_sect != "" } { + set code [catch {uplevel $error_sect} string]; + } else { + warning "remote_expect statement without a default case?!"; + return; + } + } + + if {$code == 1} { + 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 + } +} + +# Push the current connection to HOST onto a stack. +proc remote_push_conn { host } { + global board_info; + + set name [board_info $host name]; + + if { $name == "" } { + return "fail"; + } + + if ![board_info $host exists fileid] { + return "fail"; + } + + set fileid [board_info $host fileid]; + set conninfo [board_info $host conninfo]; + if ![info exists board_info($name,fileid_stack)] { + set board_info($name,fileid_stack) {} + } + set board_info($name,fileid_stack) [list $fileid $conninfo $board_info($name,fileid_stack)]; + unset board_info($name,fileid); + if [info exists board_info($name,conninfo)] { + unset board_info($name,conninfo); + } + return "pass"; +} + +# Pop a previously-pushed connection from a stack. You should have closed the +# current connection before doing this. +proc remote_pop_conn { host } { + global board_info; + + set name [board_info $host name]; + + if { $name == "" } { + return "fail"; + } + if ![info exists board_info($name,fileid_stack)] { + return "fail"; + } + set stack $board_info($name,fileid_stack); + if { [llength $stack] < 3 } { + return "fail"; + } + set board_info($name,fileid) [lindex $stack 0]; + set board_info($name,conninfo) [lindex $stack 1]; + set board_info($name,fileid_stack) [lindex $stack 2]; + return "pass"; +} + +# +# Swap the current connection with the topmost one on the stack. +# +proc remote_swap_conn { host } { + global board_info; + set name [board_info $host name]; + + if ![info exists board_info($name,fileid)] { + return "fail"; + } + + set fileid $board_info($name,fileid); + if [info exists board_info($name,conninfo)] { + set conninfo $board_info($name,conninfo); + } else { + set conninfo {} + } + if { [remote_pop_conn $host] != "pass" } { + set board_info($name,fileid) $fileid; + set board_info($name,conninfo) $conninfo; + return "fail"; + } + set newfileid $board_info($name,fileid); + set newconninfo $board_info($name,conninfo); + set board_info($name,fileid) $fileid; + set board_info($name,conninfo) $conninfo; + remote_push_conn $host; + set board_info($name,fileid) $newfileid; + set board_info($name,conninfo) $newconninfo; + return "pass"; +} + +set sum_program "testcsum"; diff --git a/lib/rlogin.exp b/lib/rlogin.exp new file mode 100644 index 0000000..78745ba --- /dev/null +++ b/lib/rlogin.exp @@ -0,0 +1,173 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# +# Connect to ARG using rlogin. This is for systems using rlogin to +# braindead targets. It returns either the spawn_id or a -1. +# + +proc rlogin_open { arg } { + global board_info + + set tries 0 + set result -1 + + if [board_info $arg exists fileid] { + return [board_info $arg fileid]; + } + + # get the hostname and port number from the config array + if [board_info $arg exists netport] { + set hostname [lindex [split [board_info $arg netport] ":"] 0] + } else { + set hostname $arg + } + + if ![board_info $arg exists shell_prompt] { + # if no prompt, then set it to something generic + set shell_prompt ".*> " + } else { + set shell_prompt [board_info $arg shell_prompt] + } + + if [board_info $arg exists fileid] { + unset board_info($arg,fileid); + } + # get the right version of rlogin + if ![board_info $arg exists rlogin_prog] { + set RLOGIN rlogin + } else { + set RLOGIN [board_info $arg rlogin_prog]; + } + + # start connection and store the spawn_id + verbose "Opening a $RLOGIN connection to $hostname" 2 + spawn $RLOGIN $hostname + if { $spawn_id < 0 } { + perror "invalid spawn id from rlogin" + return + } + set board_info($arg,fileid) $spawn_id + + # Try to connect to the target. We give up after 3 attempts. + while { $tries <= 3 } { + expect { + -re ".*$shell_prompt.*$" { + verbose "Got prompt\n" + set result 0 + break + } + -re "TERM = .*\\)\[ ]*$" { + send "dumb\r\n" + expect { + "Terminal type is*$" { + verbose "rlogin: set the terminal to dumb" 2 + } + default { + warning "rlogin: couldn't set terminmal type" + } + } + set result 10 + break + } + "unknown host" { + perror "rlogin: unknown host" + break + } + "has logged on from" { + exp_continue + } + "Terminal type is" { + verbose "rlogin: connected, got terminal prompt" 2 + set result 0 + break + } + -re "Maximum number of users already logged in.*$" { + warning "rlogin: maximum number of users already logged in" + } + -re "Sorry, shell is locked.*Connection closed.*$" { + warning "rlogin: lready connected." + } + -re "Sorry, this system is engaged.*Connection closed.*$" { + warning "rlogin: system engaged." + } + timeout { + warning "rlogin: timed out trying to connect." + } + eof { + perror "rlogin: got EOF while trying to connect." + break + } + } + incr tries + } + + # see if we maxed out on errors + if { $result < 0 } { + catch "close -i $spawn_id" + catch "wait -i $spawn_id" + set spawn_id -1 + } else { + verbose "rlogin: connected to $hostname" 2 + } + + return $spawn_id +} + +# +# Start CMDLINE running on DEST. Return the shell_id associated with +# the command. +# +proc rlogin_spawn { dest cmdline } { + if ![board_info $dest exists shell_prompt] { + set shell_prompt "(^|\[\r\n\])\[^\r\n\]*>"; + } else { + set shell_prompt [board_info $dest shell_prompt]; + } + set prefix "" + set ok 0; + for {set i 0;} {$i <= 2 && ! $ok} {incr i;} { + set shell_id [remote_open $dest]; + if { $shell_id != "" && $shell_id > 0 } { + remote_send $dest "echo k\r"; + remote_expect $dest 20 { + -re "\\(gdb\\)" { + set shell_prompt "\\(gdb\\)"; + # gdb uses 'shell command'. + set prefix "shell "; + set ok 1; + } + -re ".*$shell_prompt" { + set ok 1; + } + default { } + } + } + if { ! $ok } { + remote_close $dest; + remote_reboot $dest; + } + } + if { ! $ok } { + return "unable to start command" + } else { + remote_send $dest "${prefix}${cmdline}\n"; + return [board_info $dest fileid]; + } +} diff --git a/lib/rsh.exp b/lib/rsh.exp new file mode 100644 index 0000000..b099fd5 --- /dev/null +++ b/lib/rsh.exp @@ -0,0 +1,258 @@ +# Copyright (C) 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# DejaGnu@cygnus.com + +# +# Connect to hostname using rlogin +# +proc rsh_open { hostname } { + global spawn_id + + set tries 0 + set result -1 + + # get the hostname and port number from the config array + if [board_info $hostname exists name] { + set hostname [board_info $hostname name]; + } + set hostname [lindex [split [board_info ${hostname} netport] ":"] 0] + if [board_info ${hostname} exists shell_prompt] { + set shell_prompt [board_info ${hostname} shell_prompt] + } else { + set shell_prompt ".*> " + } + + if [board_info $hostname exists fileid] { + unset board_info($hostname,fileid); + } + + if ![board_info $hostname exists rsh_prog] { + if { [which remsh] != 0 } { + set RSH remsh + } else { + set RSH rsh + } + } else { + set RSH [board_info $hostname rsh_prog]; + } + + spawn $RSH $hostname + if { $spawn_id < 0 } { + perror "invalid spawn id from rsh" + return -1 + } + + send "\r\n" + while { $tries <= 3 } { + expect { + -re ".*$shell_prompt.*$" { + verbose "Got prompt\n" + set result 0 + break + } + -re "TERM = .*$" { + warning "Setting terminal type to vt100" + set result 0 + send "vt100\n" + break + } + "unknown host" { + exp_send "\003" + perror "telnet: unknown host" + break + } + "has logged on from" { + exp_continue + } + -re "isn't registered for Kerberos.*service.*$" { + warning "rsh: isn't registered for Kerberos, please kinit" + catch close + catch wait + break + } + -re "Kerberos rcmd failed.*$" { + warning "rsh: Kerberos rcmd failed, please kinit" + catch close + catch wait + break + } + -re "You have no Kerberos tickets.*$" { + warning "rsh: No kerberos Tickets, please kinit" + catch close + catch wait + break + } + "Terminal type is" { + verbose "rsh: connected, got terminal prompt" 2 + set result 0 + break + } + -re "trying normal rlogin.*$" { + warning "rsh: trying normal rlogin." + catch close + catch wait + break + } + -re "unencrypted connection.*$" { + warning "rsh: unencrypted connection, please kinit" + catch close + catch wait + break + } + -re "Sorry, shell is locked.*Connection closed.*$" { + warning "rsh: already connected." + } + timeout { + warning "rsh: timed out trying to connect." + } + eof { + perror "rsh: got EOF while trying to connect." + break + } + } + incr tries + } + + if { $result < 0 } { +# perror "rsh: couldn't connect after $tries tries." + close -i $spawn_id + set spawn_id -1 + } else { + set board_info($hostname,fileid) $spawn_id + } + + return $spawn_id +} + +# +# Download $srcfile to $destfile on $desthost. +# + +proc rsh_download {desthost srcfile destfile} { + if [board_info $desthost exists name] { + set desthost [board_info $desthost name]; + } + + if [board_info $desthost exists hostname] { + set desthost [board_info $desthost hostname]; + } + + if ![board_info $desthost exists rcp_prog] { + set RCP rcp + } else { + set RCP [board_info $desthost rcp_prog]; + } + + set status [catch "exec $RCP $srcfile $desthost:$destfile |& cat" output] + if { $status == 0 } { + verbose "Copied $srcfile to $desthost:$destfile" 2 + return $destfile; + } else { + verbose "Download to $desthost failed, $output." + return "" + } +} + +proc rsh_upload {desthost srcfile destfile} { + if [board_info $desthost exists name] { + set desthost [board_info $desthost name]; + } + + if [board_info $desthost exists hostname] { + set desthost [board_info $desthost hostname]; + } + + if ![board_info $desthost exists rcp_prog] { + set RCP rcp + } else { + set RCP [board_info $desthost rcp_prog]; + } + + set status [catch "exec $RCP $desthost:$srcfile $destfile" output]; + if { $status == 0 } { + verbose "Copied $desthost:$srcfile to $destfile" 2 + return $destfile; + } else { + verbose "Upload from $desthost failed, $output." + return "" + } +} + +# +# Execute "$cmd $args[0]" on $boardname. +# +proc rsh_exec { boardname cmd args } { + if { [llength $args] > 0 } { + set pargs [lindex $args 0]; + if { [llength $args] > 1 } { + set inp [lindex $args 1]; + } else { + set inp ""; + } + } else { + set pargs "" + set inp "" + } + + verbose "Executing $boardname:$cmd $pargs < $inp" + + if [board_info $boardname exists name] { + set boardname [board_info $boardname name]; + } + + if [board_info $boardname exists hostname] { + set hostname [board_info $boardname hostname]; + } else { + set hostname $boardname; + } + + if ![board_info $hostname exists rsh_prog] { + if { [which remsh] != 0 } { + set RSH remsh + } else { + set RSH rsh + } + } else { + set RSH [board_info $hostname rsh_prog]; + } + + # If CMD sends any output to stderr, exec will think it failed. More often + # than not that will be true, but it doesn't catch the case where there is + # no output but the exit code is non-zero. + if { $inp == "" } { + set inp "/dev/null" + } + set status [catch "exec cat $inp | $RSH $boardname sh -c '$cmd $pargs \\; echo XYZ\\\${?}ZYX' |& cat" output] + verbose "rsh output is $output" + # `status' doesn't mean much here other than rsh worked ok. + # What we want is whether $cmd ran ok. + if { $status != 0 } { + regsub "XYZ(\[0-9\]*)ZYX\n?" $output "" output + return [list -1 "rsh to $boardname failed for $cmd, $output"] + } + regexp "XYZ(\[0-9\]*)ZYX" $output junk status + verbose "rsh_exec: status:$status text:$output" 4 + if { $status == "" } { + return [list -1 "Couldn't parse rsh output, $output."] + } + regsub "XYZ(\[0-9\]*)ZYX\n?" $output "" output + # Delete one trailing \n because that is what `exec' will do and we want + # to behave identical to it. + regsub "\n$" $output "" output + return [list [expr $status != 0] $output] +} diff --git a/lib/standard.exp b/lib/standard.exp new file mode 100644 index 0000000..f1822e4 --- /dev/null +++ b/lib/standard.exp @@ -0,0 +1,42 @@ +# Copyright (C) 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# DejaGnu@cygnus.com + +# +# A set of standard functions for tools. Calls the +# target-machine-specific versions. +# + +proc ${tool}_load { program args } { + if { [llength $args] > 0 } { + set program_args [lindex $args 0]; + } else { + set program_args "" + } + + if { [llength $args] > 1 } { + set input_file [lindex $args 1]; + } else { + set input_file ""; + } + return [remote_load target $program $program_args $input_file]; +} + +proc ${tool}_compile { srcfile destfile compile_type options } { + target_compile $srcfile $destfile $compile_type $options +} diff --git a/lib/target.exp b/lib/target.exp new file mode 100644 index 0000000..f71c6f6 --- /dev/null +++ b/lib/target.exp @@ -0,0 +1,759 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999, 2000 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) +# and extensively modified by Bob Manson. (manson@cygnus.com) + +# a hairy pattern to recognize text +set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]" + +# +# this is a collection of support procs for the target data +# structures. We use a named array, since Tcl has no real data +# structures. Here's the special index words for the array: +# Required fields are: +# name - the name of the target. (mostly for error messages) This +# should also be the string used for this target's array. +# It should also be the same as the linker script so we +# can find them dynamically. +# Optional fields are: +# ldflags - the flags required to produce a fully linked executable. +# config - the target canonical for this target. This is a regexp +# as passed to istarget or isnative. +# cflags - the flags required to produce an object file from a +# source file. +# connect - the connectmode for this target. This is for both IP and +# serial connections. +# hostname - the hostname of the target. This is for TCP/IP based +# connections, and is also used for versions of tip that +# use /etc/remote. +# serial - the serial port. This is typically /dev/tty? or com?:. +# baud - the baud rate for a serial port connection. +# netport - the IP port. +# x10 - parameters for the x10 controller (used to reboot) +# fileid - the fileid or spawn id of of the connection. +# prompt - a regexp for matching the prompt. +# ioport - the port for I/O on dual port systems. +# +# there are three main arrays, indexed in with "target", "build", and "host". +# all other targets are indexed with a name usually based on the linker script +# like "idp", or "ex93x.ld". +# + +# +# Set the target connection. +# +proc push_target { name } { + global target_abbrev + + pop_config target + push_config target $name +} + +# +# Set the host connnection. +# +proc push_host { name } { + pop_config host + push_config host $name +} + +# +# Set the build connnection. +# +proc push_build { name } { + pop_config build + push_config build $name +} + +# +# Set the config for the current host or target connection. +# +proc push_config { type name } { + global target_info + + verbose "pushing config for $type, name is $name" + if [info exists target_info($type,name)] { + if { $target_info($type,name) == $name } { + error "pushing config for $type, '$name' twice" + } + } + set target_info($type,name) $name +} + +# +# Set the current connection for target or host. +# +proc pop_config { type } { + global target_info + + if [info exists target_info(${type},name)] { + unset target_info(${type},name) + } +} + +# +# Unset the target connection. +# +proc pop_target { } { + pop_config target +} + +# +# Unset the host connection. +# +proc pop_host { } { + pop_config host +} + +# +# Remove extraneous warnings we don't care about +# +proc prune_warnings { text } { + global host_triplet; + + # remove the \r part of "\r\n" so we don't break all the patterns + # we want to match. + regsub -all -- "\r" $text "" text + + # This is from sun4's. Do it for all machines for now. + # The "\\1" is to try to preserve a "\n" but only if necessary. + if [ishost "sparc-*-sunos*"] { + regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text + } + + # See Brendan for the raison d'etre of this one. + if [ishost "alpha*-*-*"] { + regsub -all "(^|\n)(/usr/(ucb|bin)/ld.*without exceptions was\[^\n\]+\n?)" $text "\\1" text + } + if [ishost "hppa*-*-hpux*"] { + # Ignore the compiler's warnings about PA incompatibility. + regsub -all "(^|\n)\[^\n\]*PA 2.0 object file \[^\n\]* was detected. The linked output may not run on a PA 1.x system." $text "" text + + regsub -all "(^|\n)\[^\n\]*PA 2.0 object file \[^\n\]* was detected. The linked output may not run on a PA 1.x system." $text "" text + + # And the linker's +vcompatwarnings verbage. + regsub -all "(^|\n)\[^\n\]*Linker features were used that may not be supported\[^\n\]*.\[^\n\]*." $text "" text + + # Ignore these warnings, which the HP aCC compiler seems to + # generate on HP-UX 10.30 and 11.0. (Something is probably + # wrong with some system headers, but still...) + # + # This particular warning always is given with a line of warning + # text, followed by a source line, followed by a line with "^^^" + # underlining an offending symbol name. Here we slurp up the + # warning text and the next two lines, assuming that they are + # the source line and underline chars. + # + regsub -all "Warning .*The linkage directive is ignored for an object or function declared static..\[^\n\]*.\[^\n\]*." $text "" text + + # Ignore these warnings, which I often see from the ANSI C + # compiler installed on HP-UX 11.0 machines. (Something is + # probably wrong with an installation, or perhaps NLS isn't + # quite healthy yet on 11.0. In either case, it's easier to + # "fix" this nit here, than it is to track down & fix the + # root cause.) + # + # This particular warning always is given with a line of warning + # text, followed by line that says "Using internal messages". + # + regsub -all "Warning: Unable to open pxdb message catalog.*" $text "" text + regsub -all ".* Using internal messages.*" $text "" text + + # Another form of the "unable to find message catalog" warning. + # + regsub -all "cpp: warning .*Possibly incorrect message catalog." $text "" text + + # Another odd warning on 11.0. + # + regsub -all "aCC .assigner.: Warning .*Could not find library for -l.*" $text "" text + + # Oh heck, just keep adding 'em here... + # + regsub -all "aCC .assigner.: Warning .*Could not satisfy instantiation request for \[^\n\]* contained in\[^\n\]*\n\t/lib/pa20_64/lib\[a-zA-Z0-9\]*.sl" $text "" text + + # Remove the lines that are output by the HP F77 compiler to + # indicate the functions that are being compiled. + upvar compiler_type compiler_type + if { [info exists compiler_type] && $compiler_type == "f77" } { + regsub -all "\[ \ta-zA-Z_0-9\./\]*:\[\r\n\]+" $text "" text + } + + # Ignore the warnings about unknown options + regsub -all ".*warning \[0-9\]+: Unknown option.*ignored.*" $text "" text + + } + + # Ignore these. + regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text + regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text + + # This is from sun4's. Do it for all machines for now. + # The "\\1" is to try to preserve a "\n" but only if necessary. + regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text + + # This happens when compiling on Alpha OSF/1 with cc -g -O. + regsub -all "(^|\n)(\n*uopt: Warning: file not optimized; use -g3 if both optimization and debug wanted\n?)+" $text "\\1" text + + # This happens when compiling on Alpha OSF using gas. + regsub -all "(^|\n)(/usr/.*/ld:\nWarning: Linking some objects which contain exception information sections\n\tand some which do not. This may cause fatal runtime exception handling\n\tproblems\[^\n\]*\n?)+" $text "\\1" text + + # This happens on SunOS with cc -g -O. + regsub -all "(^|\n)(cc: Warning: -O conflicts with -g. -O turned off.\n?)+" $text "\\1" text + + # This happens when assembling code with the native HP assembler + regsub -all "(^|\n)(as:\[^\n\]*err#13.\n .warning.\[^\n\]*\n?)+" $text "\\1" text + + # When using the HP assembler, -g isn't supported. + regsub -all "(^|\n)(cc1: warning: -g is only supported when using GAS on this processor\[^\n\]*\ncc1: warning:\[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(cc1plus: warning: -g is only supported when using GAS on this processor\[^\n\]*\ncc1plus: warning:\[^\n\]*\n?)+" $text "\\1" text + + # This happens when testing across NFS. + regsub -all "(^|\n)(NFS server \[^\n\]* not responding still trying\[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(NFS server \[^\n\]* ok\[^\n\]*\n?)+" $text "\\1" text + + # This happens when testing across NFS on osf4. + regsub -all "(^|\n)(NFS3 server \[^\n\]* not responding still trying\[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(NFS3 server \[^\n\]* ok\[^\n\]*\n?)+" $text "\\1" text + + # When using the IRIX 6 o32 assembler, -g isn't supported + regsub -all "(^|\n)(cc1: warning: `-g' not supported by this configuration of GCC\[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(cc1plus: warning: `-g' not supported by this configuration of GCC\[^\n\]*\n?)+" $text "\\1" text + + regsub -all "(^|\n)(cc1: warning: -mabi=32 does not support -g\[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(cc1plus: warning: -mabi=32 does not support -g\[^\n\]*\n?)+" $text "\\1" text + + # This happens with the o32 assembler on IRIX 6. + regsub -all "(^|\n)(as: Warning: -O3 is not supported for assembly compiles for ucode compilers; changing to -O2.\n?)+" $text "\\1" text + + # This happens when using g++ on a DWARF system. + regsub -all "(^|\n)(cc1plus: warning: -g option not supported for C\\+\\+ on systems using the DWARF debugging format\n?)+" $text "\\1" text + + # This is from sun4's. Do it for all machines for now. + # The "\\1" is to try to preserve a "\n" but only if necessary. + regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text + + # See Brendan for the raison d'etre of this one. + if [string match "alpha*-*-*" $host_triplet] { + regsub -all "(^|\n)(/usr/(ucb|bin)/ld.*without exceptions was\[^\n\]+\n?)" $text "\\1" text + } + + # Don't pay attention to the AIX4 linker warnings. + regsub -all "(^|\n)(ld:.*WARNING: Duplicate.*ld:.*Use the -bload\[^\n\]*\n?)" $text "\\1" text + + # Or the IRIX 6 ones. + regsub -all "(^|\n)(ld(|32|64): WARNING \[^\n\]*\n?)+" $text "\\1" text + regsub -all "(^|\n)(ld(|32|64): Giving up.*Use -wall\[^\n\]*\n?)+" $text "\\1" text + + # Or the NetBSD ones. + regsub -all "(^|\n)(\[^\n\]*:\[0-9\]+: warning: \[^\n\]* possibly used unsafely, use \[^\n\]*\n?)" $text "\\1" text + regsub -all "(^|\n)(\[^\n\]*: warning: reference to compatibility glob\[^\n\]*\n?)" $text "\\1" text + + # GNU ld warns about functions marked as dangerous in GNU libc. + regsub -all "(^|\n)\[^\n\]*: In function\[^\n\]*\n\[^\n\]\[^\n\]*function is dangerous\[^\n\]*" $text "" text + + # Libgloss libnosys defines functions that warn when linked in + regsub -all "(^|\n)\[^\n\]*: In function\[^\n\]*\n\[^\n\]\[^\n\]*is not implemented and will always fail\[^\n\]*" $text "" text + + # It might be tempting to get carried away and delete blank lines, etc. + # Just delete *exactly* what we're ask to, and that's it. + return $text +} + +# +# Invoke the compiler. This gets interesting cause the compiler may +# not be on the same machine we're running DejaGnu on. +# + +proc target_compile {source destfile type options} { + set target [target_info name]; + if { [info proc ${target}_compile] != "" } { + return [${target}_compile $source $destfile $type $options]; + } else { + return [default_target_compile $source $destfile $type $options]; + } +} + +proc default_target_compile {source destfile type options} { + global target_triplet + global tool_root_dir + global CFLAGS_FOR_TARGET + global compiler_flags + + if { $destfile == "" && $type != "preprocess" && $type != "none" } { + error "Must supply an output filename for the compile to default_target_compile" + } + + set add_flags "" + set libs "" + set compiler_type "c" + set compiler "" + set ldflags "" + set dest [target_info name] + + if [info exists CFLAGS_FOR_TARGET] { + append add_flags " $CFLAGS_FOR_TARGET" + } + + if [info exists target_info(host,name)] { + set host [host_info name]; + } else { + set host "unix"; + } + + foreach i $options { + if { $i == "c++" } { + set compiler_type "c++" + if [board_info $dest exists cxxflags] { + append add_flags " [target_info cxxflags]" + } + append add_flags " [g++_include_flags]"; + if [board_info $dest exists c++compiler] { + set compiler [target_info c++compiler]; + } else { + set compiler [find_g++]; + } + } + + if { $i == "f77" } { + set compiler_type "f77" + if [board_info $dest exists f77flags] { + append add_flags " [target_info f77flags]" + } +# append add_flags " [f77_include_flags]" + if [board_info $dest exists f77compiler] { + set compiler [target_info f77compiler] + } else { + set compiler [find_g77] + } + } + + if [regexp "^dest=" $i] { + regsub "^dest=" $i "" tmp + if [board_info $tmp exists name] { + set dest [board_info $tmp name]; + } else { + set dest $tmp; + } + } + if [regexp "^compiler=" $i] { + regsub "^compiler=" $i "" tmp + set compiler $tmp + } + if [regexp "^additional_flags=" $i] { + regsub "^additional_flags=" $i "" tmp + append add_flags " $tmp" + } + if [regexp "^ldflags=" $i] { + regsub "^ldflags=" $i "" tmp + append ldflags " $tmp" + } + if [regexp "^libs=" $i] { + regsub "^libs=" $i "" tmp + append libs " $tmp" + } + if [regexp "^incdir=" $i] { + regsub "^incdir=" $i "-I" tmp + append add_flags " $tmp" + } + if [regexp "^libdir=" $i] { + regsub "^libdir=" $i "-L" tmp + append add_flags " $tmp" + } + if [regexp "^ldscript=" $i] { + regsub "^ldscript=" $i "" ldscript + } + if [regexp "^redirect=" $i] { + regsub "^redirect=" $i "" redirect + } + if [regexp "^optimize=" $i] { + regsub "^optimize=" $i "" optimize + } + if [regexp "^timeout=" $i] { + regsub "^timeout=" $i "" timeout + } + } + + if [board_info $host exists cflags_for_target] { + append add_flags " [board_info $host cflags_for_target]"; + } + + global CC_FOR_TARGET + global CXX_FOR_TARGET + global F77_FOR_TARGET + + if [info exists CC_FOR_TARGET] { + if { $compiler == "" } { + set compiler $CC_FOR_TARGET + } + } + + if [info exists CXX_FOR_TARGET] { + if { $compiler_type == "c++" } { + set compiler $CXX_FOR_TARGET + } + } + + if [info exists F77_FOR_TARGET] { + if { $compiler_type == "f77" } { + set compiler $F77_FOR_TARGET + } + } + + if { $compiler == "" } { + set compiler [board_info $dest compiler]; + if { $compiler == "" } { + return "default_target_compile: No compiler to compile with"; + } + } + + if ![is_remote host] { + if { [which $compiler] == 0 } { + return "default_target_compile: Can't find $compiler." + } + } + + if {$type == "object"} { + append add_flags " -c" + } + + if { $type == "preprocess" } { + append add_flags " -E" + } + + if { $type == "assembly" } { + append add_flags " -S" + } + + if [board_info $dest exists cflags] { + append add_flags " [board_info $dest cflags]" + } + + if { $type == "executable" } { + # This must be added here. + # if [board_info $dest exists ldscript] { + # append add_flags " [board_info $dest ldscript]" + # } + + if [board_info $dest exists ldflags] { + append add_flags " [board_info $dest ldflags]" + } + if { $compiler_type == "c++" } { + append add_flags " [g++_link_flags]"; + } + if [isnative] { + # This is a lose. + catch "glob -nocomplain $tool_root_dir/libstdc++/libstdc++.so* $tool_root_dir/libstdc++/libstdc++.sl" tmp + if { ${tmp} != "" } { + if [regexp ".*solaris2.*" $target_triplet] { + # Solaris 2 + append add_flags " -R$tool_root_dir/libstdc++" + } elseif [regexp ".*(osf|irix5|linux).*" $target_triplet] { + # OSF/1 or Irix5 + append add_flags " -Wl,-rpath,$tool_root_dir/libstdc++" + } elseif [regexp ".*hppa.*" $target_triplet] { + # HP/UX + append add_flags " -Wl,-a,shared_archive" + } + } + } + } + + if ![info exists ldscript] { + set ldscript [board_info $dest ldscript] + } + + foreach i $options { + if { $i == "debug" } { + if [board_info $dest exists debug_flags] { + append add_flags " [board_info $dest debug_flags]"; + } else { + append add_flags " -g" + } + } + } + + if [info exists optimize] { + append add_flags " $optimize"; + } + + if { $type == "executable" } { + foreach x $libs { + if [file exists $x] { + append source " $x" + } else { + append add_flags " $x"; + } + } + append add_flags " $ldflags" + + if [board_info $dest exists libs] { + append add_flags " [board_info $dest libs]" + } + + # This probably isn't such a good idea, but it avoids nasty + # hackiness in the testsuites. + # The math library must be linked in before the C library. The C + # library is linked in by the linker script, so this must be before + # the linker script. + if [board_info $dest exists mathlib] { + append add_flags " [board_info $dest mathlib]" + } else { + append add_flags " -lm" + } + + # This must be added here. + append add_flags " $ldscript"; + + if [board_info $dest exists remote_link] { + # Relink option. + append add_flags " -Wl,-r" + } + if [board_info $dest exists output_format] { + append add_flags " -Wl,-oformat,[board_info $dest output_format]"; + } + } + + if [board_info $dest exists multilib_flags] { + append add_flags " [board_info $dest multilib_flags]"; + } + + verbose "doing compile" + + set sources "" + if [is_remote host] { + foreach x $source { + set file [remote_download host $x]; + if { $file == "" } { + warning "Unable to download $x to host." + return "Unable to download $x to host." + } else { + append sources " $file"; + } + } + } else { + set sources $source + } + + if [is_remote host] { + append add_flags " -o a.out" + remote_file host delete a.out; + } else { + if { $destfile != "" } { + append add_flags " -o $destfile"; + } + } + + # This is obscure: we put SOURCES at the end when building an + # object, because otherwise, in some situations, libtool will + # become confused about the name of the actual source file. + if {$type == "object"} { + set opts "$add_flags $sources" + } else { + set opts "$sources $add_flags" + } + + if [is_remote host] { + if [host_info exists use_at] { + set fid [open "atfile" "w"]; + puts $fid "$opts"; + close $fid; + set opts "@[remote_download host atfile]" + remote_file build delete atfile + } + } + + verbose "Invoking the compiler as $compiler $opts" 2 + + if [info exists redirect] { + verbose "Redirecting output to $redirect" 2 + set status [remote_exec host "$compiler $opts" "" "" $redirect]; + } else { + if [info exists timeout] { + verbose "Setting timeout to $timeout" 2 + set status [remote_exec host "$compiler $opts" "" "" "" $timeout]; + } else { + set status [remote_exec host "$compiler $opts"]; + } + } + + set compiler_flags $opts + if [is_remote host] { + remote_upload host a.out $destfile; + remote_file host delete a.out; + } + set comp_output [prune_warnings [lindex $status 1]]; + regsub "^\[\r\n\]+" $comp_output "" comp_output; + if { [lindex $status 0] != 0 } { + verbose -log "compiler exited with status [lindex $status 0]"; + } + if { [lindex $status 1] != "" } { + verbose -log "output is:\n[lindex $status 1]" 2; + } + if { [lindex $status 0] != 0 && "${comp_output}" == "" } { + set comp_output "exit status is [lindex $status 0]"; + } + return ${comp_output}; +} + +proc reboot_target { } { + set result [remote_reboot target] + puts "REBOOT_TARGET: \"$result\"" + return ${result}; +} + +# +# Invoke this if you really want as to be called directly, rather than +# calling the compiler. FLAGS are any additional flags to pass to the +# assembler. +# +proc target_assemble { source destfile flags } { + return [default_target_assemble $source $destfile $flags]; +} + +proc default_target_assemble { source destfile flags } { + global AS_FOR_TARGET + global ASFLAGS_FOR_TARGET + + if [info exists AS_FOR_TARGET] { + set AS "$AS_FOR_TARGET"; + } else { + if ![board_info target exists assembler] { + set AS [find_gas]; + } else { + set AS [board_info target assembler]; + } + } + + if [info exists ASFLAGS_FOR_TARGET] { + append flags " $ASFLAGS_FOR_TARGET"; + } + + if [is_remote host] { + set source [remote_download host $source]; + set dest "a.out" + } else { + set dest $destfile + } + set status [remote_exec host "$AS $source $flags -o $dest"] + if [is_remote host] { + remote_upload host $dest $destfile + } + + set comp_output [prune_warnings [lindex $status 1]]; + if { [lindex $status 0] != 0 } { + verbose -log "assembler exited with status [lindex $status 0]"; + } + if { [lindex $status 1] != "" } { + verbose -log "assembler output is:\n[lindex $status 1]" 2; + } + return ${comp_output}; +} + +# +# Invoke this if you really want ld to be called directly, rather than +# calling the compiler. FLAGS are any additional flags to pass to the +# linker. +# +proc target_link { objects destfile flags } { + return [default_link target "$objects" "$destfile" $flags]; +} + +proc default_link { board objects destfile flags } { + global LD_FOR_TARGET + global LDFLAGS_FOR_TARGET + + # return -L's in ldflags + proc only--Ls { ldflags } { + set result "" + set ldflags [split $ldflags] + set len [llength $ldflags] + for { set i 0 } { $i < $len } { incr i } { + # ??? We ignore the situation where a -L is actually the argument + # to an option. + set arg [lindex $ldflags $i] + regsub "^-Wl," $arg "" arg + if [regexp "^-L" $arg] { + # Is the directory in the next arg, or part of this one? + if { "$arg" == "-L" } { + if { $i + 1 < $len } { + append result " -L [lindex $ldflags $i+1]" + incr i + } + } else { + append result " $arg" + } + } + } + return $result + } + + if [info exists LD_FOR_TARGET] { + set LD "$LD_FOR_TARGET"; + } else { + if ![board_info target exists linker] { + set LD [find_ld]; + } else { + set LD [board_info target linker]; + } + } + + if [info exists LDFLAGS_FOR_TARGET] { + append flags " $LDFLAGS_FOR_TARGET"; + } + + # `ldflags' consists of arguments to gcc (that are then + # passed to ld), not arguments to ld directly. + # We need the -L's. + if [board_info $board exists ldflags] { + set ldflags [board_info $board ldflags] + set ldflags [only--Ls $ldflags] + append flags " $ldflags" + } + + if [board_info $board exists ldscript] { + # strip leading -Wl, if present + set ldscript [board_info $board ldscript] + regsub "^-Wl," $ldscript "" ldscript + append flags " $ldscript" + } + + if [is_remote host] { + foreach x $objects { + set nobjects "$nobjects [remote_download host $x]"; + } + set objects "$nobjects"; + set dest "a.out"; + } else { + set dest $destfile; + } + set status [remote_exec host "$LD $objects $flags -o $dest"] + if [is_remote host] { + remote_upload host $dest $destfile; + } + + set comp_output [prune_warnings [lindex $status 1]]; + if { [lindex $status 0] != 0 } { + verbose -log "linker exited with status [lindex $status 0]"; + } + if { [lindex $status 1] != "" } { + verbose -log "linker output is:\n[lindex $status 1]" 2; + } + return ${comp_output}; +} diff --git a/lib/targetdb.exp b/lib/targetdb.exp new file mode 100644 index 0000000..b682d04 --- /dev/null +++ b/lib/targetdb.exp @@ -0,0 +1,113 @@ +# Copyright (C) 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# DejaGnu@cygnus.com + +# +# Searches in the appropriate place (the board_info array) for the specified +# information. +# +proc board_info { machine op args } { + global target_info + global board_info + + verbose "board_info $machine $op $args" 3 + + if [info exists target_info($machine,name)] { + set machine $target_info($machine,name); + } + if { $op == "exists" } { + if { [llength $args] == 0 } { + if [info exists board_info($machine,name)] { + return 1; + } else { + return 0; + } + } else { + if [info exists "board_info($machine,[lindex $args 0])"] { + return 1; + } else { + return 0; + } + } + } + if { [llength $args] == 0 } { + verbose "getting $machine $op" 3 + if [info exists board_info($machine,$op)] { + return $board_info($machine,$op); + } else { + return "" + } + } + return ""; +} + +proc target_info { op args } { + return [eval "board_info target \"$op\" $args"]; +} + +proc host_info { op args } { + return [eval "board_info host \"$op\" $args"]; +} + +# +# Fill in ENTRY with VALUE for the current board being defined. +# +proc set_board_info { entry value } { + global board_info board; + + if ![info exists board_info($board,$entry)] { + set board_info($board,$entry) $value; + } +} + +# +# Fill in ENTRY with VALUE for the current target. +# +proc set_currtarget_info { entry value } { + global board_info; + + set board [target_info name]; + + if ![info exists board_info($board,$entry)] { + set board_info($board,$entry) $value; + } +} + +# +# Unset ENTRY for the current board being defined. +# +proc unset_board_info { entry } { + global board_info board; + + if [info exists board_info($board,$entry)] { + unset board_info($board,$entry); + } +} + +# +# Unset ENTRY for the current board being defined. +# +proc unset_currtarget_info { entry } { + global board_info; + + set board [target_info name]; + + if [info exists board_info($board,$entry)] { + unset board_info($board,$entry); + } +} diff --git a/lib/telnet.exp b/lib/telnet.exp new file mode 100644 index 0000000..48c72ac --- /dev/null +++ b/lib/telnet.exp @@ -0,0 +1,243 @@ +# Copyright (C) 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# DejaGnu@cygnus.com + +# +# Connect using telnet. This takes two arguments. The first one is the +# hostname, and the second is the optional port number. This sets +# the fileid field in the config array, and returns -1 for error, or the +# spawn id. +# +proc telnet_open { hostname args } { + global verbose + global connectmode + global spawn_id + global timeout + global board_info + + set raw 0; + + if { [llength $args] > 0 } { + if { [lindex $args 0] == "raw" } { + set raw 1; + } + } + + set port 23 + if [board_info $hostname exists name] { + set connhost [board_info $hostname name] + } else { + set connhost $hostname + } + + if [board_info $connhost exists hostname] { + set hostname [board_info $connhost hostname]; + } + + if [file exists /usr/kerberos/bin/telnet] { + set telnet /usr/kerberos/bin/telnet; + } else { + set telnet telnet; + } + + # Instead of unsetting it, let's return it. One connection at a + # time, please. + if [board_info $connhost exists fileid] { + return [board_info $connhost fileid]; + } + # get the hostname and port number from the config array + if [board_info $connhost exists netport] { + set type $hostname + set hosttmp [split [board_info $connhost netport] ":"] + set hostname [lindex $hosttmp 0] + if { [llength $hosttmp] > 1 } { + set port [lindex $hosttmp 1] + } + unset hosttmp + } else { + set type target + } + if [board_info $connhost exists shell_prompt] { + set shell_prompt [board_info $connhost shell_prompt] + } + if ![info exists shell_prompt] { # if no prompt, then set it to something generic + set shell_prompt ".*> " + } + + set tries 0 + set result -1 + set need_respawn 1; + verbose "Starting a telnet connection to $hostname:$port $shell_prompt" 2 + while { $result < 0 && $tries <= 3 } { + if { $need_respawn } { + set need_respawn 0; + spawn $telnet $hostname $port; + } + expect { + "Trying " { + exp_continue; + } + -re "$shell_prompt.*$" { + verbose "Got prompt\n" + set result 0 + } + -re "nt Name:|ogin:" { + if [board_info $connhost exists telnet_username] { + exp_send "[board_info $connhost telnet_username]\n"; + exp_continue; + } + if [board_info $connhost exists username] { + exp_send "[board_info $connhost username]\n"; + exp_continue; + } + perror "telnet: need to login" + break + } + "assword:" { + if [board_info $connhost exists telnet_password] { + exp_send "[board_info $connhost telnet_password]\n"; + exp_continue; + } + if [board_info $connhost exists password] { + exp_send "[board_info $connhost password]\n"; + exp_continue; + } + perror "telnet: need a password" + break + } + -re "advance.*y/n.*\\?" { + exp_send "n\n"; + exp_continue; + } + -re {([Aa]dvanced|[Ss]imple) or ([Ss]imple|[Aa]dvanced)} { + exp_send "simple\n"; + exp_continue; + } + "Connected to" { + exp_continue + } + "unknown host" { + exp_send "\003" + perror "telnet: unknown host" + break + } + "VxWorks Boot" { + exp_send "@\n"; + sleep 20; + exp_continue; + } + -re "Escape character is.*\\.\[\r\n\]" { + if { $raw || [board_info $connhost exists dont_wait_for_prompt] } { + set result 0; + } else { + if [board_info $connhost exists send_initial_cr] { + exp_send "\n" + } + exp_continue + } + } + "has logged on from" { + exp_continue + } + "You have no Kerberos tickets" { + warning "telnet: no kerberos Tickets, please kinit" + break + } + -re "Connection refused.*$" { + catch "exp_send \"\003\"" foo; + sleep 5; + warning "telnet: connection refused." + } + -re "Sorry, this system is engaged.*" { + exp_send "\003" + warning "telnet: already connected." + } + "Connection closed by foreign host.*$" { + warning "telnet: connection closed by foreign host." + break + } + -re "\[\r\n\]+" { + exp_continue + } + timeout { + exp_send "\n" + } + eof { + warning "telnet: got unexpected EOF from telnet." + catch close; + catch wait; + set need_respawn 1; + sleep 5; + } + } + incr tries + } + # we look for this here again cause it means something went wrong, and + # it doesn't always show up in the expect in buffer till the server times out. + if [info exists expect_out(buffer)] { + if [regexp "assword:|ogin:" $expect_out(buffer)] { + perror "telnet: need to supply a login and password." + } + } + if { $result < 0 } { + catch close + catch wait + set spawn_id -1 + } + if { $spawn_id >= 0 } { + verbose "setting board_info($connhost,fileid) to $spawn_id" 3 + set board_info($connhost,fileid) $spawn_id + } + return $spawn_id +} + +# +# Put the telnet connection into binary mode. +# +proc telnet_binary { hostname } { + if [board_info $hostname exists fileid] { + remote_send $hostname ""; + remote_expect $hostname 5 { + -re "telnet> *$" {} + default {} + } + remote_send $hostname "set binary\n" + remote_expect $hostname 5 { + -re "Format is .*telnet> *$" { + remote_send $hostname "toggle binary\n"; + exp_continue; + } + -re "Negotiating network ascii.*telnet> *$" { + remote_send $hostname "toggle binary\n"; + exp_continue; + } + -re "Negotiating binary.*\[\r\n\].*$" { } + -re "binary.*unknown argument.*telnet> *$" { + remote_send $hostname "mode character\n"; + } + -re "Already operating in binary.*\[\r\n\].*$" { } + timeout { + warning "Never got binary response from telnet." + } + } + } +} + +proc telnet_transmit { dest file args } { + return [standard_transmit $dest $file]; +} diff --git a/lib/tip.exp b/lib/tip.exp new file mode 100644 index 0000000..25877a9 --- /dev/null +++ b/lib/tip.exp @@ -0,0 +1,184 @@ +# Copyright (C) 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# DejaGnu@cygnus.com + +# +# Connect via tip as part of remote_open. +# returns -1 if it failed, the spawn_id if it worked; also sets +# [board_info ${hostname} fileid] with the spawn_id on success. +# +proc tip_open { hostname } { + global verbose + global spawn_id + + set tries 0 + set result -1 + + if [board_info $hostname exists name] { + set hostname [board_info ${hostname} name]; + } + set port [board_info ${hostname} tipname] + if [board_info ${hostname} exists shell_prompt] { + set shell_prompt [board_info ${hostname} shell_prompt] + } else { + set shell_prompt ".*> " # Pick something reasonably generic. + } + + if [board_info ${hostname} exists fileid] { + unset board_info(${hostname},fileid); + } + spawn tip -v $port + if { $spawn_id < 0 } { + perror "invalid spawn id from tip" + return -1 + } + expect { + -re ".*connected.*$" { + send "\r\n" + expect { + -re ".*$shell_prompt.*$" { + verbose "Got prompt\n" + set result 0 + incr tries + } + timeout { + warning "Never got prompt." + set result -1 + incr tries + if $tries<=2 { + exp_continue + } + } + } + } + -re "all ports busy.*$" { + set result -1 + perror "All ports busy." + incr tries + if { $tries <= 2 } { + exp_continue + } + } + -re "Connection Closed.*$" { + perror "Never connected." + set result -1 + incr tries + if { $tries <= 2 } { + exp_continue + } + } + -re ".*: Permission denied.*link down.*$" { + perror "Link down." + set result -1 + incr tries + } + timeout { + perror "Timed out trying to connect." + set result -1 + incr tries + if { $tries <= 2 } { + exp_continue + } + } + eof { + perror "Got unexpected EOF from tip." + set result -1 + incr tries + } + } + + send "\n~s" + expect { + "~\[set\]*" { + verbose "Setting verbose mode" 1 + send "verbose\n\n\n" + } + } + + if { $result < 0 } { + perror "Couldn't connect after $tries tries." + return -1 + } else { + set board_info($hostname,fileid) $spawn_id + return $spawn_id + } +} + +# +# Downloads using the ~put command under tip +# arg - is a full path name to the file to download +# returns -1 if an error occured, otherwise it returns 0. +# +proc tip_download { dest file args } { + global verbose + global decimal + global expect_out + + if [board_info $dest exists shell_prompt] { + set shell_prompt [board_info $dest shell_prompt]; + } else { + set shell_prompt ".*>" + } + + set result "" + if ![board_info $dest exists fileid] { + perror "tip_download: no connection to $dest." + return $result; + } + set shell_id [board_info $dest fileid]; + + if ![file exists $file] { + perror "$file doesn't exist." + return $result + } + + send -i $shell_id "\n~p" + expect { + -i $shell_id "~\[put\]*" { + verbose "Downloading $file, please wait" 1 + send -i $shell_id "$file\n" + set timeout 50 + expect { + -i $shell_id -re ".*$file.*$" { + exp_continue + } + -i $shell_id -re ".*lines transferred in.*minute.*seconds.*$shell_prompt.*$" { + verbose "Download $file successfully" 1 + set result $file; + } + -i $shell_id -re ".*Invalid command.*$shell_prompt$" { + warning "Got an invalid command to the remote shell." + } + -i $shell_id -re ".*$decimal\r" { + if [info exists expect_out(buffer)] { + verbose "$expect_out(buffer)" + exp_continue + } + } + -i $shell_id timeout { + perror "Timed out trying to download." + } + } + } + timeout { + perror "Timed out waiting for response to put command." + } + } + set timeout 10 + return $result +} diff --git a/lib/util-defs.exp b/lib/util-defs.exp new file mode 100644 index 0000000..6048242 --- /dev/null +++ b/lib/util-defs.exp @@ -0,0 +1,101 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Run a utility and test the result. +# +# Parameters: +# First one is the command +# Second one is command arguments +# Third one is the file name +# Fourth one is the regexp style pattern to match for a PASS +# +# Returns: +# 1 if the test failed, +# 0 if the test passes, +# -1 if there was an internal error. +# + +proc util_test { args } { + global verbose + # get the parameters + set cmd [lindex $args 0] + verbose "Utility to execute is $cmd" 2 + set cmd_arg [lindex $args 1] + verbose "Command line arguments are $cmd_arg" 2 + set file [lindex $args 2] + verbose "The file name to use is $file" 2 + set pattern [lindex $args 3] + verbose "The pattern to match is \"$pattern\"" 2 + + if [info exists file] { + if ![string match "" $file] { + if ![file exists $file] { + perror "$file doesn't exist" + return -1 + } + } + } + + # Run the utility to be tested and analyze the results. + + set comp_output [util_start $cmd $cmd_arg $file] + + verbose "Output is \"$comp_output\"" 2 + verbose "Pattern is \"$pattern\"" 2 + + if [regexp "$pattern" $comp_output] { + verbose "Pattern matches." 2 + return 0 + } + + verbose "Pattern does not match." 2 + return 1 +} + +# +# Run the utility +# +# Return NULL or the output. +# + +proc util_start { args } { + global verbose + set cmd [lindex $args 0] + set cmd_arg [lindex $args 1] + set file [lindex $args 2] + + if {[which $cmd] == 0} { + perror "Can't find $cmd" + return "" + } + + if { $verbose > 0 } { + verbose "Spawning \"$cmd $cmd_arg $file\"" + } else { + send_log "Spawning \"$cmd $cmd_arg $file\"\n" + } + catch "exec $cmd $cmd_arg $file" comp_output + if ![string match "" $comp_output] { + send_log "$comp_output\n" + } + return $comp_output +} diff --git a/lib/utils.exp b/lib/utils.exp new file mode 100644 index 0000000..565f18e --- /dev/null +++ b/lib/utils.exp @@ -0,0 +1,441 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Most of the procedures found here mimic their unix counter-part. +# This file is sourced by runtest.exp, so they are usable by any test case. +# + +# +# Gets the directories in a directory +# args: the first is the dir to look in, the next +# is the pattern to match. It +# defaults to *. Patterns are csh style +# globbing rules +# returns: a list of dirs or NULL +# +proc getdirs { args } { + if { [lindex $args 0] == "-all" } { + set alldirs 1 + set args [lrange $args 1 end] + } else { + set alldirs 0 + } + + set path [lindex $args 0] + if { [llength $args] > 1} { + set pattern [lindex $args 1] + } else { + set pattern "*" + } + verbose "Looking in ${path} for directories that match \"${pattern}\"" 3 + catch "glob ${path}/${pattern}" tmp + if { ${tmp} != "" } { + foreach i ${tmp} { + if [file isdirectory $i] { + switch -- "[file tail $i]" { + "testsuite" - + "config" - + "lib" - + "CVS" - + "RCS" - + "SCCS" { + verbose "Ignoring directory [file tail $i]" 3 + continue + } + default { + if [file readable $i] { + verbose "Found directory [file tail $i]" 3 + lappend dirs $i + if { $alldirs } { + eval lappend dirs [getdirs -all $i $pattern] + } + } + } + } + } + } + } else { + perror "$tmp" + return "" + } + + if ![info exists dirs] { + return "" + } else { + return $dirs + } +} + +# +# Finds all the files recursively +# rootdir - this is the directory to start the search +# from. This is and all subdirectories are search for +# filenames. Directory names are not included in the +# list, but the filenames have path information. +# pattern - this is the pattern to match. Patterns are csh style +# globbing rules. +# returns: a list or a NULL. +# +proc find { rootdir pattern } { + # first find all the directories + set dirs "$rootdir " + while 1 { + set tmp $rootdir + set rootdir "" + if [string match "" $tmp] { + break + } + foreach i $tmp { + set j [getdirs $i] + if ![string match "" $j] { + append dirs "$j " + set rootdir $j + unset j + } else { + set rootdir "" + } + } + set tmp "" + } + + # find all the files that match the pattern + foreach i $dirs { + verbose "Looking in $i" 3 + set tmp [glob -nocomplain $i/$pattern] + if { [llength $tmp] != 0 } { + foreach j $tmp { + if ![file isdirectory $j] { + lappend files $j + verbose "Adding $j to file list" 3 + } + } + } + } + + if ![info exists files] { + lappend files "" + } + return $files +} + +# +# Search the path for a file. This is basically a version +# of the BSD-unix which utility. This procedure depends on +# the shell environment variable $PATH. It returns 0 if $PATH +# does not exist or the binary is not in the path. If the +# binary is in the path, it returns the full path to the binary. +# +proc which { file } { + global env + + # strip off any extraneous arguments (like flags to the compiler) + set file [lindex $file 0] + + # if it exists then the path must be OK + # ??? What if $file has no path and "." isn't in $PATH? + if [file exists $file] { + return $file + } + if [info exists env(PATH)] { + set path [split $env(PATH) ":"] + } else { + return 0 + } + + foreach i $path { + verbose "Checking against $i" 3 + if [file exists $i/$file] { + if [file executable $i/$file] { + return $i/$file + } else { + warning "$i/$file exists but is not an executable" + } + } + } + # not in path + return 0 +} + +# +# Looks for a string in a file. +# return:list of lines that matched or NULL if none match. +# args: first arg is the filename, +# second is the pattern, +# third are any options. +# Options: line - puts line numbers of match in list +# +proc grep { args } { + + set file [lindex $args 0] + set pattern [lindex $args 1] + + verbose "Grepping $file for the pattern \"$pattern\"" 3 + + set argc [llength $args] + if { $argc > 2 } { + for { set i 2 } { $i < $argc } { incr i } { + append options [lindex $args $i] + append options " " + } + } else { + set options "" + } + + set i 0 + set fd [open $file r] + while { [gets $fd cur_line]>=0 } { + incr i + if [regexp -- "$pattern" $cur_line match] { + if ![string match "" $options] { + foreach opt $options { + case $opt in { + "line" { + lappend grep_out [concat $i $match] + } + } + } + } else { + lappend grep_out $match + } + } + } + close $fd + unset fd + unset i + if ![info exists grep_out] { + set grep_out "" + } + return $grep_out +} + +# +# Remove elements based on patterns. elements are delimited by spaces. +# pattern is the pattern to look for using glob style matching +# list is the list to check against +# returns the new list +# +proc prune { list pattern } { + set tmp {} + foreach i $list { + verbose "Checking pattern \"$pattern\" against $i" 3 + if ![string match $pattern $i] { + lappend tmp $i + } else { + verbose "Removing element $i from list" 3 + } + } + return $tmp +} + +# +# Attempt to kill a process that you started on the local machine. +# +proc slay { name } { + set in [open [concat "|ps"] r] + while {[gets $in line]>-1} { + if ![string match "*expect*slay*" $line] { + if [string match "*$name*" $line] { + set pid [lindex $line 0] + catch "exec kill -9 $pid]" + verbose "Killing $name, pid = $pid\n" + } + } + } + close $in +} + +# +# Convert a relative path to an absolute one on the local machine. +# +proc absolute { path } { + if [string match "." $path] { + return [pwd] + } + + set basedir [pwd] + cd $path + set path [pwd] + cd $basedir + return $path +} + +# +# Source a file and trap any real errors. This ignores extraneous +# output. returns a 1 if there was an error, otherwise it returns 0. +# +proc psource { file } { + global errorInfo + global errorCode + + unset errorInfo + if [file exists $file] { + catch "source $file" + if [info exists errorInfo] { + send_error "ERROR: errors in $file\n" + send_error "$errorInfo" + return 1 + } + } + return 0 +} + +# +# Check if a testcase should be run or not +# +# RUNTESTS is a copy of global `runtests'. +# +# This proc hides the details of global `runtests' from the test scripts, and +# implements uniform handling of "script arguments" where those arguments are +# file names (ie: the "foo" in make check RUNTESTFLAGS="bar.exp=foo"). +# "glob" style expressions are supported as well as multiple files (with +# spaces between them). +# Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3*.c bar*.c" +# +proc runtest_file_p { runtests testcase } { + if [string length [lindex $runtests 1]] { + set basename [file tail $testcase] + foreach ptn [lindex $runtests 1] { + if [string match $ptn $basename] { + return 1 + } + if [string match $ptn $testcase] { + return 1 + } + } + return 0 + } + return 1 +} + +# +# Delete various system verbosities from TEXT on SYSTEM +# +# An example is: +# ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9 +# +# SYSTEM is typical $target_triplet or $host_triplet. +# + +# +# Compares two files line-by-line +# returns 1 it the files match, +# returns 0 if there was a file error, +# returns -1 if they didn't match. +# +proc diff { file_1 file_2 } { + set eof -1 + set differences 0 + + if [file exists ${file_1}] { + set file_a [open ${file_1} r] + } else { + warning "${file_1} doesn't exist" + return 0 + } + + if [file exists ${file_2}] { + set file_b [open ${file_2} r] + } else { + warning "${file_2} doesn't exist" + return 0 + } + + verbose "# Diff'ing: ${file_1} ${file_2}\n" 1 + + set list_a "" + while { [gets ${file_a} line] != ${eof} } { + if [regexp "^#.*$" ${line}] { + continue + } else { + lappend list_a ${line} + } + } + close ${file_a} + + set list_b "" + while { [gets ${file_b} line] != ${eof} } { + if [regexp "^#.*$" ${line}] { + continue + } else { + lappend list_b ${line} + } + } + close ${file_b} + for { set i 0 } { $i < [llength $list_a] } { incr i } { + set line_a [lindex ${list_a} ${i}] + set line_b [lindex ${list_b} ${i}] + +# verbose "\t${file_1}: ${i}: ${line_a}\n" 3 +# verbose "\t${file_2}: ${i}: ${line_b}\n" 3 + if [string compare ${line_a} ${line_b}] { + verbose "line #${i}\n" 2 + verbose "\< ${line_a}\n" 2 + verbose "\> ${line_b}\n" 2 + + send_log "line #${i}\n" + send_log "\< ${line_a}\n" + send_log "\> ${line_b}\n" + + set differences -1 + } + } + + if { $differences == -1 || [llength ${list_a}] != [llength ${list_b}] } { + verbose "Files not the same" 2 + set differences -1 + } else { + verbose "Files are the same" 2 + set differences 1 + } + return ${differences} +} + +# +# Set an environment variable +# +proc setenv { var val } { + global env + + set env($var) $val +} + +# +# Unset an environment variable +# +proc unsetenv { var } { + global env + unset env($var) +} + +# +# Get a value from an environment variable +# +proc getenv { var } { + global env + + if [info exists env($var)] { + return $env($var) + } else { + return "" + } +} + diff --git a/lib/xsh.exp b/lib/xsh.exp new file mode 100644 index 0000000..694241d --- /dev/null +++ b/lib/xsh.exp @@ -0,0 +1,322 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License 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. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Connect to Spectra (VTRX) using xsh +# +proc xsh_open { hostname } { + global hex + global target_triplet + global xsh_shell_prompt + global board_info + + if [board_info $hostname exists fileid] { + unset board_info($hostname,fileid); + } + + if ![board_info $hostname exists spectra] { + perror "No spectra directory for $hostname"; + return -1; + } else { + set spectra [board_info $hostname spectra]; + } + + if ![board_info $hostname exists xsh_shell_prompt] { + set xsh_shell_prompt ".*> " + } else { + set xsh_shell_prompt [board_info $hostname shell_prompt]; + } + + set retries 0 + set result 0 + if ![board_info $hostname exists xsh_prog] { + set xsh xsh; + } else { + set xsh [board_info $hostname xsh_prog]; + } + + if {[which $xsh] != 0} { + spawn $xsh + } else { + warning "Can't find xsh in path" + return -1 + } + + set shell_id $spawn_id + + # start the shell + expect { + "*Spectra Cross-Development Shell version*$xsh_shell_prompt" { + verbose "Got prompt" + set result 0 + } + timeout { + warning "Timed out trying to connect." + set result -1 + incr retries + if { $retries <= 2 } { + exp_continue + } + } + } + + # connect to the shell + set retries 0 + send "connect $hostname\n" + expect { + "connect $hostname*$hostname connected \(non-os mode\)*\n" { + set xsh_shell_prompt "$hostname> " + verbose "Connected to $hostname" + } + "*connect: not attached*" { + warning "Couldn't attach target" + set result -1 + } + -re ".* reset on target.*$" { + send_user "Spectra was reset\n" + exp_continue + } + -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+.*$" { + exp_continue + } + "$hostname> " { + #send "\n" + } + timeout { + warning "Timed out trying to connect after $expect_out(seconds) seconds." + set result -1 + incr retries + if { $retries <= 2 } { + exp_continue + } + } + } + + send "\n\n\n" + expect { + "*$hostname*$hostname" { + verbose "Cleared reset messages" 1 + } + timeout { + warning "Couldn't clear reset messages" + set result 1 + } + } + + set board_info($hostname,fileid) $spawn_id; + # load to operating system + set timeout 20 + set retries 0 + if {[xsh_download $hostname $spectra/${target_triplet}-os.o "" {-e sys_start_crt0}]!=0} { + perror "Couldn't load Spectra into target" + return -1 + } + + set timeout 10 + # start the OS running + set retries 0 + send "go\n" + expect { + -re ".*Multithreading on target darkstar.*$" { + verbose "Spectra has been started..." 1 + set result 0 + } + -re ".*reset on target.*$" { + verbose "Spectra was reset" + exp_continue + } + -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+.*$" { + #send "\n" + exp_continue + } + -re "go\n" { exp_continue } + "$xsh_shell_prompt" { exp_continue } + timeout { + perror "Spectra wouldn't start" + set result -1 + incr retries + if { $retries <= 2 } { + send "go\r" + exp_continue + } + } + } + + if { $result < 0 } { + perror "Couldn't connect after $retries retries.\n" + return -1 + } else { + set board_info($hostname,fileid) $spawn_id; + return $spawn_id + } +} + +# +# Download an executable using the load command in Spectra. +# arg[0] - is a full path name to the file to download. +# arg[1] - optional arguments to the load command. +# returns 1 if a spectra error occured, +# -1 if an internal error occured, +# 0 otherwise. +# +proc xsh_download { dest file destfile args } { + global verbose + global shell_id + global decimal + global hex + global expect_out + global board_info + + set result 1 + set retries 0 + set shell_id [board_info $dest fileid]; + + if { [llength $args] > 1 } { + set opts [lindex $args 1] + } else { + set opts "" + } + + if { [llength $args] > 0 } { + set destfile [lindex $args 0] + } + + if ![file exists $file] { + perror "$file doesn't exist." + return 1 + } + + verbose "Downloading $file..." + + send -i $shell_id "load $opts $file\r" + set force 0 + expect { + -i $shell_id -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+\r\n" { + set timeout 1 + send "dout\n" + while $force<2 { + expect { + "dout*undefined kernel symbol*$xsh_shell_prompt" { + verbose "Attempted to flush I/O buffers" 1 + } + timout { + incr force + flush stdout + } + } + } + set timeout 20 + exp_continue + } + -i $shell_id "load $opts $file*\r" { + verbose "Loading a.out..." + exp_continue + } + -i $shell_id "Warm reset on target*\n" { + verbose "Spectra did a warm reset" + exp_continue + } + -i $shell_id "Cold reset on target*\n" { + verbose "Spectra did a cold reset" + exp_continue + } + -i $shell_id "loading a.out*\r" { + verbose "Loading a.out..." + exp_continue + } + -i $shell_id "reading symbols*\r" { + verbose "Reading symbols..." + exp_continue + } + -i $shell_id "defining symbols*\r" { + verbose "defining symbols..." + exp_continue + } + -i $shell_id "*loading image*\r" { + verbose "Loading image..." + exp_continue + } + -i $shell_id -re ".*bytes loaded:.*$decimal.*$" { + verbose "$expect_out(buffer)" + exp_continue + } + -i $shell_id "*loading done*\r" { + verbose "Loading done..." + exp_continue + } + -i $shell_id "*setting PC*\r" { + verbose "Setting PC..." + exp_continue + } + -i $shell_id "*resolving symbols*\r" { + verbose "Resolving symbols..." + exp_continue + } + -i $shell_id -re ".*load module id = $decimal.*$" { + verbose "" + } + -i $shell_id -re ".*load: undefined symbols.*$" { + perror "undefined symbols, make sure os is loaded and running" + set result -1 + } + -i $shell_id "$xsh_shell_prompt" { + set result 0 + exp_continue + } + -i $shell_id "load: no default target" { + perror "default target isn't set" + return -1 + } + -i $shell_id timeout { + perror "Timed out trying to download after $expect_out(seconds) seconds." + incr retries + set result 1 + if { $retries <= 2 } { + exp_continue + } + } + } + + set timeout 10 + if [info exists expect_out(buffer)] { + send_log $expect_out(buffer) + } + set board_info($hostname,fileid) $shell_id + return $result +} + +# +# Exit the remote shell +# +proc xsh_close { hostname } { + global board_info + + if ![board_info $hostname exists fileid] { + return; + } + + set shell_id [board_info ${hostname} fileid]; + send -i $shell_id "exit\n" + unset board_info(${hostname},fileid); + + verbose "Exiting shell." + return 0 +} |