1 # runtest.exp
-- Test framework driver
2 # Copyright
(C
) 1992-2019, 2020, 2022, 2023 Free Software Foundation
, Inc.
4 # This file is part of DejaGnu.
6 # DejaGnu is free software
; you can redistribute it and
/or modify it
7 # under the terms of the GNU General Public License as published by
8 # the Free Software Foundation
; either version
3 of the License
, or
9 #
(at your option
) any later version.
11 # DejaGnu is distributed in the hope that it will be useful
, but
12 # WITHOUT
ANY WARRANTY
; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU
14 # General Public License
for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with DejaGnu
; if not
, write to the Free Software Foundation
,
18 # Inc.
, 51 Franklin Street
- Fifth Floor
, Boston
, MA
02110-1301, USA.
20 # This file was written by Rob Savoye
<rob@welcomehome.org
>.
22 set frame_version
1.6.4-git
23 if {![info exists argv0
]} {
24 send_error
"Must use a version of Expect greater than 5.0\n"
28 #
trap some signals so we know whats happening. These definitions are only
29 # temporary until we read in the library stuff
31 trap { send_user
"\ninterrupted by user\n"; exit 130 } SIGINT
32 trap { send_user
"\nquit\n"; exit 131 } SIGQUIT
33 trap { send_user
"\nterminated\n"; exit 143 } SIGTERM
36 # Initialize a few global variables used by all tests.
37 # `reset_vars
' resets several of these, we define them here to document their
38 # existence. In fact, it would be nice if all globals used by some interface
39 # of dejagnu proper were documented here.
41 # Keep these all lowercase. Interface variables used by the various
42 # testsuites (eg: the gcc testsuite) should be in all capitals
43 # (eg: TORTURE_OPTIONS).
45 set mail_logs 0 ;# flag for mailing of summary and diff logs
46 set psum_file "latest" ;# file name of previous summary to diff against
48 set exit_status 0 ;# exit code returned by this program
50 set xfail_flag 0 ;# indicates that a failure is expected
51 set xfail_prms 0 ;# GNATS prms id number for this expected failure
52 set kfail_flag 0 ;# indicates that it is a known failure
53 set kfail_prms 0 ;# bug id for the description of the known failure
54 set sum_file "" ;# name of the file that contains the summary log
55 set base_dir "" ;# the current working directory
56 set xml_file "" ;# handle on the XML file if requested
57 set xml 0 ;# flag for requesting xml
58 set logname "" ;# the users login name
59 set prms_id 0 ;# GNATS prms id number
60 set bug_id 0 ;# optional bug id number
61 set dir "" ;# temp variable for directory names
62 set srcdir "." ;# source directory containing the test suite
63 set ignoretests "" ;# list of tests to not execute
64 set objdir "." ;# directory where test case binaries live
66 set multipass "" ;# list of passes and var settings
68 set exit_error 1 ;# Toggle for whether to set the exit status
69 ;# on Tcl bugs in test case drivers.
71 # These describe the host and target environments.
73 set build_triplet "" ;# type of architecture to run tests on
74 set build_os "" ;# type of os the tests are running on
75 set build_vendor "" ;# vendor name of the OS or workstation the test are running on
76 set build_cpu "" ;# type of the cpu tests are running on
77 set host_triplet "" ;# type of architecture to run tests on, sometimes remotely
78 set host_os "" ;# type of os the tests are running on
79 set host_vendor "" ;# vendor name of the OS or workstation the test are running on
80 set host_cpu "" ;# type of the cpu tests are running on
81 set target_triplet "" ;# type of architecture to run tests on, final remote
82 set target_os "" ;# type of os the tests are running on
83 set target_vendor "" ;# vendor name of the OS or workstation the test are running on
84 set target_cpu "" ;# type of the cpu tests are running on
85 set target_alias "" ;# standard abbreviation of target
86 set compiler_flags "" ;# the flags used by the compiler
89 # These set configuration file names and are local to this file.
91 set local_init_file site.exp ;# testsuite-local init file name
92 set global_init_file site.exp ;# global init file name
95 # These are used to locate parts of the testsuite.
97 set testsuitedir "testsuite" ;# top-level testsuite source directory
98 set testbuilddir "testsuite" ;# top-level testsuite object directory
103 namespace eval ::dejagnu::error {
104 # list of { file message errorCode errorInfo } lists
108 # Various ccache versions provide incorrect debug info such as ignoring
109 # different current directory, breaking GDB testsuite.
110 set env(CCACHE_DISABLE) 1
111 unset -nocomplain env(CCACHE_NODISABLE)
114 # some convenience abbreviations
116 set hex "0x\[0-9A-Fa-f\]+"
117 set decimal "\[0-9\]+"
120 # set the base dir (current working directory)
125 # These are set here instead of the init module so they can be overridden
126 # by command line options.
139 # verbose [-n] [-log] [--] message [level]
141 # Print MESSAGE if the verbose level is >= LEVEL.
142 # The default value of LEVEL is 1.
143 # "-n" says to not print a trailing newline.
144 # "-log" says to add the text to the log file even if it won't be printed.
145 # Note that the apparent behaviour of `send_user
' dictates that if the message
146 # is printed it is also added to the log file.
147 # Use "--" if MESSAGE begins with "-".
149 # This is defined here rather than in framework.exp so we can use it
150 # while still loading in the support files.
152 proc verbose { args } {
158 if { [string index [lindex $args 0] 0] eq "-" } {
159 for { set i 0 } { $i < [llength $args] } { incr i } {
160 if { [lindex $args $i] eq "--" } {
163 } elseif { [lindex $args $i] eq "-n" } {
165 } elseif { [lindex $args $i] eq "-log" } {
167 } elseif { [lindex $args $i] eq "-x" } {
169 } elseif { [string index [lindex $args $i] 0] eq "-" } {
170 clone_output "ERROR: verbose: illegal argument: [lindex $args $i]"
176 if { [llength $args] == $i } {
177 clone_output "ERROR: verbose: nothing to print"
183 if { [llength $args] > $i + 1 } {
184 set level [lindex $args [expr { $i + 1 }]]
186 set message [lindex $args $i]
188 if { $verbose >= $level } {
189 # We assume send_user also sends the text to the log file (which
190 # appears to be the case though the docs aren't clear
on this
).
192 send_user
-- "$message\n"
194 send_user
-- $message
196 } elseif
{ $logfile
} {
198 send_log
-- "$message\n"
206 # Transform a tool
name to
get the installed
name.
207 # target_triplet is the canonical target
name. target_alias is the
208 # target
name used when configure was run.
210 proc transform
{ name } {
211 global target_triplet
216 if { $target_triplet eq $host_triplet
} {
219 if { $target_triplet eq
"native" } {
222 if {[board_info host
exists no_transform_name
]} {
225 if { $target_triplet eq
"" } {
228 if {[info exists board
]} {
229 if {[board_info $board
exists target_install
]} {
230 set target_install
[board_info $board target_install
]
233 if {[target_info
exists target_install
]} {
234 set target_install
[target_info target_install
]
236 if {[info exists target_alias
]} {
237 set tmp $target_alias
-$
name
238 } elseif
{[info exists target_install
]} {
239 if { [lsearch
-exact $target_install $target_alias
] >= 0 } {
240 set tmp $target_alias
-$
name
242 set tmp
"[lindex $target_install 0]-$name"
245 verbose
"Transforming $name to $tmp"
251 # findfile arg0
[arg1
] [arg2
]
253 # Find a file and see
if it
exists.
If you only care about the false
254 # condition
, then you
'll need to pass a null "" for arg1.
255 # arg0 is the filename to look for. If the only arg,
256 # then that's what gets returned.
If this is the
257 # only
arg, then if it
exists, arg0 gets returned.
258 #
if it doesn
't exist, return only the prog name.
259 # arg1 is optional, and it's what gets returned
if
261 # arg2 is optional
, and it
's what gets returned if
262 # the file doesn't exist.
264 proc findfile
{ args } {
266 verbose
"Seeing if [lindex $args 0] exists." 2
267 if {[file
exists [lindex $
args 0]]} {
268 if { [llength $
args] > 1 } {
269 verbose
"Found file, returning [lindex $args 1]"
270 return [lindex $
args 1]
272 verbose
"Found file, returning [lindex $args 0]"
273 return [lindex $
args 0]
276 if { [llength $
args] > 2 } {
277 verbose
"Didn't find file [lindex $args 0], returning [lindex $args 2]"
278 return [lindex $
args 2]
280 verbose
"Didn't find file, returning [file tail [lindex $args 0]]"
281 return [transform
[file tail
[lindex $
args 0]]]
287 # load_file
[-1] [--] file1
[ file2 ...
]
289 # Utility to source a file. All are sourced in order unless the flag
"-1"
290 # is given in which case we stop after finding the first one.
291 # The result is
1 if a file was found
, 0 if not.
292 #
If a tcl error occurs
while sourcing a file
, we print an error message
295 proc load_file
{ args } {
298 if { [lindex $
args $i
] eq
"-1" } {
302 if { [lindex $
args $i
] eq
"--" } {
307 foreach file
[lrange $
args $i end
] {
308 verbose
"Looking for $file" 2
309 # In Tcl
, "file exists" fails if the filename looks like
310 # ~
/FILE and the environment
variable HOME does not exist.
311 if {! [catch
{file
exists $file
} result
] && $result
} {
313 verbose
"Found $file"
314 if { [catch
"uplevel #0 source $file"] == 1 } {
315 send_error
"ERROR: tcl error sourcing $file.\n"
317 if {[info exists errorInfo
]} {
318 send_error
"$errorInfo\n"
331 # search_and_load_file
-- search DIRLIST looking
for FILELIST.
332 # TYPE is used when displaying error and progress messages.
334 proc search_and_load_file
{ type filelist dirlist
} {
337 foreach
dir $dirlist
{
338 foreach initfile $filelist
{
339 set filename
[file join $
dir $initfile
]
340 verbose
"Looking for $type $filename" 2
341 if {[file
exists $filename
]} {
344 if { $type ne
"library file" } {
345 send_user
"Using $filename as $type.\n"
347 verbose
"Loading $filename"
349 if {[catch
"uplevel #0 source $filename" error] == 1} {
351 send_error
"ERROR: tcl error sourcing $type $filename.\n$error\n"
352 if {[info exists errorInfo
]} {
353 send_error
"$errorInfo\n"
368 # Give a usage statement.
373 send_user
"USAGE: runtest \[options...\]\n"
374 send_user
"\t--all, -a\t\tPrint all test output to screen\n"
375 send_user
"\t--build \[triplet\]\tThe canonical triplet of the build machine\n"
376 send_user
"\t--debug\t\t\tSet expect debugging ON\n"
377 send_user
"\t--directory name\tRun only the tests in directory 'name'\n"
378 send_user
"\t--global_init \[name\]\tThe file to load for global configuration\n"
379 send_user
"\t--help\t\t\tPrint help text\n"
380 send_user
"\t--host \[triplet\]\tThe canonical triplet of the host machine\n"
381 send_user
"\t--host_board \[name\]\tThe host board to use\n"
382 send_user
"\t--ignore \[name(s)\]\tThe names of specific tests to ignore\n"
383 send_user
"\t--local_init \[name\]\tThe file to load for local configuration\n"
384 send_user
"\t--log_dialog\t\t\Emit Expect output on stdout\n"
385 send_user
"\t--mail \[name(s)\]\tWhom to mail the results to\n"
386 send_user
"\t--objdir \[name\]\t\tThe test suite binary directory\n"
387 send_user
"\t--outdir \[name\]\t\tThe directory to put logs in\n"
388 send_user
"\t--reboot\t\tReboot the target (if supported)\n"
389 send_user
"\t--srcdir \[name\]\t\tThe test suite source code directory\n"
390 send_user
"\t--status\t\tSet the exit status to fail on Tcl errors\n"
391 send_user
"\t--strace \[number\]\tTurn on Expect tracing\n"
392 send_user
"\t--target \[triplet\]\tThe canonical triplet of the target board\n"
393 send_user
"\t--target_board \[name(s)\] The list of target boards to run tests on\n"
394 send_user
"\t--tool \[name(s)\]\tRun tests on these tools\n"
395 send_user
"\t--tool_exec \[name\]\tThe path to the tool executable to test\n"
396 send_user
"\t--tool_opts \[options\]\tA list of additional options to pass to the tool\n"
397 send_user
"\t--verbose, -v\t\tProduce verbose output\n"
398 send_user
"\t--version, -V\t\tPrint all relevant version numbers\n"
399 send_user
"\t--xml, -x\t\tWrite out an XML results file\n"
400 send_user
"\t--D\[0-1\]\t\tTcl debugger\n"
401 send_user
"\tscript.exp\[=arg(s)\]\tRun these tests only\n"
402 if { [info exists tool
] } {
403 if { [info procs $
{tool
}_option_help
] ne
"" } {
410 #
Parse the arguments the first time looking
for these. We will ultimately
411 #
parse them twice. Things are complicated because
:
412 #
- we want to
parse --verbose early
on
413 #
- we don
't want config files to override command line arguments
414 # (eg: $base_dir/$local_init_file vs --host/--target)
415 # - we need some command line arguments before we can process some config files
416 # (eg: --objdir before $objdir/$local_init_file, --host/--target before $DEJAGNU)
417 # The use of `arg_host_triplet' and `arg_target_triplet
' lets us avoid parsing
418 # the arguments three times.
421 namespace eval ::dejagnu::command_line {
422 variable cmd_var_list [list]
424 proc save_cmd_var {name} {
425 variable cmd_var_list
427 upvar 1 $name target_var
428 lappend cmd_var_list $name $target_var
431 proc restore_cmd_vars {} {
432 variable cmd_var_list
434 foreach {name value} $cmd_var_list {
435 uplevel 1 [list set $name $value]
437 verbose "Variables set by command line arguments restored." 4
440 proc dump_cmd_vars {} {
441 variable cmd_var_list
443 verbose "Variables set by command line arguments:" 4
444 foreach {name value} $cmd_var_list {
445 verbose " $name -> $value" 4
450 set arg_host_triplet ""
451 set arg_target_triplet ""
452 set arg_build_triplet ""
453 set argc [ llength $argv ]
454 for { set i 0 } { $i < $argc } { incr i } {
455 set option [lindex $argv $i]
457 # make all options have two hyphens
458 switch -glob -- $option {
462 set option "-$option"
466 # split out the argument for options that take them
467 switch -glob -- $option {
469 regexp {^[^=]*=(.*)$} $option nil optarg
485 set optarg [lindex $argv $i]
489 switch -glob -- $option {
491 "--vers*" { # (--version) version numbers
492 send_user "DejaGnu version\t$frame_version\n"
493 send_user "Expect version\t[exp_version]\n"
494 send_user "Tcl version\t[ info tclversion ]\n"
498 "--bu*" { # (--build) the build host configuration
499 set arg_build_triplet $optarg
500 ::dejagnu::command_line::save_cmd_var arg_build_triplet
504 "--g*" { # (--global_init) the global init file name
505 set global_init_file $optarg
506 ::dejagnu::command_line::save_cmd_var global_init_file
511 set host_board $optarg
512 ::dejagnu::command_line::save_cmd_var host_board
516 "--ho*" { # (--host) the host configuration
517 set arg_host_triplet $optarg
518 ::dejagnu::command_line::save_cmd_var arg_host_triplet
522 "--loc*" { # (--local_init) the local init file name
523 set local_init_file $optarg
524 ::dejagnu::command_line::save_cmd_var local_init_file
528 "--ob*" { # (--objdir) where the test case object code lives
530 ::dejagnu::command_line::save_cmd_var objdir
534 "--sr*" { # (--srcdir) where the testsuite source code lives
536 ::dejagnu::command_line::save_cmd_var srcdir
541 set target_list $optarg
542 ::dejagnu::command_line::save_cmd_var target_list
546 "--ta*" { # (--target) the target configuration
547 set arg_target_triplet $optarg
548 ::dejagnu::command_line::save_cmd_var arg_target_triplet
553 set TOOL_OPTIONS $optarg
554 ::dejagnu::command_line::save_cmd_var TOOL_OPTIONS
559 set TOOL_EXECUTABLE $optarg
560 ::dejagnu::command_line::save_cmd_var TOOL_EXECUTABLE
564 "--to*" { # (--tool) specify tool name
566 set comm_line_tool $optarg
567 ::dejagnu::command_line::save_cmd_var tool
568 ::dejagnu::command_line::save_cmd_var comm_line_tool
573 set cmdline_dir_to_run $optarg
574 ::dejagnu::command_line::save_cmd_var cmdline_dir_to_run
579 "--verb*" { # (--verbose) verbose output
584 "[A-Z0-9_-.]*=*" { # process makefile style args like CC=gcc, etc...
585 if {[regexp "^(\[A-Z0-9_-\]+)=(.*)$" $option junk var val]} {
587 verbose "$var is now $val"
588 append makevars "set $var $val;" ;# FIXME: Used anywhere?
591 send_error "Illegal variable specification:\n"
592 send_error "$option\n"
599 verbose "Verbose level is $verbose"
601 verbose [concat "Initial working directory is" [pwd]]
603 ::dejagnu::command_line::dump_cmd_vars
606 # get the users login name
608 if { $logname eq "" } {
609 if {[info exists env(USER)]} {
610 set logname $env(USER)
612 if {[info exists env(LOGNAME)]} {
613 set logname $env(LOGNAME)
615 # try getting it with whoami
616 catch "set logname [exec whoami]" tmp
617 if {[string match "*couldn't find
*to
execute*" $tmp]} {
618 # try getting it with who am i
620 catch
"set logname [exec who am i]" tmp
621 if {[string match
"*Command not found*" $tmp]} {
622 send_user
"ERROR: couldn't get the users login name\n"
623 set logname
"Unknown"
625 set logname
[lindex
[split $logname
" !"] 1]
632 verbose
"Login name is $logname"
635 # lookfor_file
-- try to find a file by searching up multiple directory levels
637 proc lookfor_file
{ dir name } {
638 foreach x
[list . .. ..
/.. ..
/..
/.. ..
/..
/..
/..
] {
639 verbose $
dir/$x
/$
name 2
640 if {[file
exists [file join $
dir $
name]]} {
641 return [file join $
dir $
name]
643 set dir [remote_file build dirname $
dir]
649 # load_lib
-- load a library by sourcing it
651 #
If there a multiple files with the same
name, stop after the first one found.
652 # The order is first look in the install
dir, then in a parallel
dir in the
653 # source tree
(up one or two levels
), then in the current
dir.
655 proc load_lib
{ file
} {
656 global verbose execpath tool
657 global libdir libdirs srcdir testsuitedir base_dir
660 if {[info exists loaded_libs
($file
)]} {
664 set loaded_libs
($file
) ""
665 set search_dirs
[list ..
/lib $libdir $libdir
/lib
]
666 lappend search_dirs
[file dirname
[file dirname $srcdir
]]/dejagnu
/lib
667 lappend search_dirs $testsuitedir
/lib
668 lappend search_dirs $execpath
/lib
"."
669 lappend search_dirs
[file dirname
[file dirname
[file dirname $srcdir
]]]/dejagnu
/lib
670 if {[info exists libdirs
]} {
671 lappend search_dirs $libdirs
673 if { [search_and_load_file
"library file" $file $search_dirs ] == 0 } {
674 send_error
"ERROR: Couldn't find library file $file.\n"
680 # Begin sourcing the config files.
681 # All are sourced in order.
684 #
(local
) $base_dir
/$local_init_file
-> $objdir
/$local_init_file
->
685 #
(global
) installed
($global_init_file
) -> $DEJAGNU
-> $HOME
/.dejagnurc
687 #
For the
normal case
, we expect $base_dir
/$local_init_file to
set
688 # host_triplet and target_triplet.
691 load_file
[file join $base_dir $local_init_file
]
693 # Ensure that command line parameters override testsuite init files.
694 ::dejagnu
::command_line
::restore_cmd_vars
697 #
If objdir didn
't get set in $base_dir/$local_init_file, set it to
698 # $base_dir. Make sure we source $objdir/$local_init_file in case
699 # $base_dir/$local_init_file doesn't exist and objdir was given
on the
703 if { $objdir eq
"." || $objdir eq $srcdir } {
706 load_file
[file join $objdir $local_init_file
]
709 # Ensure that command line parameters override testsuite init files.
710 ::dejagnu
::command_line
::restore_cmd_vars
713 # Find the testsuite.
716 # The DejaGnu manual has always stated that a testsuite must be in a
717 # testsuite
/ subdirectory.
719 verbose
"Finding testsuite ..." 3
720 verbose
"\$base_dir -> $base_dir" 3
721 verbose
"\$srcdir -> $srcdir" 3
722 verbose
"\$objdir -> $objdir" 3
723 verbose
[concat
"file tail \$srcdir -> " [file tail $srcdir]] 3
724 verbose
[concat
"file join \$srcdir testsuite -> " \
725 [file join $srcdir testsuite
]] 3
726 verbose
[concat
"file isdirectory [file join \$srcdir testsuite] -> " \
727 [file isdirectory
[file join $srcdir testsuite
]]] 3
728 verbose
[concat
"file tail \$base_dir -> " [file tail $base_dir]] 3
730 if { [file tail $srcdir
] eq
"testsuite" } {
731 # Subdirectory case
-- $srcdir includes testsuite
/
732 set testsuitedir $srcdir
733 set testbuilddir $objdir
734 } elseif
{ [file tail $srcdir
] ne
"testsuite"
735 && [file isdirectory
[file join $srcdir testsuite
]] } {
736 # Top
-level case
-- testsuite in $srcdir
/testsuite
/
737 set testsuitedir
[file join $srcdir testsuite
]
738 set testbuilddir
[file join $objdir testsuite
]
739 } elseif
{ $srcdir eq
"." && [file tail $base_dir] eq "testsuite" } {
740 # Development scaffold case
-- testsuite in
".", but "." is "testsuite"
741 set testsuitedir $base_dir
742 set testbuilddir $base_dir
744 if { $testsuitedir eq
"testsuite" && $testbuilddir eq "testsuite" } {
745 # Broken legacy case
-- testsuite not actually in testsuite
/
746 # Produce a warning
, but
continue.
747 send_error
"WARNING: testsuite is not in a testsuite/ directory.\n"
748 set testsuitedir $srcdir
749 set testbuilddir $objdir
751 # Custom case
-- all variables are assumed to have been
set correctly
755 verbose
"Finding testsuite ... done" 3
757 # Well
, this just demonstrates the real problem...
758 if {![info exists tool_root_dir
]} {
759 set tool_root_dir
[file dirname $objdir
]
760 if {[file
exists [file join $tool_root_dir testsuite
]]} {
761 set tool_root_dir
[file dirname $tool_root_dir
]
765 verbose
"Using test sources in $srcdir"
766 verbose
"Using test binaries in $objdir"
767 verbose
"Testsuite root is $testsuitedir"
768 verbose
"Tool root directory is $tool_root_dir"
770 set execpath
[file dirname $argv0
]
772 # The runtest.exp file is installed directly in libdir.
773 # Conveniently
, the source tree layout is the same as the installed libdir.
774 set libdir
[file dirname $argv0
]
775 if {[info exists env
(DEJAGNULIBS
)]} {
776 set libdir $env
(DEJAGNULIBS
)
778 # list of extra search directories used by load_lib to look
for libs
781 verbose
"Using $libdir to find libraries"
784 #
If the host or target was given
on the command line
, override the above
785 # config files. We allow $DEJAGNU to massage them though in case it would
786 # ever want to
do such a thing.
788 if { $arg_host_triplet ne
"" } {
789 set host_triplet $arg_host_triplet
791 if { $arg_build_triplet ne
"" } {
792 set build_triplet $arg_build_triplet
795 #
If we only specify
--host
, then that must be the build machine too
,
796 # and we
're stuck using the old functionality of a simple cross test.
797 if {[expr { $build_triplet eq "" && $host_triplet ne "" } ]} {
798 set build_triplet $host_triplet
800 # If we only specify --build, then we'll use that as the host too.
801 if {[expr
{ $build_triplet ne
"" && $host_triplet eq "" } ]} {
802 set host_triplet $build_triplet
804 unset arg_host_triplet arg_build_triplet
807 #
If the build machine type hasn
't been specified by now, use config.guess.
810 if {[expr {$build_triplet eq "" && $host_triplet eq ""}]} {
812 foreach dir [list $libdir $libdir/libexec $libdir/.. $execpath $srcdir $srcdir/.. $srcdir/../..] {
813 verbose "Looking for $dir/config.guess" 2
814 if {[file exists [file join $dir config.guess]]} {
815 set config_guess [file join $dir config.guess]
816 verbose "Found [file join $dir config.guess]"
821 # get the canonical triplet
822 if {![info exists config_guess]} {
823 send_error "ERROR: Couldn't find config.guess
program.
\n"
826 if { [info exists ::env
(CONFIG_SHELL
)] } {
827 if { [catch
{exec $
::env
(CONFIG_SHELL
) $config_guess
} build_triplet
] } {
828 if { [lindex $
::errorCode
0] eq
"CHILDSTATUS" } {
829 send_error
"ERROR: Running config.guess with\
830 CONFIG_SHELL
=$
::env
(CONFIG_SHELL
)\
832 [lindex $
::errorCode
2].
\n"
834 send_error
"ERROR: Running config.guess with\
835 CONFIG_SHELL
=$
::env
(CONFIG_SHELL
)\
837 send_error
" $::errorCode\n"
840 } elseif
{ [info exists ::env
(SHELL)] } {
841 if { [catch
{exec $
::env
(SHELL) $config_guess
} build_triplet
] } {
842 if { [lindex $
::errorCode
0] eq
"CHILDSTATUS" } {
843 send_error
"ERROR: Running config.guess with\
846 [lindex $
::errorCode
2].
\n"
848 send_error
"ERROR: Running config.guess with\
851 send_error
" $::errorCode\n"
855 if { [catch
{exec $config_guess
} build_triplet
] } {
856 if { [lindex $
::errorCode
0] eq
"CHILDSTATUS" } {
857 send_error
"ERROR: Running config.guess exited on code\
858 [lindex $
::errorCode
2].
\n"
860 send_error
"ERROR: Running config.guess produced error:\n"
861 send_error
" $::errorCode\n"
865 if { ![regexp
-- {^
[[:alnum
:]_.
]+(-[[:alnum
:]_.
]+)+$
} $build_triplet
] } {
866 send_error
"ERROR: Running config.guess produced bogus build triplet:\n"
867 send_error
" $build_triplet\n"
868 send_error
" (Perhaps you need to set CONFIG_SHELL or\
869 SHELL in your environment
\n"
870 send_error
" to the absolute file name of a POSIX shell?)\n"
873 verbose
"Assuming build host is $build_triplet"
874 if { $host_triplet eq
"" } {
875 set host_triplet $build_triplet
880 # Figure out the target.
If the target hasn
't been specified, then we have to
881 # assume we are native.
883 if { $arg_target_triplet ne "" } {
884 set target_triplet $arg_target_triplet
885 } elseif { $target_triplet eq "" } {
886 set target_triplet $build_triplet
887 verbose "Assuming native target is $target_triplet" 2
889 unset arg_target_triplet
891 # Default target_alias to target_triplet.
893 if {![info exists target_alias]} {
894 set target_alias $target_triplet
897 proc get_local_hostname { } {
898 if {[catch "info hostname" hb]} {
901 regsub "\\..*$" $hb "" hb
903 verbose "hostname=$hb" 3
908 # We put these here so that they can be overridden later by site.exp or
911 # Set up the target as machine NAME. We also load base-config.exp as a
912 # default configuration. The config files are sourced with the global
913 # variable $board set to the name of the current target being defined.
915 proc setup_target_hook { whole_name name } {
919 if {[info exists host_board]} {
922 set hb [get_local_hostname]
925 set board $whole_name
928 set board_type "target"
930 load_config base-config.exp
931 if {![load_board_description $name $whole_name $hb]} {
932 if { $name ne "unix" } {
933 perror "couldn't
load description file
for $
name"
936 load_generic_config
"unix"
940 if {[board_info $board
exists generic_name
]} {
941 load_tool_target_config
[board_info $board generic_name
]
947 push_target $whole_name
949 if { [info procs $
{whole_name
}_init
] ne
"" } {
950 $
{whole_name
}_init $whole_name
953 if { ![isnative
] && ![isremote target
] } {
954 global env build_triplet target_triplet
955 if { (![info exists env
(DEJAGNU
)]) && ($build_triplet ne $target_triplet
) } {
956 warning
"Assuming target board is the local machine (which is probably wrong).\nYou may need to set your DEJAGNU environment variable."
962 # Clean things up afterwards.
964 proc cleanup_target_hook
{ name } {
966 # Clean up the target board.
967 if { [info procs $
{name}_exit
] ne
"" } {
970 # We also
call the tool exit routine here.
971 if {[info exists tool
]} {
972 if { [info procs $
{tool
}_exit
] ne
"" } {
980 proc setup_host_hook
{ name } {
986 set board_type
"host"
988 load_board_description $
name
992 if { [info procs $
{name}_init
] ne
"" } {
997 proc setup_build_hook
{ name } {
1003 set board_type
"build"
1005 load_board_description $
name
1009 if { [info procs $
{name}_init
] ne
"" } {
1015 # Find and
load the global config file
if it
exists.
1016 # The global config file is used to
set the
connect mode and other
1017 # parameters specific to each particular target.
1018 # These files assume the host and target have been
set.
1021 if { [load_file
-- [file join $libdir $global_init_file
]] == 0 } {
1022 #
If $DEJAGNU isn
't set either then there isn't
any global config file.
1023 # Warn the user as there really should be one.
1024 if { ! [info exists env
(DEJAGNU
)] } {
1025 send_error
"WARNING: Couldn't find the global config file.\n"
1029 if {[info exists env
(DEJAGNU
)]} {
1030 if { [load_file
-- $env
(DEJAGNU
)] == 0 } {
1031 # It may seem odd to only issue a warning
if there isn
't a global
1032 # config file, but issue an error if $DEJAGNU is erroneously defined.
1033 # Since $DEJAGNU is set there is *supposed* to be a global config file,
1034 # so the current behaviour seems reasonable.
1035 send_error "ERROR: global config file $env(DEJAGNU) not found.\n"
1038 if {![info exists boards_dir]} {
1039 set boards_dir "[file dirname $env(DEJAGNU)]/boards"
1043 # Load user .dejagnurc file last as the ultimate override.
1044 load_file ~/.dejagnurc
1046 if {![info exists boards_dir]} {
1051 # parse out the config parts of the triplet name
1055 if { $build_cpu eq "" } {
1056 regsub -- "-.*-.*" $build_triplet "" build_cpu
1058 if { $build_vendor eq "" } {
1059 regsub -- "^\[a-z0-9\]*-" $build_triplet "" build_vendor
1060 regsub -- "-.*" $build_vendor "" build_vendor
1062 if { $build_os eq "" } {
1063 regsub -- ".*-.*-" $build_triplet "" build_os
1067 if { $host_cpu eq "" } {
1068 regsub -- "-.*-.*" $host_triplet "" host_cpu
1070 if { $host_vendor eq "" } {
1071 regsub -- "^\[a-z0-9\]*-" $host_triplet "" host_vendor
1072 regsub -- "-.*" $host_vendor "" host_vendor
1074 if { $host_os eq "" } {
1075 regsub -- ".*-.*-" $host_triplet "" host_os
1079 if { $target_cpu eq "" } {
1080 regsub -- "-.*-.*" $target_triplet "" target_cpu
1082 if { $target_vendor eq "" } {
1083 regsub -- "^\[a-z0-9\]*-" $target_triplet "" target_vendor
1084 regsub -- "-.*" $target_vendor "" target_vendor
1086 if { $target_os eq "" } {
1087 regsub -- ".*-.*-" $target_triplet "" target_os
1091 # Load the primary tool initialization file.
1094 proc load_tool_init { file } {
1095 global srcdir testsuitedir
1098 if {[info exists loaded_libs(tool/$file)]} {
1102 set loaded_libs(tool/$file) ""
1104 lappend searchpath [file join $testsuitedir lib tool]
1105 lappend searchpath [file join $testsuitedir lib]
1106 # for legacy testsuites that might have files in lib/ instead of
1107 # testsuite/lib/ in the package source tree; deprecated
1108 lappend searchpath [file join $srcdir lib]
1110 if { ![search_and_load_file "tool init file" [list $file] $searchpath] } {
1111 warning "Couldn't find tool init file
"
1116 #
load the testing framework libraries
1119 load_lib framework.exp
1120 load_lib debugger.exp
1123 load_lib targetdb.exp
1124 load_lib libgloss.exp
1126 # Initialize the test counters and reset them to
0.
1131 #
Parse the command line arguments.
1134 #
Load the tool initialization file. Allow the
--tool option to override
1135 # what
's set in the site.exp file.
1136 if {[info exists comm_line_tool]} {
1137 set tool $comm_line_tool
1140 if {[info exists tool]} {
1141 load_tool_init ${tool}.exp
1144 set argc [ llength $argv ]
1145 for { set i 0 } { $i < $argc } { incr i } {
1146 set option [ lindex $argv $i ]
1148 # make all options have two hyphens
1149 switch -glob -- $option {
1153 set option "-$option"
1157 # split out the argument for options that take them
1158 switch -glob -- $option {
1160 regexp {^[^=]*=(.*)$} $option nil optarg
1176 set optarg [lindex $argv $i]
1180 switch -glob -- $option {
1181 "--v*" { # (--verbose) verbose output
1186 "--g*" { # (--global_init) the global init file name
1187 # Already parsed (and no longer useful). The file has been loaded.
1191 "--loc*" { # (--local_init) the local init file name
1192 # Already parsed (and no longer useful). The file has been loaded.
1196 "--bu*" { # (--build) the build host configuration
1197 # Already parsed (and don't
set again
). Let $DEJAGNU
rename it.
1201 "--ho*" { # (--host) the host configuration
1202 # Already parsed
(and don
't set again). Let $DEJAGNU rename it.
1207 # Set it again, father knows best.
1208 set target_list $optarg
1212 "--ta*" { # (--target) the target configuration
1213 # Already parsed (and don't
set again
). Let $DEJAGNU
rename it.
1217 "--a*" { # (--all) print all test output to screen
1219 verbose
"Print all test output to screen"
1224 # Already parsed
(and don
't set again). Let $DEJAGNU rename it.
1229 "--de*" { # (--debug) expect internal debugging
1230 if {[file exists ./dbg.log]} {
1231 catch [file delete -force -- dbg.log]
1233 if { $verbose > 2 } {
1234 exp_internal -f dbg.log 1
1236 exp_internal -f dbg.log 0
1238 verbose "Expect Debugging is ON"
1242 "--D[01]" { # (-Debug) turn on Tcl debugger
1243 # The runtest shell script handles this option, but it
1244 # still appears in the options in the Tcl code.
1245 verbose "Tcl debugger is ON"
1249 "--m*" { # (--mail) mail the output
1250 set mailing_list $optarg
1252 verbose "Mail results to $mailing_list"
1256 "--r*" { # (--reboot) reboot the target
1258 verbose "Will reboot the target (if supported)"
1262 "--ob*" { # (--objdir) where the test case object code lives
1263 # Already parsed, but parse again to make sure command line
1264 # options override any config file.
1266 verbose "Using test binaries in $objdir"
1270 "--ou*" { # (--outdir) where to put the output files
1272 verbose "Test output put in $outdir"
1281 "*.exp" { # specify test names to run
1282 set all_runtests($option) ""
1283 verbose "Running only tests $option"
1287 "*.exp=*" { # specify test names to run
1288 set tmp [split $option "="]
1289 set all_runtests([lindex $tmp 0]) [lindex $tmp 1]
1290 verbose "Running only tests $option"
1295 "--ig*" { # (--ignore) specify test names to exclude
1296 set ignoretests $optarg
1297 verbose "Ignoring test $ignoretests"
1301 "--sr*" { # (--srcdir) where the testsuite source code lives
1302 # Already parsed, but parse again to make sure command line
1303 # options override any config file.
1309 "--str*" { # (--strace) expect trace level
1310 set tracelevel $optarg
1312 verbose "Source Trace level is now $tracelevel"
1316 "--sta*" { # (--status) exit status flag
1317 # preserved for compatability, do nothing
1326 set TOOL_EXECUTABLE $optarg
1330 "--to*" { # (--tool) specify tool name
1332 verbose "Testing $tool"
1338 verbose "XML logging turned on"
1342 "--he*" { # (--help) help text
1347 "[A-Z0-9_-.]*=*" { # skip makefile style args like CC=gcc, etc... (processed in first pass)
1352 if {[info exists tool]} {
1353 if { [info procs ${tool}_option_proc] ne "" } {
1354 if {[${tool}_option_proc $option]} {
1359 send_error "\nIllegal Argument \"$option\"\n"
1360 send_error "try \"runtest --help\" for option list\n"
1367 # check for a few crucial variables
1369 if {![info exists tool]} {
1370 send_error "WARNING: No tool specified\n"
1375 # initialize a few Tcl variables to something other than their default
1377 if { $verbose > 2 || $log_dialog } {
1392 # print the config info
1393 clone_output "Test run by $logname on [timestamp -format %c]"
1395 clone_output "Target is $target_triplet"
1396 clone_output "Host is $host_triplet"
1397 clone_output "Build is $build_triplet"
1400 clone_output "Native configuration is $target_triplet"
1402 clone_output "Target is $target_triplet"
1403 clone_output "Host is $host_triplet"
1407 clone_output "\n\t\t=== $tool tests ===\n"
1410 # Look for the generic board configuration file. It searches in several
1411 # places: $libdir/config, $libdir/../config, and $boards_dir.
1414 proc load_generic_config { name } {
1421 if {[info exists board]} {
1422 if {![info exists board_info($board,generic_name)]} {
1423 set board_info($board,generic_name) $name
1427 if {[info exists board_type]} {
1428 set type "for $board_type"
1433 set dirlist [concat $libdir/config [file dirname $libdir]/config $boards_dir]
1434 set result [search_and_load_file "generic interface file $type" $name.exp $dirlist]
1440 # Load the tool-specific target description.
1442 proc load_config { args } {
1447 return [search_and_load_file "tool-and-target-specific interface file" $args [list $testsuitedir/config $testsuitedir/../config $testsuitedir/../../config $testsuitedir/../../../config]]
1451 # Find the files that set up the configuration for the target. There
1452 # are assumed to be two of them; one defines a basic set of
1453 # functionality for the target that can be used by all tool
1454 # testsuites, and the other defines any necessary tool-specific
1455 # functionality. These files are loaded via load_config.
1457 # These used to all be named $target_abbrev-$tool.exp, but as the
1458 # $tool variable goes away, it's now just $target_abbrev.exp. First
1459 # we look
for a file named with both the abbrev and the tool names.
1460 #
Then we look
for one named with just the abbrev
name. Finally
, we
1461 # look
for a file called default
, which is the default actions
, as
1462 # some tools could be purely host based. Unknown is mostly
for error
1466 proc load_tool_target_config
{ name } {
1467 global target_os libdir testsuitedir
1469 set found
[load_config $
name.exp $target_os.exp
"default.exp" "unknown.exp"]
1471 if { $found
== 0 } {
1472 send_error
"WARNING: Couldn't find tool config file for $name, using default.\n"
1473 #
If we can
't load the tool init file, this must be a simple natively hosted
1474 # test suite, so we use the default procs for Unix.
1475 if { [search_and_load_file "library file" default.exp [list $libdir $libdir/config [file dirname [file dirname $testsuitedir]]/dejagnu/config $testsuitedir/config . [file dirname [file dirname [file dirname $testsuitedir]]]/dejagnu/config]] == 0 } {
1476 send_error "ERROR: Couldn't find default tool init file.
\n"
1483 # Find the file that describes the machine specified by board_name.
1486 proc load_board_description
{ board_name
args } {
1495 if { [llength $
args] > 0 } {
1496 set whole_name
[lindex $
args 0]
1498 set whole_name $board_name
1501 set board_info
($whole_name
,name) $whole_name
1502 if {![info exists board
]} {
1503 set board $whole_name
1510 if { [llength $
args] > 1 } {
1511 set suffix
[lindex $
args 1]
1512 if { $suffix ne
"" } {
1513 foreach x $boards_dir
{
1514 lappend dirlist $x
/$suffix
1516 lappend dirlist $libdir
/baseboards
/$suffix
1519 set dirlist
[concat $dirlist $boards_dir
]
1520 lappend dirlist $libdir
/baseboards
1521 verbose
"dirlist is $dirlist"
1522 if {[info exists board_type
]} {
1523 set type
"for $board_type"
1527 if {![info exists board_info
($whole_name
,isremote
)]} {
1528 set board_info
($whole_name
,isremote
) 1
1529 if {[info exists board_type
]} {
1530 if { $board_type eq
"build" } {
1531 set board_info
($whole_name
,isremote
) 0
1534 if { $board_name eq
[get_local_hostname
] } {
1535 set board_info
($whole_name
,isremote
) 0
1538 search_and_load_file
"standard board description file $type" standard.exp $dirlist
1539 set found
[search_and_load_file
"board description file $type" $board_name.exp $dirlist]
1540 if { $board_set
!= 0 } {
1548 # Find the base
-level file that describes the machine specified by
args. We
1549 # only look in one directory
, $libdir
/baseboards.
1552 proc load_base_board_description
{ board_name
} {
1559 set board_info
($board_name
,name) $board_name
1560 if {![info exists board
]} {
1561 set board $board_name
1564 if {[info exists board_type
]} {
1565 set type
"for $board_type"
1569 if {![info exists board_info
($board_name
,isremote
)]} {
1570 set board_info
($board_name
,isremote
) 1
1571 if {[info exists board_type
]} {
1572 if { $board_type eq
"build" } {
1573 set board_info
($board_name
,isremote
) 0
1578 if { $board_name eq
[get_local_hostname
] } {
1579 set board_info
($board_name
,isremote
) 0
1581 set found
[search_and_load_file
"board description file $type" $board_name.exp [list $libdir/baseboards]]
1582 if { $board_set
!= 0 } {
1590 # Source the testcase in TEST_FILE_NAME.
1593 proc runtest
{ test_file_name
} {
1597 global errcnt warncnt
1603 clone_output
"Running $test_file_name ..."
1610 #
set testdir so testsuite file
-test has a starting point
1611 set testdir
[file dirname $test_file_name
]
1613 if {[file
exists $test_file_name
]} {
1614 set timestart
[timestamp
]
1616 if {[info exists tool
]} {
1617 if { [info procs $
{tool
}_init
] ne
"" } {
1618 $
{tool
}_init $test_file_name
1622 if { [catch
"uplevel #0 source $test_file_name" msg] == 1 } {
1623 #
If we have a Tcl error
, propagate the exit
status so
1624 # that
'make' (if it invokes runtest
) notices the error.
1625 global exit_status exit_error
1626 # exit error is
set by the
--status command line option
1627 if { $exit_status
== 0 } {
1630 set new_error
[list $test_file_name $msg
]
1631 # We can
't call `perror' here
, it resets `errorInfo
'
1632 # before we want to look at it. Also remember that perror
1633 # increments `errcnt'.
If we
do call perror we
'd have to
1634 # reset errcnt afterwards.
1635 clone_output "ERROR: tcl error sourcing $test_file_name."
1636 if {[info exists errorCode]} {
1637 clone_output "ERROR: tcl error code $errorCode"
1638 lappend new_error $errorCode
1640 lappend new_error [list]
1642 if {[info exists errorInfo]} {
1643 clone_output "ERROR: $errorInfo"
1644 lappend new_error $errorInfo
1647 lappend new_error [list]
1649 lappend ::dejagnu::error::list $new_error
1650 unresolved "testcase '$test_file_name
' aborted due to Tcl error"
1653 if {[info exists tool]} {
1654 if { [info procs ${tool}_finish] ne "" } {
1658 set timeend [timestamp]
1659 set timediff [expr {$timeend - $timestart}]
1660 verbose -log "testcase $test_file_name completed in $timediff seconds" 4
1662 # This should never happen, but maybe if the file got removed
1663 # between the `find' above and here.
1664 perror
"$test_file_name does not exist." 0
1668 #
Trap some signals so we know what
's happening. These replace the previous
1669 # ones because we've now loaded the library stuff.
1672 foreach sig
{{SIGINT
{interrupted by user
} 130} \
1673 {SIGQUIT
{interrupted by user
} 131} \
1674 {SIGTERM
{terminated
} 143}} {
1675 set signal [lindex $sig
0]
1676 set str
[lindex $sig
1]
1677 set code
[lindex $sig
2]
1678 trap "send_error \"got a \[trap -name\] signal, $str \\n\"; set exit_status $code; log_and_exit;" $signal
1679 verbose
"setting trap for $signal to $str" 1
1681 unset
signal str sig
1685 # Given a list of targets
, process
any iterative lists.
1687 proc process_target_variants
{ target_list
} {
1689 foreach x $target_list
{
1690 if {[regexp
"\\(" $x]} {
1691 regsub
{^.
*\
(([^
()]*)\
)$
} $x
{\
1} variant_list
1692 regsub
{\
([^
(]*$
} $x
"" x
1693 set list
[process_target_variants $x
]
1696 set result
[concat $result
[iterate_target_variants $x
[split $variant_list
","]]]
1698 } elseif
{[regexp
"\{" $x]} {
1699 regsub
"^.*\{(\[^\{\}\]*)\}$" $x {\1} variant_list
1700 regsub
"\{\[^\{\]*$" $x "" x
1701 set list
[process_target_variants $x
]
1703 foreach i
[split $variant_list
","] {
1708 lappend result $
name
1718 proc iterate_target_variants
{ target variants
} {
1719 return [iterate_target_variants_two $target $target $variants
]
1723 # Given a list of variants
, produce the list of all possible combinations.
1725 proc iterate_target_variants_two
{ orig_target target variants
} {
1727 if { [llength $variants
] == 0 } {
1728 return [list $target
]
1730 if { [llength $variants
] > 1 } {
1731 set result
[iterate_target_variants_two $orig_target $target
[lrange $variants
1 end
]]
1733 if { $target ne $orig_target
} {
1734 set result
[list $target
]
1739 if { [lindex $variants
0] ne
"" } {
1740 append target
"/" [lindex $variants 0]
1741 return [concat $result
[iterate_target_variants_two $orig_target $target
[lrange $variants
1 end
]]]
1743 return [concat $result $target
]
1748 setup_build_hook
[get_local_hostname
]
1750 if {[info exists host_board
]} {
1751 setup_host_hook $host_board
1753 set hb
[get_local_hostname
]
1760 # main test execution loop
1763 if {[info exists errorInfo
]} {
1768 # make sure we have only single path delimiters
1769 regsub
-all
{([^
/])//*} $srcdir
{\
1/} srcdir
1770 regsub
-all
{([^
/])//*} $objdir
{\
1/} objdir
1771 regsub
-all
{([^
/])//*} $testsuitedir
{\
1/} testsuitedir
1772 regsub
-all
{([^
/])//*} $testbuilddir
{\
1/} testbuilddir
1774 if {![info exists target_list
]} {
1775 # Make sure there is at least one target machine. It
's probably a Unix box,
1776 # but that's just a guess.
1777 set target_list
{ "unix" }
1779 verbose
"target list is $target_list"
1783 # Iterate through the list of targets.
1785 global current_target
1787 set target_list
[process_target_variants $target_list
]
1789 set target_count
[llength $target_list
]
1791 clone_output
"Schedule of variations:"
1792 foreach current_target $target_list
{
1793 clone_output
" $current_target"
1798 foreach current_target $target_list
{
1799 verbose
"target is $current_target"
1800 set current_target_name $current_target
1801 set tlist
[split $current_target
/]
1802 set current_target
[lindex $tlist
0]
1803 set board_variant_list
[lrange $tlist
1 end
]
1805 #
Set the counts
for this target to
0.
1807 clone_output
"Running target $current_target_name"
1809 setup_target_hook $current_target_name $current_target
1811 #
If multiple passes requested
, set them up. Otherwise prepare just one.
1812 # The format of `MULTIPASS
' is a list of elements containing
1813 # "{ name var1=value1 ... }" where `name' is a generic
name for the pass and
1814 # currently has no other meaning.
1818 if { [info exists MULTIPASS
] } {
1819 set multipass $MULTIPASS
1821 if { $multipass eq
"" } {
1822 set multipass
{ "" }
1825 #
If PASS is specified
, we want to run only the tests specified.
1826 # Its value should be a number or a list of numbers that specify
1827 # the passes that we want to run.
1828 if {[info exists PASS
]} {
1837 foreach multipass_elem $multipass
{
1838 set multipass_name
[lindex $multipass_elem
0]
1839 if {$p
== $multipass_name
} {
1840 lappend passes $multipass_elem
1845 set multipass $passes
1848 foreach pass $multipass
{
1850 # multipass_name is
set for `record_test
' to use (see framework.exp).
1851 if { [lindex $pass 0] ne "" } {
1852 set multipass_name [lindex $pass 0]
1853 clone_output "Running pass `$multipass_name' ...
"
1855 set multipass_name
""
1858 foreach varval
[lrange $pass
1 end
] {
1859 set tmp
[string first
"=" $varval]
1860 set var
[string range $varval
0 [expr
{$tmp
- 1}]]
1861 # Save previous value.
1862 if {[info exists $var
]} {
1863 lappend restore
"$var [list [eval concat \$$var]]"
1865 lappend restore $var
1867 # Handle
"CFLAGS=$CFLAGS foo".
1868 eval
set $var \
[string range
\"$varval
\" [expr
{$tmp
+ 1}] end\
]
1869 verbose
"$var is now [eval concat \$$var]"
1873 # look
for the top level testsuites.
if $tool doesn
't
1874 # exist and there are no subdirectories in $testsuitedir, then
1875 # we print a warning and default to srcdir.
1876 set test_top_dirs [lsort [getdirs -all $testsuitedir $tool*]]
1877 if { $test_top_dirs eq "" } {
1878 send_error "WARNING: could not find testsuite; trying $srcdir.\n"
1879 set test_top_dirs [list $srcdir]
1882 # DejaGNU's notion of test tree and test files is very
1884 # given $testsuitedir and $tool
, any subdirectory
(at
any
1885 # level deep
) with the
"$tool" prefix starts a test tree
1886 # given a test tree
, any *.exp file underneath
(at
any
1887 # level deep
) is a test file.
1889 #
For test tree layouts with $tool prefix
on
1890 # both a parent and a child directory
, we need to eliminate
1891 # the child directory entry from test_top_dirs list.
1892 # e.g. gdb.hp
/gdb.base
-hp
/ would result in two entries
1893 # in the list
: gdb.hp
, gdb.hp
/gdb.base
-hp.
1894 #
If the latter not eliminated
, test files under
1895 # gdb.hp
/gdb.base
-hp would be run twice
(since test files
1896 # are gathered from all sub
-directories underneath a
1899 # Since $tool may be g
++, etc. which could confuse
1900 # regexp
, we cannot
do the simpler test
:
1902 #
if [regexp
"$testsuitedir/.*$tool.*/.*$tool.*" $dir]
1904 # instead
, we rely
on the fact that test_top_dirs is
1905 # a sorted list of entries
, and
any entry that contains
1906 # the previous valid test top
dir entry in its own pathname
1909 set temp_top_dirs
[list
]
1911 foreach
dir $test_top_dirs
{
1912 if { $prev_dir eq
""
1913 ||
[string first $prev_dir
/ $
dir] == -1 } {
1914 # the first top
dir entry
, or an entry that
1915 # does not share the previous entry
's entire
1916 # pathname, record it as a valid top dir entry.
1918 lappend temp_top_dirs $dir
1922 set test_top_dirs $temp_top_dirs
1924 verbose "Top level testsuite dirs are $test_top_dirs" 2
1926 if {[array exists all_runtests]} {
1927 foreach x [array names all_runtests] {
1928 verbose "trying to glob $testsuitedir/$x" 2
1929 set s [glob -nocomplain $testsuitedir/$x]
1931 set testlist [concat $testlist $s]
1936 # If we have a list of tests, run all of them.
1938 if { $testlist ne "" } {
1939 foreach test_name $testlist {
1940 if { $ignoretests ne "" } {
1941 if { 0 <= [lsearch $ignoretests [file tail $test_name]]} {
1946 # set subdir to the tail of the dirname after $srcdir,
1947 # for the driver files that want it. XXX this is silly.
1948 # drivers should get a single var, not $srcdir/$subdir
1949 set subdir [relative_filename $srcdir \
1950 [file dirname $test_name]]
1952 # XXX not the right thing to do.
1953 set runtests [list [file tail $test_name] ""]
1959 # Go digging for tests.
1961 foreach dir $test_top_dirs {
1962 if { $dir ne $testsuitedir } {
1963 # Ignore this directory if is a directory to be
1965 if {[info exists ignoredirs] && $ignoredirs ne ""} {
1967 foreach directory $ignoredirs {
1968 if {[string match *$directory* $dir]} {
1978 # Run the test if dir_to_run was specified as a
1979 # value (for example in MULTIPASS) and the test
1980 # directory matches that directory.
1981 if {[info exists dir_to_run] && $dir_to_run ne ""} {
1982 # JYG: dir_to_run might be a space delimited list
1983 # of directories. Look for match on each item.
1985 foreach directory $dir_to_run {
1986 if {[string match *$directory* $dir]} {
1996 # Run the test if cmdline_dir_to_run was specified
1997 # by the user using --directory and the test
1998 # directory matches that directory
1999 if {[info exists cmdline_dir_to_run] \
2000 && $cmdline_dir_to_run ne ""} {
2001 # JYG: cmdline_dir_to_run might be a space delimited
2002 # list of directories. Look for match on each item.
2004 foreach directory $cmdline_dir_to_run {
2005 # Look for a directory that ends with the
2006 # provided --directory name.
2007 if {[string match $directory $dir]
2008 || [string match "*/$directory" $dir]} {
2018 foreach test_name [lsort [find $dir *.exp]] {
2019 if { $test_name eq "" } {
2022 # Ignore this one if asked to.
2023 if { $ignoretests ne "" } {
2024 if { 0 <= [lsearch $ignoretests [file tail $test_name]]} {
2029 # Get the path after the $srcdir so we know
2030 # the subdir we're in.
2031 set subdir
[relative_filename $srcdir \
2032 [file dirname $test_name
]]
2033 # Check to see
if the range of tests is limited
,
2034 #
set `runtests
' to a list of two elements: the script name
2035 # and any arguments ("" if none).
2036 if {[array exists all_runtests]} {
2037 verbose "searching for $test_name in [array names all_runtests]" 2
2038 if { 0 > [lsearch [array names all_runtests] [file tail $test_name]]} {
2039 if { 0 > [lsearch [array names all_runtests] $test_name] } {
2043 set runtests [list [file tail $test_name] $all_runtests([file tail $test_name])]
2045 set runtests [list [file tail $test_name] ""]
2053 # Restore the variables set by this pass.
2054 foreach varval $restore {
2055 if { [llength $varval] > 1 } {
2056 verbose "Restoring [lindex $varval 0] to [lindex $varval 1]" 4
2057 set [lindex $varval 0] [lindex $varval 1]
2059 verbose "Restoring [lindex $varval 0] to `unset'" 4
2060 unset
-- [lindex $varval
0]
2064 cleanup_target_hook $current_target
2065 if { $target_count
> 1 } {