Fix handling of lists given as command-line parameters
[dejagnu.git] / runtest.exp
blob84c7e28e117abff450e2aa9a8b9bbb1e618f0040
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"
25 exit 1
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
65 set reboot 0
66 set multipass "" ;# list of passes and var settings
67 set errno ""; ;#
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
101 # Collected errors
103 namespace eval ::dejagnu::error {
104 # list of { file message errorCode errorInfo } lists
105 variable list [list]
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)
122 set base_dir [pwd]
125 # These are set here instead of the init module so they can be overridden
126 # by command line options.
128 set all_flag 0
129 set binpath ""
130 set debug 0
131 set options ""
132 set outdir "."
133 set reboot 1
134 set tracelevel 0
135 set verbose 0
136 set log_dialog 0
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 } {
153 global verbose
154 set newline 1
155 set logfile 0
157 set i 0
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 "--" } {
161 incr i
162 break
163 } elseif { [lindex $args $i] eq "-n" } {
164 set newline 0
165 } elseif { [lindex $args $i] eq "-log" } {
166 set logfile 1
167 } elseif { [lindex $args $i] eq "-x" } {
168 set xml 1
169 } elseif { [string index [lindex $args $i] 0] eq "-" } {
170 clone_output "ERROR: verbose: illegal argument: [lindex $args $i]"
171 return
172 } else {
173 break
176 if { [llength $args] == $i } {
177 clone_output "ERROR: verbose: nothing to print"
178 return
182 set level 1
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).
191 if { $newline } {
192 send_user -- "$message\n"
193 } else {
194 send_user -- $message
196 } elseif { $logfile } {
197 if { $newline } {
198 send_log -- "$message\n"
199 } else {
200 send_log -- $message
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
212 global target_alias
213 global host_triplet
214 global board
216 if { $target_triplet eq $host_triplet } {
217 return $name
219 if { $target_triplet eq "native" } {
220 return $name
222 if {[board_info host exists no_transform_name]} {
223 return $name
225 if { $target_triplet eq "" } {
226 return $name
227 } else {
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
241 } else {
242 set tmp "[lindex $target_install 0]-$name"
245 verbose "Transforming $name to $tmp"
246 return $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
260 # the file exists.
261 # arg2 is optional, and it's what gets returned if
262 # the file doesn't exist.
264 proc findfile { args } {
265 # look for the file
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]
271 } else {
272 verbose "Found file, returning [lindex $args 0]"
273 return [lindex $args 0]
275 } else {
276 if { [llength $args] > 2 } {
277 verbose "Didn't find file [lindex $args 0], returning [lindex $args 2]"
278 return [lindex $args 2]
279 } else {
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
293 # and exit.
295 proc load_file { args } {
296 set i 0
297 set only_one 0
298 if { [lindex $args $i] eq "-1" } {
299 set only_one 1
300 incr i
302 if { [lindex $args $i] eq "--" } {
303 incr i
306 set found 0
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} {
312 set found 1
313 verbose "Found $file"
314 if { [catch "uplevel #0 source $file"] == 1 } {
315 send_error "ERROR: tcl error sourcing $file.\n"
316 global errorInfo
317 if {[info exists errorInfo]} {
318 send_error "$errorInfo\n"
320 exit 1
322 if { $only_one } {
323 break
327 return $found
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 } {
335 set found 0
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]} {
342 set found 1
343 set error ""
344 if { $type ne "library file" } {
345 send_user "Using $filename as $type.\n"
346 } else {
347 verbose "Loading $filename"
349 if {[catch "uplevel #0 source $filename" error] == 1} {
350 global errorInfo
351 send_error "ERROR: tcl error sourcing $type $filename.\n$error\n"
352 if {[info exists errorInfo]} {
353 send_error "$errorInfo\n"
355 exit 1
357 break
360 if { $found } {
361 break
364 return $found
368 # Give a usage statement.
370 proc usage { } {
371 global tool
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 "" } {
404 ${tool}_option_help
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 {
459 "--*" {
461 "-*" {
462 set option "-$option"
466 # split out the argument for options that take them
467 switch -glob -- $option {
468 "--*=*" {
469 regexp {^[^=]*=(.*)$} $option nil optarg
471 "--bu*" -
472 "--g*" -
473 "--ho*" -
474 "--ig*" -
475 "--loc*" -
476 "--m*" -
477 "--ob*" -
478 "--ou*" -
479 "--sr*" -
480 "--str*" -
481 "--ta*" -
482 "--di*" -
483 "--to*" {
484 incr i
485 set optarg [lindex $argv $i]
489 switch -glob -- $option {
490 "--V*" -
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"
495 exit 0
498 "--bu*" { # (--build) the build host configuration
499 set arg_build_triplet $optarg
500 ::dejagnu::command_line::save_cmd_var arg_build_triplet
501 continue
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
507 continue
510 "--host_bo*" {
511 set host_board $optarg
512 ::dejagnu::command_line::save_cmd_var host_board
513 continue
516 "--ho*" { # (--host) the host configuration
517 set arg_host_triplet $optarg
518 ::dejagnu::command_line::save_cmd_var arg_host_triplet
519 continue
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
525 continue
528 "--ob*" { # (--objdir) where the test case object code lives
529 set objdir $optarg
530 ::dejagnu::command_line::save_cmd_var objdir
531 continue
534 "--sr*" { # (--srcdir) where the testsuite source code lives
535 set srcdir $optarg
536 ::dejagnu::command_line::save_cmd_var srcdir
537 continue
540 "--target_bo*" {
541 set target_list $optarg
542 ::dejagnu::command_line::save_cmd_var target_list
543 continue
546 "--ta*" { # (--target) the target configuration
547 set arg_target_triplet $optarg
548 ::dejagnu::command_line::save_cmd_var arg_target_triplet
549 continue
552 "--tool_opt*" {
553 set TOOL_OPTIONS $optarg
554 ::dejagnu::command_line::save_cmd_var TOOL_OPTIONS
555 continue
558 "--tool_exec*" {
559 set TOOL_EXECUTABLE $optarg
560 ::dejagnu::command_line::save_cmd_var TOOL_EXECUTABLE
561 continue
564 "--to*" { # (--tool) specify tool name
565 set tool $optarg
566 set comm_line_tool $optarg
567 ::dejagnu::command_line::save_cmd_var tool
568 ::dejagnu::command_line::save_cmd_var comm_line_tool
569 continue
572 "--di*" {
573 set cmdline_dir_to_run $optarg
574 ::dejagnu::command_line::save_cmd_var cmdline_dir_to_run
575 continue
578 "--v" -
579 "--verb*" { # (--verbose) verbose output
580 incr verbose
581 continue
584 "[A-Z0-9_-.]*=*" { # process makefile style args like CC=gcc, etc...
585 if {[regexp "^(\[A-Z0-9_-\]+)=(.*)$" $option junk var val]} {
586 set $var $val
587 verbose "$var is now $val"
588 append makevars "set $var $val;" ;# FIXME: Used anywhere?
589 unset junk var val
590 } else {
591 send_error "Illegal variable specification:\n"
592 send_error "$option\n"
594 continue
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)
611 } else {
612 if {[info exists env(LOGNAME)]} {
613 set logname $env(LOGNAME)
614 } else {
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
619 unset tmp
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"
624 } else {
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]
645 return ""
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
658 global loaded_libs
660 if {[info exists loaded_libs($file)]} {
661 return
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"
675 exit 1
680 # Begin sourcing the config files.
681 # All are sourced in order.
683 # Search 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
700 # command line.
703 if { $objdir eq "." || $objdir eq $srcdir } {
704 set objdir $base_dir
705 } else {
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
743 } else {
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
750 } else {
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
779 set libdirs {}
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 ""}]} {
811 # find config.guess
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]"
817 break
821 # get the canonical triplet
822 if {![info exists config_guess]} {
823 send_error "ERROR: Couldn't find config.guess program.\n"
824 exit 1
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)\
831 exited on code\
832 [lindex $::errorCode 2].\n"
833 } else {
834 send_error "ERROR: Running config.guess with\
835 CONFIG_SHELL=$::env(CONFIG_SHELL)\
836 produced error:\n"
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\
844 SHELL=$::env(SHELL)\
845 exited on code\
846 [lindex $::errorCode 2].\n"
847 } else {
848 send_error "ERROR: Running config.guess with\
849 SHELL=$::env(SHELL)\
850 produced error:\n"
851 send_error " $::errorCode\n"
854 } else {
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"
859 } else {
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"
871 exit 1
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]} {
899 set hb ""
900 } else {
901 regsub "\\..*$" $hb "" hb
903 verbose "hostname=$hb" 3
904 return $hb
908 # We put these here so that they can be overridden later by site.exp or
909 # friends.
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 } {
916 global board
917 global host_board
919 if {[info exists host_board]} {
920 set hb $host_board
921 } else {
922 set hb [get_local_hostname]
925 set board $whole_name
927 global board_type
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"
934 exit 1
935 } else {
936 load_generic_config "unix"
940 if {[board_info $board exists generic_name]} {
941 load_tool_target_config [board_info $board generic_name]
944 unset board
945 unset board_type
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 } {
965 global tool
966 # Clean up the target board.
967 if { [info procs ${name}_exit] ne "" } {
968 ${name}_exit
970 # We also call the tool exit routine here.
971 if {[info exists tool]} {
972 if { [info procs ${tool}_exit] ne "" } {
973 ${tool}_exit
976 remote_close target
977 pop_target
980 proc setup_host_hook { name } {
981 global board
982 global board_info
983 global board_type
985 set board $name
986 set board_type "host"
988 load_board_description $name
989 unset board
990 unset board_type
991 push_host $name
992 if { [info procs ${name}_init] ne "" } {
993 ${name}_init $name
997 proc setup_build_hook { name } {
998 global board
999 global board_info
1000 global board_type
1002 set board $name
1003 set board_type "build"
1005 load_board_description $name
1006 unset board
1007 unset board_type
1008 push_build $name
1009 if { [info procs ${name}_init] ne "" } {
1010 ${name}_init $name
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"
1036 exit 1
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]} {
1047 set boards_dir ""
1051 # parse out the config parts of the triplet name
1054 # build values
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
1066 # host values
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
1078 # target values
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
1096 global loaded_libs
1098 if {[info exists loaded_libs(tool/$file)]} {
1099 return
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
1118 load_lib utils.exp
1119 load_lib framework.exp
1120 load_lib debugger.exp
1121 load_lib remote.exp
1122 load_lib target.exp
1123 load_lib targetdb.exp
1124 load_lib libgloss.exp
1126 # Initialize the test counters and reset them to 0.
1127 init_testcounts
1128 reset_vars
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 {
1150 "--*" {
1152 "-*" {
1153 set option "-$option"
1157 # split out the argument for options that take them
1158 switch -glob -- $option {
1159 "--*=*" {
1160 regexp {^[^=]*=(.*)$} $option nil optarg
1162 "--bu*" -
1163 "--g*" -
1164 "--ho*" -
1165 "--ig*" -
1166 "--loc*" -
1167 "--m*" -
1168 "--ob*" -
1169 "--ou*" -
1170 "--sr*" -
1171 "--str*" -
1172 "--ta*" -
1173 "--di*" -
1174 "--to*" {
1175 incr i
1176 set optarg [lindex $argv $i]
1180 switch -glob -- $option {
1181 "--v*" { # (--verbose) verbose output
1182 # Already parsed.
1183 continue
1186 "--g*" { # (--global_init) the global init file name
1187 # Already parsed (and no longer useful). The file has been loaded.
1188 continue
1191 "--loc*" { # (--local_init) the local init file name
1192 # Already parsed (and no longer useful). The file has been loaded.
1193 continue
1196 "--bu*" { # (--build) the build host configuration
1197 # Already parsed (and don't set again). Let $DEJAGNU rename it.
1198 continue
1201 "--ho*" { # (--host) the host configuration
1202 # Already parsed (and don't set again). Let $DEJAGNU rename it.
1203 continue
1206 "--target_bo*" {
1207 # Set it again, father knows best.
1208 set target_list $optarg
1209 continue
1212 "--ta*" { # (--target) the target configuration
1213 # Already parsed (and don't set again). Let $DEJAGNU rename it.
1214 continue
1217 "--a*" { # (--all) print all test output to screen
1218 set all_flag 1
1219 verbose "Print all test output to screen"
1220 continue
1223 "--di*" {
1224 # Already parsed (and don't set again). Let $DEJAGNU rename it.
1225 continue
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
1235 } else {
1236 exp_internal -f dbg.log 0
1238 verbose "Expect Debugging is ON"
1239 continue
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"
1246 continue
1249 "--m*" { # (--mail) mail the output
1250 set mailing_list $optarg
1251 set mail_logs 1
1252 verbose "Mail results to $mailing_list"
1253 continue
1256 "--r*" { # (--reboot) reboot the target
1257 set reboot 1
1258 verbose "Will reboot the target (if supported)"
1259 continue
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.
1265 set objdir $optarg
1266 verbose "Using test binaries in $objdir"
1267 continue
1270 "--ou*" { # (--outdir) where to put the output files
1271 set outdir $optarg
1272 verbose "Test output put in $outdir"
1273 continue
1276 "--log_dialog*" {
1277 incr log_dialog
1278 continue
1281 "*.exp" { # specify test names to run
1282 set all_runtests($option) ""
1283 verbose "Running only tests $option"
1284 continue
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"
1291 unset tmp
1292 continue
1295 "--ig*" { # (--ignore) specify test names to exclude
1296 set ignoretests $optarg
1297 verbose "Ignoring test $ignoretests"
1298 continue
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.
1305 set srcdir $optarg
1306 continue
1309 "--str*" { # (--strace) expect trace level
1310 set tracelevel $optarg
1311 strace $tracelevel
1312 verbose "Source Trace level is now $tracelevel"
1313 continue
1316 "--sta*" { # (--status) exit status flag
1317 # preserved for compatability, do nothing
1318 continue
1321 "--tool_opt*" {
1322 continue
1325 "--tool_exec*" {
1326 set TOOL_EXECUTABLE $optarg
1327 continue
1330 "--to*" { # (--tool) specify tool name
1331 set tool $optarg
1332 verbose "Testing $tool"
1333 continue
1336 "--x*" {
1337 set xml 1
1338 verbose "XML logging turned on"
1339 continue
1342 "--he*" { # (--help) help text
1343 usage
1344 exit 0
1347 "[A-Z0-9_-.]*=*" { # skip makefile style args like CC=gcc, etc... (processed in first pass)
1348 continue
1351 default {
1352 if {[info exists tool]} {
1353 if { [info procs ${tool}_option_proc] ne "" } {
1354 if {[${tool}_option_proc $option]} {
1355 continue
1359 send_error "\nIllegal Argument \"$option\"\n"
1360 send_error "try \"runtest --help\" for option list\n"
1361 exit 1
1367 # check for a few crucial variables
1369 if {![info exists tool]} {
1370 send_error "WARNING: No tool specified\n"
1371 set tool ""
1375 # initialize a few Tcl variables to something other than their default
1377 if { $verbose > 2 || $log_dialog } {
1378 log_user 1
1379 } else {
1380 log_user 0
1383 set timeout 10
1388 # open log files
1390 open_logs
1392 # print the config info
1393 clone_output "Test run by $logname on [timestamp -format %c]"
1394 if {[is3way]} {
1395 clone_output "Target is $target_triplet"
1396 clone_output "Host is $host_triplet"
1397 clone_output "Build is $build_triplet"
1398 } else {
1399 if {[isnative]} {
1400 clone_output "Native configuration is $target_triplet"
1401 } else {
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 } {
1415 global libdir
1416 global board
1417 global board_info
1418 global boards_dir
1419 global board_type
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"
1429 } else {
1430 set 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]
1436 return $result
1440 # Load the tool-specific target description.
1442 proc load_config { args } {
1443 global testsuitedir
1445 set found 0
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
1463 # trapping.
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"
1477 exit 1
1483 # Find the file that describes the machine specified by board_name.
1486 proc load_board_description { board_name args } {
1487 global libdir
1488 global board
1489 global board_info
1490 global boards_dir
1491 global board_type
1493 set dejagnu ""
1495 if { [llength $args] > 0 } {
1496 set whole_name [lindex $args 0]
1497 } else {
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
1504 set board_set 1
1505 } else {
1506 set board_set 0
1509 set dirlist {}
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"
1524 } else {
1525 set 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 } {
1541 unset board
1544 return $found
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 } {
1553 global libdir
1554 global board
1555 global board_info
1556 global board_type
1558 set board_set 0
1559 set board_info($board_name,name) $board_name
1560 if {![info exists board]} {
1561 set board $board_name
1562 set board_set 1
1564 if {[info exists board_type]} {
1565 set type "for $board_type"
1566 } else {
1567 set 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 } {
1583 unset board
1586 return $found
1590 # Source the testcase in TEST_FILE_NAME.
1593 proc runtest { test_file_name } {
1594 global prms_id
1595 global bug_id
1596 global test_result
1597 global errcnt warncnt
1598 global errorCode
1599 global errorInfo
1600 global tool
1601 global testdir
1603 clone_output "Running $test_file_name ..."
1604 set prms_id 0
1605 set bug_id 0
1606 set errcnt 0
1607 set warncnt 0
1608 set test_result ""
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 } {
1628 set exit_status 2
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
1639 } else {
1640 lappend new_error [list]
1642 if {[info exists errorInfo]} {
1643 clone_output "ERROR: $errorInfo"
1644 lappend new_error $errorInfo
1645 unset errorInfo
1646 } else {
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 "" } {
1655 ${tool}_finish
1658 set timeend [timestamp]
1659 set timediff [expr {$timeend - $timestart}]
1660 verbose -log "testcase $test_file_name completed in $timediff seconds" 4
1661 } else {
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.
1671 if {![exp_debug]} {
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 } {
1688 set result {}
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]
1694 set result {}
1695 foreach x $list {
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]
1702 foreach x $list {
1703 foreach i [split $variant_list ","] {
1704 set name $x
1705 if { $i ne "" } {
1706 append name "/" $i
1708 lappend result $name
1711 } else {
1712 lappend result $x
1715 return $result
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]
1729 } else {
1730 if { [llength $variants] > 1 } {
1731 set result [iterate_target_variants_two $orig_target $target [lrange $variants 1 end]]
1732 } else {
1733 if { $target ne $orig_target } {
1734 set result [list $target]
1735 } else {
1736 set result {}
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]]]
1742 } else {
1743 return [concat $result $target]
1748 setup_build_hook [get_local_hostname]
1750 if {[info exists host_board]} {
1751 setup_host_hook $host_board
1752 } else {
1753 set hb [get_local_hostname]
1754 if { $hb ne "" } {
1755 setup_host_hook $hb
1760 # main test execution loop
1763 if {[info exists errorInfo]} {
1764 unset 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" }
1778 } else {
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"
1795 clone_output ""
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.
1806 reset_vars
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.
1816 global env
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]} {
1829 set pass $PASS
1830 } else {
1831 set pass ""
1834 if {$pass ne ""} {
1835 set passes [list]
1836 foreach p $pass {
1837 foreach multipass_elem $multipass {
1838 set multipass_name [lindex $multipass_elem 0]
1839 if {$p == $multipass_name} {
1840 lappend passes $multipass_elem
1841 break
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' ..."
1854 } else {
1855 set multipass_name ""
1857 set restore ""
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]]"
1864 } else {
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]"
1870 unset tmp 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]
1880 } else {
1881 # JYG:
1882 # DejaGNU's notion of test tree and test files is very
1883 # general:
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
1897 # directory).
1899 # Since $tool may be g++, etc. which could confuse
1900 # regexp, we cannot do the simpler test:
1901 # ...
1902 # if [regexp "$testsuitedir/.*$tool.*/.*$tool.*" $dir]
1903 # ...
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
1907 # must be excluded.
1909 set temp_top_dirs [list]
1910 set prev_dir ""
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
1919 set prev_dir $dir
1922 set test_top_dirs $temp_top_dirs
1924 verbose "Top level testsuite dirs are $test_top_dirs" 2
1925 set testlist ""
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]
1930 if { $s ne "" } {
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]]} {
1942 continue
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] ""]
1955 runtest $test_name
1957 } else {
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
1964 # ignored.
1965 if {[info exists ignoredirs] && $ignoredirs ne ""} {
1966 set found 0
1967 foreach directory $ignoredirs {
1968 if {[string match *$directory* $dir]} {
1969 set found 1
1970 break
1973 if { $found } {
1974 continue
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.
1984 set found 0
1985 foreach directory $dir_to_run {
1986 if {[string match *$directory* $dir]} {
1987 set found 1
1988 break
1991 if {!$found} {
1992 continue
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.
2003 set found 0
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]} {
2009 set found 1
2010 break
2013 if {!$found} {
2014 continue
2018 foreach test_name [lsort [find $dir *.exp]] {
2019 if { $test_name eq "" } {
2020 continue
2022 # Ignore this one if asked to.
2023 if { $ignoretests ne "" } {
2024 if { 0 <= [lsearch $ignoretests [file tail $test_name]]} {
2025 continue
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] } {
2040 continue
2043 set runtests [list [file tail $test_name] $all_runtests([file tail $test_name])]
2044 } else {
2045 set runtests [list [file tail $test_name] ""]
2047 runtest $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]
2058 } else {
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 } {
2066 log_summary
2070 log_and_exit