aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/debugger.exp244
-rw-r--r--lib/dg.exp922
-rw-r--r--lib/framework.exp898
-rw-r--r--lib/ftp.exp246
-rw-r--r--lib/kermit.exp180
-rw-r--r--lib/libgloss.exp843
-rw-r--r--lib/mondfe.exp213
-rw-r--r--lib/remote.exp1265
-rw-r--r--lib/rlogin.exp173
-rw-r--r--lib/rsh.exp258
-rw-r--r--lib/standard.exp42
-rw-r--r--lib/target.exp759
-rw-r--r--lib/targetdb.exp113
-rw-r--r--lib/telnet.exp243
-rw-r--r--lib/tip.exp184
-rw-r--r--lib/util-defs.exp101
-rw-r--r--lib/utils.exp441
-rw-r--r--lib/xsh.exp322
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
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-12 18:10:53 +0000