toolchain/dejagnu/runtest.exp

   1 # Test Framework Driver
   2 # Copyright (C) 1992 - 2002, 2003 Free Software Foundation, Inc.
   3
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17
  18 # Please email any bugs, comments, and/or additions to this file to:
  19 # bug-dejagnu@gnu.org
  20
  21 # This file was written by Rob Savoye. (rob@welcomehome.org)
  22
  23 set frame_version       1.4.4
  24 if ![info exists argv0] {
  25     send_error "Must use a version of Expect greater than 5.0\n"
  26     exit 1
  27 }
  28
  29 #
  30 # trap some signals so we know whats happening. These definitions are only
  31 # temporary until we read in the library stuff
  32 #
  33 trap { send_user "\nterminated\n";             exit 1 } SIGTERM
  34 trap { send_user "\ninterrupted by user\n";    exit 1 } SIGINT
  35 trap { send_user "\nsigquit\n";                exit 1 } SIGQUIT
  36
  37 #
  38 # Initialize a few global variables used by all tests.
  39 # `reset_vars' resets several of these, we define them here to document their
  40 # existence.  In fact, it would be nice if all globals used by some interface
  41 # of dejagnu proper were documented here.
  42 #
  43 # Keep these all lowercase.  Interface variables used by the various
  44 # testsuites (eg: the gcc testsuite) should be in all capitals
  45 # (eg: TORTURE_OPTIONS).
  46 #
  47 set mail_logs   0               ;# flag for mailing of summary and diff logs
  48 set psum_file   "latest"        ;# file name of previous summary to diff against
  49
  50 set exit_status 0               ;# exit code returned by this program
  51
  52 set xfail_flag  0               ;# indicates that a failure is expected
  53 set xfail_prms  0               ;# GNATS prms id number for this expected failure
  54 set kfail_flag  0               ;# indicates that it is a known failure
  55 set kfail_prms  0               ;# bug id for the description of the known failure
  56 set sum_file    ""              ;# name of the file that contains the summary log
  57 set base_dir    ""              ;# the current working directory
  58 set xml_file    ""              ;# name of the xml output if requested
  59 set xml         0               ;# flag for requesting xml
  60 set logname     ""              ;# the users login name
  61 set prms_id     0               ;# GNATS prms id number
  62 set bug_id      0               ;# optional bug id number
  63 set dir         ""              ;# temp variable for directory names
  64 set srcdir      "."             ;# source directory containing the test suite
  65 set ignoretests ""              ;# list of tests to not execute
  66 set objdir      "."             ;# directory where test case binaries live
  67 set reboot      0
  68 set configfile  site.exp        ;# (local to this file)
  69 set multipass   ""              ;# list of passes and var settings
  70 set errno       "";             ;#
  71 set exit_error  0               ;# Toggle for whether to set the exit status
  72 ;# on Tcl bugs in test case drivers.
  73 #
  74 # These describe the host and target environments.
  75 #
  76 set build_triplet  ""           ;# type of architecture to run tests on
  77 set build_os       ""           ;# type of os the tests are running on
  78 set build_vendor   ""           ;# vendor name of the OS or workstation the test are running on
  79 set build_cpu      ""           ;# type of the cpu tests are running on
  80 set host_triplet   ""           ;# type of architecture to run tests on, sometimes remotely
  81 set host_os        ""           ;# type of os the tests are running on
  82 set host_vendor    ""           ;# vendor name of the OS or workstation the test are running on
  83 set host_cpu       ""           ;# type of the cpu tests are running on
  84 set target_triplet ""           ;# type of architecture to run tests on, final remote
  85 set target_os      ""           ;# type of os the tests are running on
  86 set target_vendor  ""           ;# vendor name of the OS or workstation the test are running on
  87 set target_cpu     ""           ;# type of the cpu tests are running on
  88 set target_alias   ""           ;# standard abbreviation of target
  89 set compiler_flags ""           ;# the flags used by the compiler
  90
  91 #
  92 # some convenience abbreviations
  93 #
  94 if ![info exists hex] {
  95     set hex "0x\[0-9A-Fa-f\]+"
  96 }
  97 if ![info exists decimal] {
  98     set decimal "\[0-9\]+"
  99 }
 100
 101 #
 102 # set the base dir (current working directory)
 103 #
 104 set base_dir [pwd]
 105
 106 #
 107 # These are tested in case they are not initialized in $configfile. They are
 108 # tested here instead of the init module so they can be overridden by command
 109 # line options.
 110 #
 111 if ![info exists all_flag] {
 112     set all_flag 0
 113 }
 114 if ![info exists binpath] {
 115     set binpath ""
 116 }
 117 if ![info exists debug] {
 118     set debug 0
 119 }
 120 if ![info exists options] {
 121     set options ""
 122 }
 123 if ![info exists outdir] {
 124     set outdir "."
 125 }
 126 if ![info exists reboot] {
 127     set reboot 1
 128 }
 129 if ![info exists tracelevel] {
 130     set tracelevel 0
 131 }
 132 if ![info exists verbose] {
 133     set verbose 0
 134 }
 135
 136 #
 137 # verbose [-n] [-log] [--] message [level]
 138 #
 139 # Print MESSAGE if the verbose level is >= LEVEL.
 140 # The default value of LEVEL is 1.
 141 # "-n" says to not print a trailing newline.
 142 # "-log" says to add the text to the log file even if it won't be printed.
 143 # Note that the apparent behaviour of `send_user' dictates that if the message
 144 # is printed it is also added to the log file.
 145 # Use "--" if MESSAGE begins with "-".
 146 #
 147 # This is defined here rather than in framework.exp so we can use it
 148 # while still loading in the support files.
 149 #
 150 proc verbose { args } {
 151     global verbose
 152     set newline 1
 153     set logfile 0
 154
 155     set i 0
 156     if { [string index [lindex $args 0] 0] == "-" } {
 157         for { set i 0 } { $i < [llength $args] } { incr i } {
 158             if { [lindex $args $i] == "--" } {
 159                 incr i
 160                 break
 161             } elseif { [lindex $args $i] == "-n" } {
 162                 set newline 0
 163             } elseif { [lindex $args $i] == "-log" } {
 164                 set logfile 1
 165             } elseif { [lindex $args $i] == "-x" } {
 166                 set xml 1
 167             } elseif { [string index [lindex $args $i] 0] == "-" } {
 168                 clone_output "ERROR: verbose: illegal argument: [lindex $args $i]"
 169                 return
 170             } else {
 171                 break
 172             }
 173         }
 174         if { [llength $args] == $i } {
 175             clone_output "ERROR: verbose: nothing to print"
 176             return
 177         }
 178     }
 179
 180     set level 1
 181     if { [llength $args] > $i + 1 } {
 182         set level [lindex $args [expr $i+1]]
 183     }
 184     set message [lindex $args $i]
 185
 186     if { $verbose >= $level } {
 187         # There is no need for the "--" argument here, but play it safe.
 188         # We assume send_user also sends the text to the log file (which
 189         # appears to be the case though the docs aren't clear on this).
 190         if { $newline } {
 191             send_user -- "$message\n"
 192         } else {
 193             send_user -- "$message"
 194         }
 195     } elseif { $logfile } {
 196         if { $newline } {
 197             send_log "$message\n"
 198         } else {
 199             send_log "$message"
 200         }
 201     }
 202 }
 203
 204 #
 205 # Transform a tool name to get the installed name.
 206 # target_triplet is the canonical target name.  target_alias is the
 207 # target name used when configure was run.
 208 #
 209 proc transform { name } {
 210     global target_triplet
 211     global target_alias
 212     global host_triplet
 213     global board
 214
 215     if [string match $target_triplet $host_triplet] {
 216         return $name
 217     }
 218     if [string match "native" $target_triplet] {
 219         return $name
 220     }
 221     if [board_info host exists no_transform_name] {
 222         return $name
 223     }
 224     if [string match "" $target_triplet] {
 225         return $name
 226     } else {
 227         if [info exists board] {
 228             if [board_info $board exists target_install] {
 229                 set target_install [board_info $board target_install]
 230             }
 231         }
 232         if [target_info exists target_install] {
 233             set target_install [target_info target_install]
 234         }
 235         if [info exists target_alias] {
 236             set tmp ${target_alias}-${name}
 237         } elseif [info exists target_install] {
 238             if { [lsearch -exact $target_install $target_alias] >= 0 } {
 239                 set tmp ${target_alias}-${name}
 240             } else {
 241                 set tmp "[lindex $target_install 0]-${name}"
 242             }
 243         }
 244         verbose "Transforming $name to $tmp"
 245         return $tmp
 246     }
 247 }
 248
 249 #
 250 # findfile arg0 [arg1] [arg2]
 251 #
 252 # Find a file and see if it exists. If you only care about the false
 253 # condition, then you'll need to pass a null "" for arg1.
 254 #       arg0 is the filename to look for. If the only arg,
 255 #            then that's what gets returned. If this is the
 256 #            only arg, then if it exists, arg0 gets returned.
 257 #            if it doesn't exist, return only the prog name.
 258 #       arg1 is optional, and it's what gets returned if
 259 #            the file exists.
 260 #       arg2 is optional, and it's what gets returned if
 261 #            the file doesn't exist.
 262 #
 263 proc findfile { args } {
 264     # look for the file
 265     verbose "Seeing if [lindex $args 0] exists." 2
 266     if [file exists [lindex $args 0]] {
 267         if { [llength $args] > 1 } {
 268             verbose "Found file, returning [lindex $args 1]"
 269             return [lindex $args 1]
 270         } else {
 271             verbose "Found file, returning [lindex $args 0]"
 272             return [lindex $args 0]
 273         }
 274     } else {
 275         if { [llength $args] > 2 } {
 276             verbose "Didn't find file [lindex $args 0], returning [lindex $args 2]"
 277             return [lindex $args 2]
 278         } else {
 279             verbose "Didn't find file, returning [file tail [lindex $args 0]]"
 280             return [transform [file tail [lindex $args 0]]]
 281         }
 282     }
 283 }
 284
 285 #
 286 # load_file [-1] [--] file1 [ file2 ... ]
 287 #
 288 # Utility to source a file.  All are sourced in order unless the flag "-1"
 289 # is given in which case we stop after finding the first one.
 290 # The result is 1 if a file was found, 0 if not.
 291 # If a tcl error occurs while sourcing a file, we print an error message
 292 # and exit.
 293 #
 294 # ??? Perhaps add an optional argument of some descriptive text to add to
 295 # verbose and error messages (eg: -t "library file" ?).
 296 #
 297 proc load_file { args } {
 298     set i 0
 299     set only_one 0
 300     if { [lindex $args $i] == "-1" } {
 301         set only_one 1
 302         incr i
 303     }
 304     if { [lindex $args $i] == "--" } {
 305         incr i
 306     }
 307
 308     set found 0
 309     foreach file [lrange $args $i end] {
 310         verbose "Looking for $file" 2
 311         # In Tcl7.5a2, "file exists" can fail if the filename looks
 312         # like ~/FILE and the environment variable HOME does not
 313         # exist.
 314         if {! [catch {file exists $file} result] && $result} {
 315             set found 1
 316             verbose "Found $file"
 317             if { [catch "uplevel #0 source $file"] == 1 } {
 318                 send_error "ERROR: tcl error sourcing $file.\n"
 319                 global errorInfo
 320                 if [info exists errorInfo] {
 321                     send_error "$errorInfo\n"
 322                 }
 323                 exit 1
 324             }
 325             if $only_one {
 326                 break
 327             }
 328         }
 329     }
 330     return $found
 331 }
 332
 333 #
 334 # search_and_load_file -- search DIRLIST looking for FILELIST.
 335 # TYPE is used when displaying error and progress messages.
 336 #
 337 proc search_and_load_file { type filelist dirlist } {
 338     set found 0
 339
 340     foreach dir $dirlist {
 341         foreach initfile $filelist {
 342             verbose "Looking for $type ${dir}/${initfile}" 2
 343             if [file exists ${dir}/${initfile}] {
 344                 set found 1
 345                 set error ""
 346                 if { ${type} != "library file" } {
 347                     send_user "Using ${dir}/${initfile} as ${type}.\n"
 348                 } else {
 349                     verbose "Loading ${dir}/${initfile}"
 350                 }
 351                 if [catch "uplevel #0 source ${dir}/${initfile}" error]==1 {
 352                     global errorInfo
 353                     send_error "ERROR: tcl error sourcing ${type} ${dir}/${initfile}.\n${error}\n"
 354                     if [info exists errorInfo] {
 355                         send_error "$errorInfo\n"
 356                     }
 357                     exit 1
 358                 }
 359                 break
 360             }
 361         }
 362         if $found {
 363             break
 364         }
 365     }
 366     return $found
 367 }
 368
 369 #
 370 # Give a usage statement.
 371 #
 372 proc usage { } {
 373     global tool
 374
 375     send_user "USAGE: runtest \[options...\]\n"
 376     send_user "\t--all (-a)\t\tPrint all test output to screen\n"
 377     send_user "\t--build \[string\]\tThe canonical config name of the build machine\n"
 378     send_user "\t--host \[string\]\t\tThe canonical config name of the host machine\n"
 379     send_user "\t--host_board \[name\]\tThe host board to use\n"
 380     send_user "\t--target \[string\]\tThe canonical config name of the target board\n"
 381     send_user "\t--status (-sta)\t\tSet the exit status to fail on Tcl errors\n"
 382     send_user "\t--debug (-de)\t\tSet expect debugging ON\n"
 383     send_user "\t--help (-he)\t\tPrint help text\n"
 384     send_user "\t--mail \[name(s)\]\tWhom to mail the results to\n"
 385     send_user "\t--ignore \[name(s)\]\tThe names of specific tests to ignore\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 \[name\]\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--strace \[number\]\tSet expect tracing ON\n"
 391     send_user "\t--target_board \[name(s)\] The list of target boards to run tests on\n"
 392     send_user "\t--tool\[name(s)\]\t\tRun tests on these tools\n"
 393     send_user "\t--tool_exec \[name\]\tThe path to the tool executable to test\n"
 394     send_user "\t--tool_opts \[options\]\tA list of additional options to pass to the tool\n"
 395     send_user "\t--directory (-di) name\tRun only the tests in directory 'name'\n"
 396     send_user "\t--verbose (-v)\t\tEmit verbose output\n"
 397     send_user "\t--version (-V)\t\tEmit all version numbers\n"
 398     send_user "\t--xml (-x)\t\tTurn on XML output generation\n"
 399     send_user "\t--D\[0-1\]\t\tTcl debugger\n"
 400     send_user "\tscript.exp\[=arg(s)\]\tRun these tests only\n"
 401     if { [info exists tool] } {
 402         if { [info proc ${tool}_option_help] != "" } {
 403             ${tool}_option_help
 404         }
 405     }
 406 }
 407
 408 #
 409 # Parse the arguments the first time looking for these.  We will ultimately
 410 # parse them twice.  Things are complicated because:
 411 # - we want to parse --verbose early on
 412 # - we don't want config files to override command line arguments
 413 #   (eg: $base_dir/$configfile vs --host/--target)
 414 # - we need some command line arguments before we can process some config files
 415 #   (eg: --objdir before $objdir/$configfile, --host/--target before $DEJAGNU)
 416 # The use of `arg_host_triplet' and `arg_target_triplet' lets us avoid parsing
 417 # the arguments three times.
 418 #
 419
 420 set arg_host_triplet ""
 421 set arg_target_triplet ""
 422 set arg_build_triplet ""
 423 set argc [ llength $argv ]
 424 for { set i 0 } { $i < $argc } { incr i } {
 425     set option [lindex $argv $i]
 426
 427     # make all options have two hyphens
 428     switch -glob -- $option {
 429         "--*" {
 430         }
 431         "-*" {
 432             set option "-$option"
 433         }
 434     }
 435
 436     # split out the argument for options that take them
 437     switch -glob -- $option {
 438         "--*=*" {
 439             regexp {^[^=]*=(.*)$} $option nil optarg
 440         }
 441         "--bu*" -
 442         "--ho*" -
 443         "--ig*"  -
 444         "--m*"  -
 445         "--n*"  -
 446         "--ob*" -
 447         "--ou*" -
 448         "--sr*" -
 449         "--str*" -
 450         "--ta*" -
 451         "--di*" -
 452         "--to*" {
 453             incr i
 454             set optarg [lindex $argv $i]
 455         }
 456     }
 457
 458     switch -glob -- $option {
 459         "--bu*" {                       # (--build) the build host configuration
 460             set arg_build_triplet $optarg
 461             continue
 462         }
 463
 464         "--host_bo*" {
 465             set host_board $optarg
 466             continue
 467         }
 468
 469         "--ho*" {                       # (--host) the host configuration
 470             set arg_host_triplet $optarg
 471             continue
 472         }
 473
 474         "--ob*" {                       # (--objdir) where the test case object code lives
 475             set objdir $optarg
 476             continue
 477         }
 478
 479         "--sr*" {                       # (--srcdir) where the testsuite source code lives
 480             set srcdir $optarg
 481             continue
 482         }
 483
 484         "--target_bo*" {
 485             set target_list $optarg
 486             continue
 487         }
 488
 489         "--ta*" {                       # (--target) the target configuration
 490             set arg_target_triplet $optarg
 491             continue
 492         }
 493
 494         "--tool_opt*" {
 495             set TOOL_OPTIONS $optarg
 496             continue
 497         }
 498
 499         "--tool_exec*" {
 500             set TOOL_EXECUTABLE $optarg
 501             continue
 502         }
 503
 504         "--tool_ro*" {
 505             set tool_root_dir $optarg
 506             continue
 507         }
 508
 509         "--to*" {                       # (--tool) specify tool name
 510             set tool $optarg
 511             set comm_line_tool $optarg
 512             continue
 513         }
 514
 515         "--di*" {
 516             set cmdline_dir_to_run $optarg
 517             continue
 518         }
 519
 520         "--v" -
 521         "--verb*" {                     # (--verbose) verbose output
 522             incr verbose
 523             continue
 524         }
 525
 526         "[A-Z0-9_-.]*=*" { # process makefile style args like CC=gcc, etc...
 527             if [regexp "^(\[A-Z0-9_-\]+)=(.*)$" $option junk var val] {
 528                 set $var $val
 529                 verbose "$var is now $val"
 530                 append makevars "set $var $val;" ;# FIXME: Used anywhere?
 531                 unset junk var val
 532             } else {
 533                 send_error "Illegal variable specification:\n"
 534                 send_error "$option\n"
 535             }
 536             continue
 537         }
 538
 539     }
 540 }
 541 verbose "Verbose level is $verbose"
 542
 543 #
 544 # get the users login name
 545 #
 546 if [string match "" $logname] {
 547     if [info exists env(USER)] {
 548         set logname $env(USER)
 549     } else {
 550         if [info exists env(LOGNAME)] {
 551             set logname $env(LOGNAME)
 552         } else {
 553             # try getting it with whoami
 554             catch "set logname [exec whoami]" tmp
 555             if [string match "*couldn't find*to execute*" $tmp] {
 556                 # try getting it with who am i
 557                 unset tmp
 558                 catch "set logname [exec who am i]" tmp
 559                 if [string match "*Command not found*" $tmp] {
 560                     send_user "ERROR: couldn't get the users login name\n"
 561                     set logname "Unknown"
 562                 } else {
 563                     set logname [lindex [split $logname " !"] 1]
 564                 }
 565             }
 566         }
 567     }
 568 }
 569
 570 #
 571 # lookfor_file -- try to find a file by searching up multiple directory levels
 572 #
 573 proc lookfor_file { dir name } {
 574     foreach x ".. ../.. ../../.. ../../../.." {
 575         verbose "$dir/$name" 2
 576         if [file exists $dir/$name] {
 577             return $dir/$name
 578         }
 579         set dir [remote_file build dirname $dir]
 580     }
 581     return ""
 582 }
 583
 584 #
 585 # load_lib -- load a library by sourcing it
 586 #
 587 # If there a multiple files with the same name, stop after the first one found.
 588 # The order is first look in the install dir, then in a parallel dir in the
 589 # source tree, (up one or two levels), then in the current dir.
 590 #
 591 proc load_lib { file } {
 592     global verbose libdir srcdir base_dir execpath tool
 593     global loaded_libs
 594
 595     if [info exists loaded_libs($file)] {
 596         return
 597     }
 598
 599     set loaded_libs($file) ""
 600
 601     if { [search_and_load_file "library file" $file [list ../lib $libdir $libdir/lib [file dirname [file dirname $srcdir]]/dejagnu/lib $srcdir/lib $execpath/lib . [file dirname [file dirname [file dirname $srcdir]]]/dejagnu/lib]] == 0 } {
 602         send_error "ERROR: Couldn't find library file $file.\n"
 603         exit 1
 604     }
 605 }
 606
 607 verbose "Login name is $logname"
 608
 609 #
 610 # Begin sourcing the config files.
 611 # All are sourced in order.
 612 #
 613 # Search order:
 614 #       $HOME/.dejagnurc -> $base_dir/$configfile -> $objdir/$configfile
 615 #       -> installed -> $DEJAGNU
 616 #
 617 # ??? It might be nice to do $HOME last as it would allow it to be the
 618 # ultimate override.  Though at present there is still $DEJAGNU.
 619 #
 620 # For the normal case, we rely on $base_dir/$configfile to set
 621 # host_triplet and target_triplet.
 622 #
 623
 624 load_file ~/.dejagnurc $base_dir/$configfile
 625
 626 #
 627 # If objdir didn't get set in $base_dir/$configfile, set it to $base_dir.
 628 # Make sure we source $objdir/$configfile in case $base_dir/$configfile doesn't
 629 # exist and objdir was given on the command line.
 630 #
 631
 632 if [expr [string match "." $objdir] || [string match $srcdir $objdir]] {
 633     set objdir $base_dir
 634 } else {
 635     load_file $objdir/$configfile
 636 }
 637
 638 # Well, this just demonstrates the real problem...
 639 if ![info exists tool_root_dir] {
 640     set tool_root_dir [file dirname $objdir]
 641     if [file exists "$tool_root_dir/testsuite"] {
 642         set tool_root_dir [file dirname $tool_root_dir]
 643     }
 644 }
 645
 646 verbose "Using test sources in $srcdir"
 647 verbose "Using test binaries in $objdir"
 648 verbose "Tool root directory is $tool_root_dir"
 649
 650 set execpath [file dirname $argv0]
 651 set libdir   [file dirname $execpath]/dejagnu
 652 if [info exists env(DEJAGNULIBS)] {
 653     set libdir $env(DEJAGNULIBS)
 654 }
 655
 656 verbose "Using $libdir to find libraries"
 657
 658 #
 659 # If the host or target was given on the command line, override the above
 660 # config files.  We allow $DEJAGNU to massage them though in case it would
 661 # ever want to do such a thing.
 662 #
 663 if { $arg_host_triplet != "" } {
 664     set host_triplet $arg_host_triplet
 665 }
 666 if { $arg_build_triplet != "" } {
 667     set build_triplet $arg_build_triplet
 668 }
 669
 670 # if we only specify --host, then that must be the build machne too, and we're
 671 # stuck using the old functionality of a simple cross test
 672 if [expr { $build_triplet == ""  &&  $host_triplet != "" } ] {
 673     set build_triplet $host_triplet
 674 }
 675 # if we only specify --build, then we'll use that as the host too
 676 if [expr { $build_triplet != "" && $host_triplet == "" } ] {
 677     set host_triplet $build_triplet
 678 }
 679 unset arg_host_triplet arg_build_triplet
 680
 681 #
 682 # If the build machine type hasn't been specified by now, use config.guess.
 683 #
 684
 685 if [expr  { $build_triplet == ""  &&  $host_triplet == ""} ] {
 686     # find config.guess
 687     foreach dir "$libdir $libdir/libexec $libdir/.. $execpath $srcdir $srcdir/.. $srcdir/../.." {
 688         verbose "Looking for ${dir}/config.guess" 2
 689         if [file exists ${dir}/config.guess] {
 690             set config_guess ${dir}/config.guess
 691             verbose "Found ${dir}/config.guess"
 692             break
 693         }
 694     }
 695
 696     # get the canonical config name
 697     if ![info exists config_guess] {
 698         send_error "ERROR: Couldn't find config.guess program.\n"
 699         exit 1
 700     }
 701     catch "exec $config_guess" build_triplet
 702     case $build_triplet in {
 703         { "No uname command or uname output not recognized" "Unable to guess system type" } {
 704             verbose "WARNING: Uname output not recognized"
 705             set build_triplet unknown
 706         }
 707     }
 708     verbose "Assuming build host is $build_triplet"
 709     if { $host_triplet == "" } {
 710         set host_triplet $build_triplet
 711     }
 712
 713 }
 714
 715 #
 716 # Figure out the target. If the target hasn't been specified, then we have to
 717 # assume we are native.
 718 #
 719 if { $arg_target_triplet != "" } {
 720     set target_triplet $arg_target_triplet
 721 } elseif { $target_triplet == "" } {
 722     set target_triplet $build_triplet
 723     verbose "Assuming native target is $target_triplet" 2
 724 }
 725 unset arg_target_triplet
 726 #
 727 # Default target_alias to target_triplet.
 728 #
 729 if ![info exists target_alias] {
 730     set target_alias $target_triplet
 731 }
 732
 733 proc get_local_hostname { } {
 734     if [catch "info hostname" hb] {
 735         set hb ""
 736     } else {
 737         regsub "\\..*$" $hb "" hb
 738     }
 739     verbose "hostname=$hb" 3
 740     return $hb
 741 }
 742
 743 #
 744 # We put these here so that they can be overridden later by site.exp or
 745 # friends.
 746 #
 747 # Set up the target as machine NAME. We also load base-config.exp as a
 748 # default configuration. The config files are sourced with the global
 749 # variable $board set to the name of the current target being defined.
 750 #
 751 proc setup_target_hook { whole_name name } {
 752     global board
 753     global host_board
 754
 755     if [info exists host_board] {
 756         set hb $host_board
 757     } else {
 758         set hb [get_local_hostname]
 759     }
 760
 761     set board $whole_name
 762
 763     global board_type
 764     set board_type "target"
 765
 766     load_config base-config.exp
 767     if ![load_board_description ${name} ${whole_name} ${hb}] {
 768         if { $name != "unix" } {
 769             perror "couldn't load description file for ${name}"
 770             exit 1
 771         } else {
 772             load_generic_config "unix"
 773         }
 774     }
 775
 776     if [board_info $board exists generic_name] {
 777         load_tool_target_config [board_info $board generic_name]
 778     }
 779
 780     unset board
 781     unset board_type
 782
 783     push_target $whole_name
 784
 785     if { [info procs ${whole_name}_init] != "" } {
 786         ${whole_name}_init $whole_name
 787     }
 788
 789     if { ![isnative] && ![is_remote target] } {
 790         global env build_triplet target_triplet
 791         if { (![info exists env(DEJAGNU)]) && ($build_triplet != $target_triplet) } {
 792             warning "Assuming target board is the local machine (which is probably wrong).\nYou may need to set your DEJAGNU environment variable."
 793         }
 794     }
 795 }
 796
 797 #
 798 # Clean things up afterwards.
 799 #
 800 proc cleanup_target_hook { name } {
 801     global tool
 802     # Clean up the target board.
 803     if { [info procs "${name}_exit"] != "" } {
 804         ${name}_exit
 805     }
 806     # We also call the tool exit routine here.
 807     if [info exists tool] {
 808         if { [info procs "${tool}_exit"] != "" } {
 809             ${tool}_exit
 810         }
 811     }
 812     remote_close target
 813     pop_target
 814 }
 815
 816 proc setup_host_hook { name } {
 817     global board
 818     global board_info
 819     global board_type
 820
 821     set board $name
 822     set board_type "host"
 823
 824     load_board_description $name
 825     unset board
 826     unset board_type
 827     push_host $name
 828     if { [info proc ${name}_init] != "" } {
 829         ${name}_init $name
 830     }
 831 }
 832
 833 proc setup_build_hook { name } {
 834     global board
 835     global board_info
 836     global board_type
 837
 838     set board $name
 839     set board_type "build"
 840
 841     load_board_description $name
 842     unset board
 843     unset board_type
 844     push_build $name
 845     if { [info proc ${name}_init] != "" } {
 846         ${name}_init $name
 847     }
 848 }
 849
 850 #
 851 # Find and load the global config file if it exists.
 852 # The global config file is used to set the connect mode and other
 853 # parameters specific to each particular target.
 854 # These files assume the host and target have been set.
 855 #
 856
 857 if { [load_file -- $libdir/$configfile] == 0 } {
 858     # If $DEJAGNU isn't set either then there isn't any global config file.
 859     # Warn the user as there really should be one.
 860     if { ! [info exists env(DEJAGNU)] } {
 861         send_error "WARNING: Couldn't find the global config file.\n"
 862     }
 863 }
 864
 865 if [info exists env(DEJAGNU)] {
 866     if { [load_file -- $env(DEJAGNU)] == 0 } {
 867         # It may seem odd to only issue a warning if there isn't a global
 868         # config file, but issue an error if $DEJAGNU is erroneously defined.
 869         # Since $DEJAGNU is set there is *supposed* to be a global config file,
 870         # so the current behaviour seems reasonable.
 871         send_error "WARNING: global config file $env(DEJAGNU) not found.\n"
 872     }
 873     if ![info exists boards_dir] {
 874         set boards_dir "[file dirname $env(DEJAGNU)]/boards"
 875     }
 876 }
 877
 878 if ![info exists boards_dir] {
 879     set boards_dir ""
 880 }
 881
 882 #
 883 # parse out the config parts of the triplet name
 884 #
 885
 886 # build values
 887 if { $build_cpu == "" } {
 888     regsub -- "-.*-.*" ${build_triplet} "" build_cpu
 889 }
 890 if { $build_vendor == "" } {
 891     regsub -- "^\[a-z0-9\]*-" ${build_triplet} "" build_vendor
 892     regsub -- "-.*" ${build_vendor} "" build_vendor
 893 }
 894 if { $build_os == "" } {
 895     regsub -- ".*-.*-" ${build_triplet} "" build_os
 896 }
 897
 898 # host values
 899 if { $host_cpu == "" } {
 900     regsub -- "-.*-.*" ${host_triplet} "" host_cpu
 901 }
 902 if { $host_vendor == "" } {
 903     regsub -- "^\[a-z0-9\]*-" ${host_triplet} "" host_vendor
 904     regsub -- "-.*" ${host_vendor} "" host_vendor
 905 }
 906 if { $host_os == "" } {
 907     regsub -- ".*-.*-" ${host_triplet} "" host_os
 908 }
 909
 910 # target values
 911 if { $target_cpu == "" } {
 912     regsub -- "-.*-.*" ${target_triplet} "" target_cpu
 913 }
 914 if { $target_vendor == "" } {
 915     regsub -- "^\[a-z0-9\]*-" ${target_triplet} "" target_vendor
 916     regsub -- "-.*" ${target_vendor} "" target_vendor
 917 }
 918 if { $target_os == "" } {
 919     regsub -- ".*-.*-" ${target_triplet} "" target_os
 920 }
 921
 922 #
 923 # Load the primary tool initialization file.
 924 #
 925
 926 proc load_tool_init { file } {
 927     global srcdir
 928     global loaded_libs
 929
 930     if [info exists loaded_libs($file)] {
 931         return
 932     }
 933
 934     set loaded_libs($file) ""
 935
 936     if [file exists ${srcdir}/lib/$file] {
 937         verbose "Loading library file ${srcdir}/lib/$file"
 938         if { [catch "uplevel #0 source ${srcdir}/lib/$file"] == 1 } {
 939             send_error "ERROR: tcl error sourcing library file ${srcdir}/lib/$file.\n"
 940             global errorInfo
 941             if [info exists errorInfo] {
 942                 send_error "$errorInfo\n"
 943             }
 944             exit 1
 945         }
 946     } else {
 947         warning "Couldn't find tool init file"
 948     }
 949 }
 950
 951 #
 952 # load the testing framework libraries
 953 #
 954 load_lib utils.exp
 955 load_lib framework.exp
 956 load_lib debugger.exp
 957 load_lib remote.exp
 958 load_lib target.exp
 959 load_lib targetdb.exp
 960 load_lib libgloss.exp
 961
 962 # Initialize the test counters and reset them to 0.
 963 init_testcounts
 964 reset_vars
 965
 966 #
 967 # Parse the command line arguments.
 968 #
 969
 970 # Load the tool initialization file. Allow the --tool option to override
 971 # what's set in the site.exp file.
 972 if [info exists comm_line_tool] {
 973     set tool $comm_line_tool
 974 }
 975
 976 if [info exists tool] {
 977     load_tool_init ${tool}.exp
 978 }
 979
 980 set argc [ llength $argv ]
 981 for { set i 0 } { $i < $argc } { incr i } {
 982     set option [ lindex $argv $i ]
 983
 984     # make all options have two hyphens
 985     switch -glob -- $option {
 986         "--*" {
 987         }
 988         "-*" {
 989             set option "-$option"
 990         }
 991     }
 992
 993     # split out the argument for options that take them
 994     switch -glob -- $option {
 995         "--*=*" {
 996             regexp {^[^=]*=(.*)$} $option nil optarg
 997         }
 998         "--bu*" -
 999         "--ho*" -
1000         "--ig*"  -
1001         "--m*"  -
1002         "--n*"  -
1003         "--ob*" -
1004         "--ou*" -
1005         "--sr*" -
1006         "--str*" -
1007         "--ta*" -
1008         "--di*" -
1009         "--to*" {
1010             incr i
1011             set optarg [lindex $argv $i]
1012         }
1013     }
1014
1015     switch -glob -- $option {
1016         "--V*" -
1017         "--vers*" {                     # (--version) version numbers
1018             send_user "Expect version is\t[exp_version]\n"
1019             send_user "Tcl version is\t\t[ info tclversion ]\n"
1020             send_user "Framework version is\t$frame_version\n"
1021             exit
1022         }
1023
1024         "--v*" {                        # (--verbose) verbose output
1025             # Already parsed.
1026             continue
1027         }
1028
1029         "--bu*" {                       # (--build) the build host configuration
1030             # Already parsed (and don't set again).  Let $DEJAGNU rename it.
1031             continue
1032         }
1033
1034         "--ho*" {                       # (--host) the host configuration
1035             # Already parsed (and don't set again).  Let $DEJAGNU rename it.
1036             continue
1037         }
1038
1039         "--target_bo*" {
1040             # Set it again, father knows best.
1041             set target_list $optarg
1042             continue
1043         }
1044
1045         "--ta*" {                       # (--target) the target configuration
1046             # Already parsed (and don't set again).  Let $DEJAGNU rename it.
1047             continue
1048         }
1049
1050         "--a*" {                        # (--all) print all test output to screen
1051             set all_flag 1
1052             verbose "Print all test output to screen"
1053             continue
1054         }
1055
1056         "--di*" {
1057             # Already parsed (and don't set again).  Let $DEJAGNU rename it.
1058             # set cmdline_dir_to_run $optarg
1059             continue
1060         }
1061
1062
1063         "--de*" {                       # (--debug) expect internal debugging
1064             if [file exists ./dbg.log] {
1065                 catch "exec rm -f ./dbg.log"
1066             }
1067             if { $verbose > 2 } {
1068                 exp_internal -f dbg.log 1
1069             } else {
1070                 exp_internal -f dbg.log 0
1071             }
1072             verbose "Expect Debugging is ON"
1073             continue
1074         }
1075
1076         "--D[01]" {                     # (-Debug) turn on Tcl debugger
1077             verbose "Tcl debugger is ON"
1078             continue
1079         }
1080
1081         "--m*" {                        # (--mail) mail the output
1082             set mailing_list $optarg
1083             set mail_logs 1
1084             verbose "Mail results to $mailing_list"
1085             continue
1086         }
1087
1088         "--r*" {                        # (--reboot) reboot the target
1089             set reboot 1
1090             verbose "Will reboot the target (if supported)"
1091             continue
1092         }
1093
1094         "--ob*" {                       # (--objdir) where the test case object code lives
1095             # Already parsed, but parse again to make sure command line
1096             # options override any config file.
1097             set objdir $optarg
1098             verbose "Using test binaries in $objdir"
1099             continue
1100         }
1101
1102         "--ou*" {                       # (--outdir) where to put the output files
1103             set outdir $optarg
1104             verbose "Test output put in $outdir"
1105             continue
1106         }
1107
1108         "*.exp" {                       #  specify test names to run
1109             set all_runtests($option) ""
1110             verbose "Running only tests $option"
1111             continue
1112         }
1113
1114         "*.exp=*" {                     #  specify test names to run
1115             set tmp [split $option "="]
1116             set all_runtests([lindex $tmp 0]) [lindex $tmp 1]
1117             verbose "Running only tests $option"
1118             unset tmp
1119             continue
1120         }
1121
1122         "--ig*" {                       #  (--ignore) specify test names to exclude
1123             set ignoretests $optarg
1124             verbose "Ignoring test $ignoretests"
1125             continue
1126         }
1127
1128         "--sr*" {                       # (--srcdir) where the testsuite source code lives
1129             # Already parsed, but parse again to make sure command line
1130             # options override any config file.
1131
1132             set srcdir $optarg
1133             continue
1134         }
1135
1136         "--str*" {                      # (--strace) expect trace level
1137             set tracelevel $optarg
1138             strace $tracelevel
1139             verbose "Source Trace level is now $tracelevel"
1140             continue
1141         }
1142
1143         "--sta*" {                      # (--status) exit status flag
1144             set exit_error 1
1145             verbose "Tcl errors will set an ERROR exit status"
1146             continue
1147         }
1148
1149         "--tool_opt*" {
1150             continue
1151         }
1152
1153         "--tool_exec*" {
1154             set TOOL_EXECUTABLE $optarg
1155             continue
1156         }
1157
1158         "--tool_ro*" {
1159             set tool_root_dir $optarg
1160             continue
1161         }
1162
1163         "--to*" {                       # (--tool) specify tool name
1164             set tool $optarg
1165             verbose "Testing $tool"
1166             continue
1167         }
1168
1169         "--x*" {
1170             set xml 1
1171             verbose "XML logging turned on"
1172             continue
1173         }
1174
1175         "--he*" {                       # (--help) help text
1176             usage
1177             exit 0
1178         }
1179
1180         "[A-Z0-9_-.]*=*" { # skip makefile style args like CC=gcc, etc... (processed in first pass)
1181             continue
1182         }
1183
1184         default {
1185             if [info exists tool] {
1186                 if { [info proc ${tool}_option_proc] != "" } {
1187                     if [${tool}_option_proc $option] {
1188                         continue
1189                     }
1190                 }
1191             }
1192             send_error "\nIllegal Argument \"$option\"\n"
1193             send_error "try \"runtest --help\" for option list\n"
1194             exit 1
1195         }
1196     }
1197
1198 }
1199
1200 #
1201 # check for a few crucial variables
1202 #
1203 if ![info exists tool] {
1204     send_error "WARNING: No tool specified\n"
1205     set tool ""
1206 }
1207
1208 #
1209 # initialize a few Tcl variables to something other than their default
1210 #
1211 if { $verbose > 2 } {
1212     log_user 1
1213 } else {
1214     log_user 0
1215 }
1216
1217 set timeout 10
1218
1219
1220
1221 #
1222 # open log files
1223 #
1224 open_logs
1225
1226 # print the config info
1227 clone_output "Test Run By $logname on [timestamp -format %c]"
1228 if [is3way]  {
1229     clone_output "Target is $target_triplet"
1230     clone_output "Host   is $host_triplet"
1231     clone_output "Build  is $build_triplet"
1232 } else {
1233     if [isnative] {
1234         clone_output "Native configuration is $target_triplet"
1235     } else {
1236         clone_output "Target is $target_triplet"
1237         clone_output "Host   is $host_triplet"
1238     }
1239 }
1240
1241 clone_output "\n\t\t=== $tool tests ===\n"
1242
1243 #
1244 # Look for the generic board configuration file. It searches in several
1245 # places: ${libdir}/config, ${libdir}/../config, and $boards_dir.
1246 #
1247
1248 proc load_generic_config { name } {
1249     global srcdir
1250     global configfile
1251     global libdir
1252     global env
1253     global board
1254     global board_info
1255     global boards_dir
1256     global board_type
1257
1258     if [info exists board] {
1259         if ![info exists board_info($board,generic_name)] {
1260             set board_info($board,generic_name) $name
1261         }
1262     }
1263
1264     if [info exists board_type] {
1265         set type "for $board_type"
1266     } else {
1267         set type ""
1268     }
1269
1270     set dirlist [concat ${libdir}/config [file dirname $libdir]/config $boards_dir]
1271     set result [search_and_load_file "generic interface file $type" ${name}.exp $dirlist]
1272
1273     return $result
1274 }
1275
1276 #
1277 # Load the tool-specific target description.
1278 #
1279 proc load_config { args } {
1280     global srcdir
1281     global board_type
1282
1283     set found 0
1284
1285     return [search_and_load_file "tool-and-target-specific interface file" $args [list ${srcdir}/config ${srcdir}/../config ${srcdir}/../../config ${srcdir}/../../../config]]
1286 }
1287
1288 #
1289 # Find the files that set up the configuration for the target. There
1290 # are assumed to be two of them; one defines a basic set of
1291 # functionality for the target that can be used by all tool
1292 # testsuites, and the other defines any necessary tool-specific
1293 # functionality. These files are loaded via load_config.
1294 #
1295 # These used to all be named $target_abbrev-$tool.exp, but as the
1296 # $tool variable goes away, it's now just $target_abbrev.exp.  First
1297 # we look for a file named with both the abbrev and the tool names.
1298 # Then we look for one named with just the abbrev name. Finally, we
1299 # look for a file called default, which is the default actions, as
1300 # some tools could be purely host based. Unknown is mostly for error
1301 # trapping.
1302 #
1303
1304 proc load_tool_target_config { name } {
1305     global target_os libdir srcdir
1306
1307     set found [load_config "${name}.exp" "${target_os}.exp" "default.exp" "unknown.exp"]
1308
1309     if { $found == 0 } {
1310         send_error "WARNING: Couldn't find tool config file for $name, using default.\n"
1311         # If we can't load the tool init file, this must be a simple natively hosted
1312         # test suite, so we use the default procs for Unix.
1313         if { [search_and_load_file "library file" default.exp [list $libdir $libdir/config [file dirname [file dirname $srcdir]]/dejagnu/config $srcdir/config . [file dirname [file dirname [file dirname $srcdir]]]/dejagnu/config]] == 0 } {
1314             send_error "ERROR: Couldn't find default tool init file.\n"
1315             exit 1
1316         }
1317     }
1318 }
1319
1320 #
1321 # Find the file that describes the machine specified by board_name.
1322 #
1323
1324 proc load_board_description { board_name args } {
1325     global srcdir
1326     global configfile
1327     global libdir
1328     global env
1329     global board
1330     global board_info
1331     global boards_dir
1332     global board_type
1333
1334     set dejagnu ""
1335
1336     if { [llength $args] > 0 } {
1337         set whole_name [lindex $args 0]
1338     } else {
1339         set whole_name $board_name
1340     }
1341
1342     set board_info($whole_name,name) $whole_name
1343     if ![info exists board] {
1344         set board $whole_name
1345         set board_set 1
1346     } else {
1347         set board_set 0
1348     }
1349
1350     set dirlist {}
1351     if { [llength $args] > 1 } {
1352         set suffix [lindex $args 1]
1353         if { ${suffix} != "" } {
1354             foreach x ${boards_dir} {
1355                 lappend dirlist ${x}/${suffix}
1356             }
1357             lappend dirlist ${libdir}/baseboards/${suffix}
1358         }
1359     }
1360     set dirlist [concat $dirlist $boards_dir]
1361     lappend dirlist ${libdir}/baseboards
1362     verbose "dirlist is $dirlist"
1363     if [info exists board_type] {
1364         set type "for $board_type"
1365     } else {
1366         set type ""
1367     }
1368     if ![info exists board_info($whole_name,isremote)] {
1369         set board_info($whole_name,isremote) 1
1370         if [info exists board_type] {
1371             if { $board_type == "build" } {
1372                 set board_info($whole_name,isremote) 0
1373             }
1374         }
1375         if { ${board_name} == [get_local_hostname] } {
1376             set board_info($whole_name,isremote) 0
1377         }
1378     }
1379     search_and_load_file "standard board description file $type" standard.exp $dirlist
1380     set found [search_and_load_file "board description file $type" ${board_name}.exp $dirlist]
1381     if { $board_set != 0 } {
1382         unset board
1383     }
1384
1385     return $found
1386 }
1387
1388 #
1389 # Find the base-level file that describes the machine specified by args. We
1390 # only look in one directory, ${libdir}/baseboards.
1391 #
1392
1393 proc load_base_board_description { board_name } {
1394     global srcdir
1395     global configfile
1396     global libdir
1397     global env
1398     global board
1399     global board_info
1400     global board_type
1401
1402     set board_set 0
1403     set board_info($board_name,name) $board_name
1404     if ![info exists board] {
1405         set board $board_name
1406         set board_set 1
1407     }
1408     if [info exists board_type] {
1409         set type "for $board_type"
1410     } else {
1411         set type ""
1412     }
1413     if ![info exists board_info($board_name,isremote)] {
1414         set board_info($board_name,isremote) 1
1415         if [info exists board_type] {
1416             if { $board_type == "build" } {
1417                 set board_info($board_name,isremote) 0
1418             }
1419         }
1420     }
1421
1422     if { ${board_name} == [get_local_hostname] } {
1423         set board_info($board_name,isremote) 0
1424     }
1425     set found [search_and_load_file "board description file $type" ${board_name}.exp ${libdir}/baseboards]
1426     if { $board_set != 0 } {
1427         unset board
1428     }
1429
1430     return $found
1431 }
1432
1433 #
1434 # Source the testcase in TEST_FILE_NAME.
1435 #
1436
1437 proc runtest { test_file_name } {
1438     global prms_id
1439     global bug_id
1440     global test_result
1441     global errcnt
1442     global errorInfo
1443     global tool
1444
1445     clone_output "Running $test_file_name ..."
1446     set prms_id 0
1447     set bug_id  0
1448     set test_result ""
1449
1450     if [file exists $test_file_name] {
1451         set timestart [timestamp]
1452
1453         if [info exists tool] {
1454             if { [info procs "${tool}_init"] != "" } {
1455                 ${tool}_init $test_file_name
1456             }
1457         }
1458
1459         if { [catch "uplevel #0 source $test_file_name"] == 1 } {
1460             # If we have a Tcl error, propogate the exit status do make
1461             # notices the error.
1462             global exit_status exit_error
1463             # exit error is set by a command line option
1464             if { $exit_status == 0 } {
1465                 set exit_status $exit_error
1466             }
1467             # We can't call `perror' here, it resets `errorInfo'
1468             # before we want to look at it.  Also remember that perror
1469             # increments `errcnt'.  If we do call perror we'd have to
1470             # reset errcnt afterwards.
1471             clone_output "ERROR: tcl error sourcing $test_file_name."
1472             if [info exists errorInfo] {
1473                 clone_output "ERROR: $errorInfo"
1474                 unset errorInfo
1475             }
1476         }
1477
1478         if [info exists tool] {
1479             if { [info procs "${tool}_finish"] != "" } {
1480                 ${tool}_finish
1481             }
1482         }
1483         set timeend [timestamp]
1484         set timediff [expr $timeend - $timestart]
1485         verbose -log "testcase $test_file_name completed in $timediff seconds" 4
1486     } else {
1487         # This should never happen, but maybe if the file got removed
1488         # between the `find' above and here.
1489         perror "$test_file_name does not exist."
1490         # ??? This is a hack.  We want to send a message to stderr and
1491         # to the summary file (just like perror does), but we don't
1492         # want the next testcase to get a spurious "unresolved" because
1493         # errcnt != 0.  Calling `clone_output' is also supposed to be a
1494         # no-no (see the comments for clone_output).
1495         set errcnt 0
1496     }
1497 }
1498
1499 #
1500 # Trap some signals so we know what's happening.  These replace the previous
1501 # ones because we've now loaded the library stuff.
1502 #
1503 if ![exp_debug] {
1504     foreach sig "{SIGTERM {terminated}} \
1505              {SIGINT  {interrupted by user}} \
1506              {SIGQUIT {interrupted by user}} \
1507              {SIGSEGV {segmentation violation}}" {
1508         set signal [lindex $sig 0]
1509         set str [lindex $sig 1]
1510         trap "send_error \"got a \[trap -name\] signal, $str \\n\"; log_and_exit;" $signal
1511         verbose "setting trap for $signal to $str" 1
1512     }
1513     unset signal str sig
1514 }
1515
1516 #
1517 # Given a list of targets, process any iterative lists.
1518 #
1519 proc process_target_variants { target_list } {
1520     set result {}
1521     foreach x $target_list {
1522         if [regexp "\\(" $x] {
1523             regsub "^.*\\((\[^()\]*)\\)$" "$x" "\\1" variant_list
1524             regsub "\\(\[^(\]*$" "$x" "" x
1525             set list [process_target_variants $x]
1526             set result {}
1527             foreach x $list {
1528                 set result [concat $result [iterate_target_variants $x [split $variant_list ","]]]
1529             }
1530         } elseif [regexp "\{" $x] {
1531             regsub "^.*\{(\[^\{\}\]*)\}$" "$x" "\\1" variant_list
1532             regsub "\{\[^\{\]*$" "$x" "" x
1533             set list [process_target_variants $x]
1534             foreach x $list {
1535                 foreach i [split $variant_list ","] {
1536                     set name $x
1537                     if { $i != "" } {
1538                         append name "/" $i
1539                     }
1540                     lappend result $name
1541                 }
1542             }
1543         } else {
1544             lappend result "$x"
1545         }
1546     }
1547     return $result
1548 }
1549
1550 proc iterate_target_variants { target variants } {
1551     return [iterate_target_variants_two $target $target $variants]
1552 }
1553
1554 #
1555 # Given a list of variants, produce the list of all possible combinations.
1556 #
1557 proc iterate_target_variants_two { orig_target target variants } {
1558
1559     if { [llength $variants] == 0 } {
1560         return [list $target]
1561     } else {
1562         if { [llength $variants] > 1 } {
1563             set result [iterate_target_variants_two $orig_target $target [lrange $variants 1 end]]
1564         } else {
1565             if { $target != $orig_target } {
1566                 set result [list $target]
1567             } else {
1568                 set result {}
1569             }
1570         }
1571         if { [lindex $variants 0] != "" } {
1572             append target "/" [lindex $variants 0]
1573             return [concat $result [iterate_target_variants_two $orig_target $target [lrange $variants 1 end]]]
1574         } else {
1575             return [concat $result $target]
1576         }
1577     }
1578 }
1579
1580 setup_build_hook [get_local_hostname]
1581
1582 if [info exists host_board] {
1583     setup_host_hook $host_board
1584 } else {
1585     set hb [get_local_hostname]
1586     if { $hb != "" } {
1587         setup_host_hook $hb
1588     }
1589 }
1590
1591 #
1592 # main test execution loop
1593 #
1594
1595 if [info exists errorInfo] {
1596     unset errorInfo
1597 }
1598 # make sure we have only single path delimiters
1599 regsub -all "\(\[^/\]\)//*" $srcdir "\\1/" srcdir
1600
1601 if ![info exists target_list] {
1602     # Make sure there is at least one target machine. It's probably a Unix box,
1603     # but that's just a guess.
1604     set target_list { "unix" }
1605 } else {
1606     verbose "target list is $target_list"
1607 }
1608
1609 #
1610 # Iterate through the list of targets.
1611 #
1612 global current_target
1613
1614 set target_list [process_target_variants $target_list]
1615
1616 set target_count [llength $target_list]
1617
1618 clone_output "Schedule of variations:"
1619 foreach current_target $target_list {
1620     clone_output "    $current_target"
1621 }
1622 clone_output ""
1623
1624
1625 foreach current_target $target_list {
1626     verbose "target is $current_target"
1627     set current_target_name $current_target
1628     set tlist [split $current_target /]
1629     set current_target [lindex $tlist 0]
1630     set board_variant_list [lrange $tlist 1 end]
1631
1632     # Set the counts for this target to 0.
1633     reset_vars
1634     clone_output "Running target $current_target_name"
1635
1636     setup_target_hook $current_target_name $current_target
1637
1638     # If multiple passes requested, set them up.  Otherwise prepare just one.
1639     # The format of `MULTIPASS' is a list of elements containing
1640     # "{ name var1=value1 ... }" where `name' is a generic name for the pass and
1641     # currently has no other meaning.
1642
1643     global env
1644
1645     if { [info exists MULTIPASS] } {
1646         set multipass $MULTIPASS
1647     }
1648     if { $multipass == "" } {
1649         set multipass { "" }
1650     }
1651
1652     # If PASS is specified, we want to run only the tests specified.
1653     # Its value should be a number or a list of numbers that specify
1654     # the passes that we want to run.
1655     if [info exists PASS] {
1656         set pass $PASS
1657     } else {
1658         set pass ""
1659     }
1660
1661     if {$pass != ""} {
1662         set passes [list]
1663         foreach p $pass {
1664             foreach multipass_elem $multipass {
1665                 set multipass_name [lindex $multipass_elem 0]
1666                 if {$p == $multipass_name} {
1667                     lappend passes $multipass_elem
1668                     break
1669                 }
1670             }
1671         }
1672         set multipass $passes
1673     }
1674
1675     foreach pass $multipass {
1676
1677         # multipass_name is set for `record_test' to use (see framework.exp).
1678         if { [lindex $pass 0] != "" } {
1679             set multipass_name [lindex $pass 0]
1680             clone_output "Running pass `$multipass_name' ..."
1681         } else {
1682             set multipass_name ""
1683         }
1684         set restore ""
1685         foreach varval [lrange $pass 1 end] {
1686             set tmp [string first "=" $varval]
1687             set var [string range $varval 0 [expr $tmp - 1]]
1688             # Save previous value.
1689             if [info exists $var] {
1690                 lappend restore "$var [list [eval concat \$$var]]"
1691             } else {
1692                 lappend restore "$var"
1693             }
1694             # Handle "CFLAGS=$CFLAGS foo".
1695             # FIXME: Do we need to `catch' this?
1696             eval set $var \[string range \"$varval\" [expr $tmp + 1] end\]
1697             verbose "$var is now [eval concat \$$var]"
1698             unset tmp var
1699         }
1700
1701         # look for the top level testsuites. if $tool doesn't
1702         # exist and there are no subdirectories in $srcdir, then
1703         # we default to srcdir.
1704         set test_top_dirs [lsort [getdirs -all ${srcdir} "${tool}*"]]
1705         if { ${test_top_dirs} == "" } {
1706             set test_top_dirs ${srcdir}
1707         } else {
1708             # JYG:
1709             # DejaGNU's notion of test tree and test files is very
1710             # general:
1711             # given ${srcdir} and ${tool}, any subdirectory (at any
1712             # level deep) with the "${tool}" prefix starts a test tree
1713             # given a test tree, any *.exp file underneath (at any
1714             # level deep) is a test file.
1715             #
1716             # For test tree layouts with ${tool} prefix on
1717             # both a parent and a child directory, we need to eliminate
1718             # the child directory entry from test_top_dirs list.
1719             # e.g. gdb.hp/gdb.base-hp/ would result in two entries
1720             # in the list: gdb.hp, gdb.hp/gdb.base-hp.
1721             # If the latter not eliminated, test files under
1722             # gdb.hp/gdb.base-hp would be run twice (since test files
1723             # are gathered from all sub-directories underneath a
1724             # directory).
1725             #
1726             # Since ${tool} may be g++, etc. which could confuse
1727             # regexp, we cannot do the simpler test:
1728             #     ...
1729             #     if [regexp "${srcdir}/.*${tool}.*/.*${tool}.*" ${dir}]
1730             #     ...
1731             # instead, we rely on the fact that test_top_dirs is
1732             # a sorted list of entries, and any entry that contains
1733             # the previous valid test top dir entry in its own pathname
1734             # must be excluded.
1735
1736             set temp_top_dirs ""
1737             set prev_dir ""
1738             foreach dir "${test_top_dirs}" {
1739                 if { [string length ${prev_dir}] == 0 ||
1740                      [string first "${prev_dir}/" ${dir}] == -1} {
1741                     # the first top dir entry, or an entry that
1742                     # does not share the previous entry's entire
1743                     # pathname, record it as a valid top dir entry.
1744                     #
1745                     lappend temp_top_dirs ${dir}
1746                     set prev_dir ${dir}
1747                 }
1748             }
1749             set test_top_dirs ${temp_top_dirs}
1750         }
1751         verbose "Top level testsuite dirs are ${test_top_dirs}" 2
1752         set testlist ""
1753         if [info exists all_runtests] {
1754             foreach x [array names all_runtests] {
1755                 verbose "trying to glob ${srcdir}/${x}" 2
1756                 set s [glob -nocomplain ${srcdir}/$x]
1757                 if { $s != "" } {
1758                     set testlist [concat $testlist $s]
1759                 }
1760             }
1761         }
1762         #
1763         # If we have a list of tests, run all of them.
1764         #
1765         if { $testlist != "" } {
1766             foreach test_name $testlist {
1767                 if { ${ignoretests} != "" } {
1768                     if { 0 <= [lsearch ${ignoretests} [file tail ${test_name}]]} {
1769                         continue
1770                     }
1771                 }
1772
1773                 # set subdir to the tail of the dirname after $srcdir,
1774                 # for the driver files that want it.  XXX this is silly.
1775                 # drivers should get a single var, not "$srcdir/$subdir"
1776                 set subdir [file dirname $test_name]
1777                 set p [expr [string length $srcdir]-1]
1778                 while {0 < $p && [string index $srcdir $p] == "/"} {
1779                     incr p -1
1780                 }
1781                 if {[string range $subdir 0 $p] == $srcdir} {
1782                     set subdir [string range $subdir [expr $p+1] end]
1783                     regsub "^/" $subdir "" subdir
1784                 }
1785
1786                 # XXX not the right thing to do.
1787                 set runtests [list [file tail $test_name] ""]
1788
1789                 runtest $test_name
1790             }
1791         } else {
1792             #
1793             # Go digging for tests.
1794             #
1795             foreach dir "${test_top_dirs}" {
1796                 if { ${dir} != ${srcdir} } {
1797                     # Ignore this directory if is a directory to be
1798                     # ignored.
1799                     if {[info exists ignoredirs] && $ignoredirs != ""} {
1800                         set found 0
1801                         foreach directory $ignoredirs {
1802                             if [string match "*${directory}*" $dir] {
1803                                 set found 1
1804                                 break
1805                             }
1806                         }
1807                         if {$found} {
1808                             continue
1809                         }
1810                     }
1811
1812                     # Run the test if dir_to_run was specified as a
1813                     # value (for example in MULTIPASS) and the test
1814                     # directory matches that directory.
1815                     if {[info exists dir_to_run] && $dir_to_run != ""} {
1816                         # JYG: dir_to_run might be a space delimited list
1817                         # of directories.  Look for match on each item.
1818                         set found 0
1819                         foreach directory $dir_to_run {
1820                             if [string match "*${directory}*" $dir] {
1821                                 set found 1
1822                                 break
1823                             }
1824                         }
1825                         if {!$found} {
1826                             continue
1827                         }
1828                     }
1829
1830                     # Run the test if cmdline_dir_to_run was specified
1831                     # by the user using --directory and the test
1832                     # directory matches that directory
1833                     if {[info exists cmdline_dir_to_run] \
1834                             && $cmdline_dir_to_run != ""} {
1835                         # JYG: cmdline_dir_to_run might be a space delimited
1836                         # list of directories.  Look for match on each item.
1837                         set found 0
1838                         foreach directory $cmdline_dir_to_run {
1839                             if [string match "*${directory}*" $dir] {
1840                                 set found 1
1841                                 break
1842                             }
1843                         }
1844                         if {!$found} {
1845                             continue
1846                         }
1847                     }
1848
1849                     foreach test_name [lsort [find ${dir} *.exp]] {
1850                         if { ${test_name} == "" } {
1851                             continue
1852                         }
1853                         # Ignore this one if asked to.
1854                         if { ${ignoretests} != "" } {
1855                             if { 0 <= [lsearch ${ignoretests} [file tail ${test_name}]]} {
1856                                 continue
1857                             }
1858                         }
1859
1860                         # Get the path after the $srcdir so we know
1861                         # the subdir we're in.
1862                         set subdir [file dirname $test_name]
1863                         # We used to do
1864                         # regsub $srcdir [file dirname $test_name] "" subdir
1865                         # but what if [file dirname $test_name] contains regexp
1866                         # characters? We lose. Instead...
1867                         set first [string first $srcdir $subdir]
1868                         if { $first >= 0 } {
1869                             set first [expr $first + [string length $srcdir]]
1870                             set subdir [string range $subdir $first end]
1871                             regsub "^/" "$subdir" "" subdir
1872                         }
1873                         if { "$srcdir" == "$subdir" || "$srcdir" == "$subdir/" } {
1874                             set subdir ""
1875                         }
1876                         # Check to see if the range of tests is limited,
1877                         # set `runtests' to a list of two elements: the script name
1878                         # and any arguments ("" if none).
1879                         if [info exists all_runtests] {
1880                             verbose "searching for $test_name in [array names all_runtests]"
1881                             if { 0 > [lsearch [array names all_runtests] [file tail $test_name]]} {
1882                                 if { 0 > [lsearch [array names all_runtests] $test_name] } {
1883                                     continue
1884                                 }
1885                             }
1886                             set runtests [list [file tail $test_name] $all_runtests([file tail $test_name])]
1887                         } else {
1888                             set runtests [list [file tail $test_name] ""]
1889                         }
1890                         runtest $test_name
1891                     }
1892                 }
1893             }
1894             # Restore the variables set by this pass.
1895             foreach varval $restore {
1896                 if { [llength $varval] > 1 } {
1897                     verbose "Restoring [lindex $varval 0] to [lindex $varval 1]" 4
1898                     set [lindex $varval 0] [lindex $varval 1]
1899                 } else {
1900                     verbose "Restoring [lindex $varval 0] to `unset'" 4
1901                     unset [lindex $varval 0]
1902                 }
1903             }
1904         }
1905     }
1906     cleanup_target_hook $current_target
1907     if { $target_count > 1 } {
1908         log_summary
1909     }
1910 }
1911
1912 log_and_exit