lib/dg.exp

   1 # `dg' general purpose testcase driver.
   2
   3 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
   4 #
   5 # This file is part of DejaGnu.
   6 #
   7 # DejaGnu is free software: you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation, either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # DejaGnu is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with DejaGnu.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 # This file was written by Doug Evans (dje@cygnus.com).
  21
  22 # This file is based on old-dejagnu.exp.  It is intended to be more extensible
  23 # without incurring the overhead that old-dejagnu.exp can.  All test framework
  24 # commands appear in the testcase as "{ dg-xxx args ... }".  We pull them out
  25 # with one grep, and then run the function(s) named by "dg-xxx".  When running
  26 # dg-xxx, the line number that it occurs on is always passed as the first
  27 # argument.  We also support different kinds of tools via callbacks.
  28 #
  29 # The currently supported options are:
  30 #
  31 # dg-prms-id N
  32 #       set prms_id to N
  33 #
  34 # dg-options "options ..." [{ target selector }]
  35 #       specify special options to pass to the tool (eg: compiler)
  36 #
  37 # dg-do do-what-keyword [{ target/xfail selector }]
  38 #       `do-what-keyword' is tool specific and is passed unchanged to
  39 #       ${tool}-dg-test.  An example is gcc where `keyword' can be any of:
  40 #       preprocess | compile | assemble | link | run
  41 #       and will do one of: produce a .i, produce a .s, produce a .o,
  42 #       produce an a.out, or produce an a.out and run it (the default is
  43 #       'compile').
  44 #
  45 # dg-error regexp comment [{ target/xfail selector } [{.|0|linenum}]]
  46 #       indicate an error message <regexp> is expected on this line
  47 #       (the test fails if it doesn't occur)
  48 #       linenum=0 for general tool messages (eg: -V arg missing).
  49 #       "." means the current line.
  50 #
  51 # dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum}]]
  52 #       indicate a warning message <regexp> is expected on this line
  53 #       (the test fails if it doesn't occur)
  54 #
  55 # dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum}]]
  56 #       indicate a bogus error message <regexp> used to occur here
  57 #       (the test fails if it does occur)
  58 #
  59 # dg-build regexp comment [{ target/xfail selector }]
  60 #       indicate the build use to fail for some reason
  61 #       (errors covered here include bad assembler generated, tool crashes,
  62 #       and link failures)
  63 #       (the test fails if it does occur)
  64 #
  65 # dg-excess-errors comment [{ target/xfail selector }]
  66 #       indicate excess errors are expected (any line)
  67 #       (this should only be used sparingly and temporarily)
  68 #
  69 # dg-output regexp [{ target selector }]
  70 #       indicate the expected output of the program is <regexp>
  71 #       (there may be multiple occurrences of this, they are concatenated)
  72 #
  73 # dg-final { tcl script }
  74 #       add some Tcl script to be run at the end
  75 #       (there may be multiple occurrences of this, they are concatenated)
  76 #       (unbalanced braces must be \-escaped)
  77 #
  78 # "{ target selector }" is a list of expressions that determine whether the
  79 # test succeeds or fails for a particular target, or in some cases whether the
  80 # option applies for a particular target.  If the case of `dg-do' it specifies
  81 # whether the testcase is even attempted on the specified target.
  82 #
  83 # The target selector is always optional.  The format is one of:
  84 #
  85 # { xfail *-*-* ... } - the test is expected to fail for the given targets
  86 # { target *-*-* ... } - the option only applies to the given targets
  87 #
  88 # At least one target must be specified, use *-*-* for "all targets".
  89 # At present it is not possible to specify both `xfail' and `target'.
  90 # "native" may be used in place of "*-*-*".
  91 #
  92 # Example:
  93 #
  94 #       [ ... some complicated code ... ]
  95 #       return a; /* { dg-build "fatal" "ran out of spill regs" { xfail i386-*-* } } */
  96 #
  97 # In this contrived example, the compiler used to crash on the "return
  98 # a;" for some target and it still does crash on i386-*-*.
  99 #
 100 # ??? It might be possible to add additional optional arguments by having
 101 # something like: { dg-error ".*syntax.*" "syntax error" { { foo 1 } ... } }
 102 #
 103 # Callbacks
 104 #
 105 # ${tool}-dg-test testfile do-what-keyword extra-flags
 106 #
 107 #       Run the test, be it compiler, assembler, or whatever.
 108 #
 109 # ${tool}-dg-prune target_triplet text
 110 #
 111 #       Optional callback to delete output from the tool that can occur
 112 #       even in successful ("pass") situations and interfere with output
 113 #       pattern matching.  This also gives the tool an opportunity to review
 114 #       the output and check for any conditions which indicate an "untested"
 115 #       or "unresolved" state.  An example is if a testcase is too big and
 116 #       fills all available ram (which can happen for 16 bit CPUs).  The
 117 #       result is either the pruned text or
 118 #       "::untested|unresolved|unsupported::message"
 119 #       (eg: "::unsupported::memory full").
 120 #
 121 # Notes:
 122 # 1) All runnable testcases must return 0 from main() for success.
 123 #    You can't rely on getting any return code from target boards, and the
 124 #    `exec' command says a program fails if it returns non-zero.
 125 #
 126 # Language independence is (theoretically) achieved by:
 127 #
 128 # 1) Using global $tool to indicate the language (eg: gcc, g++, gas, etc.).
 129 #    This should only be used to look up other objects.  We don't want to
 130 #    have to add code for each new language that is supported.  If this is
 131 #    done right, no code needs to be added here for each new language.
 132 #
 133 # 2) Passing tool options in as arguments.
 134 #
 135 #    Earlier versions of ${tool}_start (eg: gcc_start) would only take the name
 136 #    of the file to compile as an argument.  Newer versions accept a list of
 137 #    one or two elements, the second being a string of *all* options to pass
 138 #    to the tool.  We require this facility.
 139 #
 140 # 3) Callbacks.
 141 #
 142 # Try not to do anything else that makes life difficult.
 143 #
 144 # The normal way to write a testsuite is to have a .exp file containing:
 145 #
 146 # load_lib ${tool}-dg.exp
 147 # dg-init
 148 # dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/foo*]] ...
 149 # dg-finish
 150 \f
 151 # Global state variables.
 152 # The defaults are for GCC.
 153
 154 # The default do-what keyword.
 155 set dg-do-what-default compile
 156
 157 # When dg-interpreter-batch-mode is 1, no execution test or excess error
 158 # tests are performed.
 159 set dg-interpreter-batch-mode 0
 160
 161 # Line number format.  This is how line numbers appear in program output.
 162 set dg-linenum-format ":%d:"
 163 proc dg-format-linenum { linenum } {
 164     global dg-linenum-format
 165     return [format ${dg-linenum-format} $linenum]
 166 }
 167
 168 # Useful subroutines.
 169
 170 # dg-get-options -- pick out the dg-xxx options in a testcase
 171 #
 172 # PROG is the file name of the testcase.
 173 # The result is a list of options found.
 174 #
 175 # Example: For the following testcase:
 176 #
 177 # /* { dg-prms-id 1234 } */
 178 # int foo { return 0; } /* { dg-build fatal "some comment" } */
 179 #
 180 # we return:
 181 #
 182 # { dg-prms-id 1 1234 } { dg-build 2 fatal "some comment" }
 183
 184 proc dg-get-options { prog } {
 185     set result ""
 186
 187     set tmp [grep $prog "{\[ \t\]\+dg-\[-a-z\]\+\[ \t\]\+.*\[ \t\]\+}" line]
 188     if {$tmp ne ""} {
 189         foreach i $tmp {
 190             regexp "(\[0-9\]+)\[ \t\]+{\[ \t\]+(dg-\[-a-z\]+)\[ \t\]+(.*)\[ \t\]+}\[^\}\]*(\n|$)" $i i line cmd args
 191             append result " { $cmd $line $args }"
 192         }
 193     }
 194     return $result
 195 }
 196
 197 #
 198 # Process optional xfail/target arguments
 199 #
 200 # SELECTOR is "xfail target-triplet-1 ..." or "target target-triplet-1 ..."
 201 # `target-triplet' may be "native".
 202 # For xfail, the result is "F" (expected to Fail) if the current target is
 203 # affected, otherwise "P" (expected to Pass).
 204 # For target, the result is "S" (target is Selected) if the target is selected,
 205 # otherwise "N" (target is Not selected).
 206 #
 207 proc dg-process-target { selector } {
 208     global target_triplet
 209
 210     set isnative [isnative]
 211     set triplet_match 0
 212
 213     set selector [string trim $selector]
 214     if {[regexp "^xfail " $selector]} {
 215         set what xfail
 216     } elseif {[regexp "^target " $selector]} {
 217         set what target
 218     } else {
 219         # The use of error here and in other dg-xxx utilities is intentional.
 220         # dg-test will catch them and do the right thing.
 221         error "syntax error in target selector \"$selector\""
 222     }
 223
 224     if {[regexp "^${what}( \[^ \]+-\[^ \]+-\[^ \]+| native)+$" $selector]} {
 225         regsub "^${what} " $selector "" selector
 226         foreach triplet $selector {
 227             if {[string match $triplet $target_triplet]} {
 228                 set triplet_match 1
 229             } elseif { $isnative && $triplet eq "native" } {
 230                 set triplet_match 1
 231             }
 232         }
 233     } else {
 234         error "syntax error in target selector \"$selector\""
 235     }
 236
 237     if { $triplet_match } {
 238         return [expr { $what eq "xfail" ? "F" : "S" }]
 239     } else {
 240         return [expr { $what eq "xfail" ? "P" : "N" }]
 241     }
 242 }
 243
 244 # Predefined user option handlers.
 245 # The line number is always the first element.
 246 # Note that each of these are varargs procs (they have an `args' argument).
 247 # Tests for optional arguments are coded with ">=" to simplify adding new ones.
 248 #
 249 proc dg-prms-id { args } {
 250     global prms_id
 251
 252     if { [llength $args] > 2 } {
 253         error "[lindex $args 0]: too many arguments"
 254     }
 255
 256     set prms_id [lindex $args 1]
 257 }
 258
 259 # Set tool options
 260 #
 261 # Different options can be used for different targets by having multiple
 262 # instances, selecting a different target each time.  Since options are
 263 # processed in order, put the default value first.  Subsequent occurrences
 264 # will override previous ones.
 265 #
 266 proc dg-options { args } {
 267     upvar dg-extra-tool-flags extra-tool-flags
 268
 269     if { [llength $args] > 3 } {
 270         error "[lindex $args 0]: too many arguments"
 271     }
 272
 273     if { [llength $args] >= 3 } {
 274         switch -- [dg-process-target [lindex $args 2]] {
 275             "S" { set extra-tool-flags [lindex $args 1] }
 276             "N" { }
 277             "F" { error "[lindex $args 0]: `xfail' not allowed here" }
 278             "P" { error "[lindex $args 0]: `xfail' not allowed here" }
 279         }
 280     } else {
 281         set extra-tool-flags [lindex $args 1]
 282     }
 283 }
 284
 285 # Record what to do (compile/run/etc.)
 286 #
 287 # Multiple instances are supported (since we don't support target and xfail
 288 # selectors on one line), though it doesn't make much sense to change the
 289 # compile/assemble/link/run field.  Nor does it make any sense to have
 290 # multiple lines of target selectors (use one line).
 291 #
 292 proc dg-do { args } {
 293     upvar dg-do-what do-what
 294
 295     if { [llength $args] > 3 } {
 296         error "[lindex $args 0]: too many arguments"
 297     }
 298
 299     set doaction [lindex $args 1]
 300     set selected [lindex ${do-what} 1]  ;# selected? (""/S/N)
 301     set expected [lindex ${do-what} 2]  ;# expected to pass/fail (P/F)
 302
 303     if { [llength $args] >= 3 } {
 304         switch -- [dg-process-target [lindex $args 2]] {
 305             "S" {
 306                 set selected "S"
 307             }
 308             "N" {
 309                 # Don't deselect a target if it's been explicitly selected,
 310                 # but indicate a specific target has been selected (so don't
 311                 # do this testcase if it's not appropriate for this target).
 312                 # The user really shouldn't have multiple lines of target
 313                 # selectors, but try to do the intuitive thing (multiple lines
 314                 # are OR'd together).
 315                 if { $selected ne "S" } {
 316                     set selected "N"
 317                 } else {
 318                     set doaction [lindex ${do-what} 0]
 319                 }
 320             }
 321             "F" { set expected "F" }
 322             "P" {
 323                 # There's nothing to do for "P".  We don't want to clobber a
 324                 # previous xfail for this target.
 325             }
 326         }
 327     } else {
 328         # Note: A previous occurrence of `dg-do' with target/xfail selectors
 329         # is a user mistake.  We clobber previous values here.
 330         set selected S
 331         set expected P
 332     }
 333
 334     switch -- [lindex $args 1] {
 335         "preprocess" { }
 336         "compile" { }
 337         "assemble" { }
 338         "link" { }
 339         "run" { }
 340         default {
 341             error "[lindex $args 0]: syntax error"
 342         }
 343     }
 344     set do-what [list $doaction $selected $expected]
 345 }
 346
 347 proc dg-error { args } {
 348     upvar dg-messages messages
 349
 350     if { [llength $args] > 5 } {
 351         error "[lindex $args 0]: too many arguments"
 352     }
 353
 354     set xfail ""
 355     if { [llength $args] >= 4 } {
 356         switch -- [dg-process-target [lindex $args 3]] {
 357             "F" { set xfail "X" }
 358             "P" { set xfail "" }
 359             "N" {
 360                 # If we get "N", this error doesn't apply to us so ignore it.
 361                 return
 362             }
 363         }
 364     }
 365
 366     if { [llength $args] >= 5 } {
 367         switch -- [lindex $args 4] {
 368             "." { set line [dg-format-linenum [lindex $args 0]] }
 369             "0" { set line "" }
 370             "default" { set line [dg-format-linenum [lindex $args 4]] }
 371         }
 372     } else {
 373         set line [dg-format-linenum [lindex $args 0]]
 374     }
 375
 376     lappend messages [list $line ${xfail}ERROR [lindex $args 1] [lindex $args 2]]
 377 }
 378
 379 proc dg-warning { args } {
 380     upvar dg-messages messages
 381
 382     if { [llength $args] > 5 } {
 383         error "[lindex $args 0]: too many arguments"
 384     }
 385
 386     set xfail ""
 387     if { [llength $args] >= 4 } {
 388         switch -- [dg-process-target [lindex $args 3]] {
 389             "F" { set xfail "X" }
 390             "P" { set xfail "" }
 391             "N" {
 392                 # If we get "N", this warning doesn't apply to us so ignore it.
 393                 return
 394             }
 395         }
 396     }
 397
 398     if { [llength $args] >= 5 } {
 399         switch -- [lindex $args 4] {
 400             "." { set line [dg-format-linenum [lindex $args 0]] }
 401             "0" { set line "" }
 402             "default" { set line [dg-format-linenum [lindex $args 4]] }
 403         }
 404     } else {
 405         set line [dg-format-linenum [lindex $args 0]]
 406     }
 407
 408     lappend messages [list $line ${xfail}WARNING [lindex $args 1] [lindex $args 2]]
 409 }
 410
 411 proc dg-bogus { args } {
 412     upvar dg-messages messages
 413
 414     if { [llength $args] > 5 } {
 415         error "[lindex $args 0]: too many arguments"
 416     }
 417
 418     set xfail ""
 419     if { [llength $args] >= 4 } {
 420         switch -- [dg-process-target [lindex $args 3]] {
 421             "F" { set xfail "X" }
 422             "P" { set xfail "" }
 423             "N" {
 424                 # If we get "N", this message doesn't apply to us so ignore it.
 425                 return
 426             }
 427         }
 428     }
 429
 430     if { [llength $args] >= 5 } {
 431         switch -- [lindex $args 4] {
 432             "." { set line [dg-format-linenum [lindex $args 0]] }
 433             "0" { set line "" }
 434             "default" { set line [dg-format-linenum [lindex $args 4]] }
 435         }
 436     } else {
 437         set line [dg-format-linenum [lindex $args 0]]
 438     }
 439
 440     lappend messages [list $line ${xfail}BOGUS [lindex $args 1] [lindex $args 2]]
 441 }
 442
 443 proc dg-build { args } {
 444     upvar dg-messages messages
 445
 446     if { [llength $args] > 4 } {
 447         error "[lindex $args 0]: too many arguments"
 448     }
 449
 450     set xfail ""
 451     if { [ llength $args] >= 4 } {
 452         switch -- [dg-process-target [lindex $args 3]] {
 453             "F" { set xfail "X" }
 454             "P" { set xfail "" }
 455             "N" {
 456                 # If we get "N", this lossage doesn't apply to us so ignore it.
 457                 return
 458             }
 459         }
 460     }
 461
 462     lappend messages [list [lindex $args 0] ${xfail}BUILD [lindex $args 1] [lindex $args 2]]
 463 }
 464
 465 proc dg-excess-errors { args } {
 466     upvar dg-excess-errors-flag excess-errors-flag
 467
 468     if { [llength $args] > 3 } {
 469         error "[lindex $args 0]: too many arguments"
 470     }
 471
 472     if { [llength $args] >= 3 } {
 473         switch -- [dg-process-target [lindex $args 2]] {
 474             "F" { set excess-errors-flag 1 }
 475             "S" { set excess-errors-flag 1 }
 476         }
 477     } else {
 478         set excess-errors-flag 1
 479     }
 480 }
 481
 482 # Indicate expected program output.
 483 #
 484 # We support multiple occurrences, but we do not implicitly insert newlines
 485 # between them.
 486 #
 487 # Note that target boards don't all support this kind of thing so it's a good
 488 # idea to specify the target all the time.  If one or more targets are
 489 # explicitly selected, the test won't be performed if we're not one of them
 490 # (as long as we were never mentioned).
 491 #
 492 # If you have target dependent output and want to set an xfail for one or more
 493 # of them, use { dg-output "" { xfail a-b-c ... } }.  The "" won't contribute
 494 # to the expected output.
 495 #
 496 proc dg-output { args } {
 497     upvar dg-output-text output-text
 498
 499     if { [llength $args] > 3 } {
 500         error "[lindex $args 0]: too many arguments"
 501     }
 502
 503     # Allow target dependent output.
 504
 505     set expected [lindex ${output-text} 0]
 506     if { [llength $args] >= 3 } {
 507         switch -- [dg-process-target [lindex $args 2]] {
 508             "N" { return }
 509             "S" { }
 510             "F" { set expected "F" }
 511             # Don't override a previous xfail.
 512             "P" { }
 513         }
 514     }
 515
 516     if { [llength ${output-text}] == 1 } {
 517         # First occurrence.
 518         set output-text [list $expected [lindex $args 1]]
 519     } else {
 520         set output-text [list $expected "[lindex ${output-text} 1][lindex $args 1]"]
 521     }
 522 }
 523
 524 proc dg-final { args } {
 525     upvar dg-final-code final-code
 526
 527     if { [llength $args] > 2 } {
 528         error "[lindex $args 0]: too many arguments"
 529     }
 530
 531     append final-code "[lindex $args 1]\n"
 532 }
 533 \f
 534 # Set up our environment
 535 #
 536 # There currently isn't much to do, but always calling it allows us to add
 537 # enhancements without having to update our callers.
 538 # It must be run before calling `dg-test'.
 539 #
 540 proc dg-init { } {
 541 }
 542 \f
 543 # dg-runtest -- simple main loop useful to most testsuites
 544 #
 545 # OPTIONS is a set of options to always pass.
 546 # DEFAULT_EXTRA_OPTIONS is a set of options to pass if the testcase
 547 # doesn't specify any (with dg-option).
 548
 549 proc dg-runtest { testcases options default-extra-options } {
 550     global runtests
 551
 552     foreach testcase $testcases {
 553         # If we're only testing specific files and this isn't one of them, skip it.
 554         if {![runtest_file_p $runtests $testcase]} {
 555             continue
 556         }
 557         verbose "Testing [file tail [file dirname $testcase]]/[file tail $testcase]"
 558         dg-test $testcase $options ${default-extra-options}
 559     }
 560 }
 561 \f
 562 # dg-trim-dirname -- rip DIR_NAME out of FILE_NAME
 563 #
 564 # Syntax: dg-trim-dirname dir_name file_name
 565 # We need to go through this contortion in order to properly support
 566 # directory-names which might have embedded regexp special characters.
 567 #
 568 proc dg-trim-dirname { dir_name file_name } {
 569     set special_character "\[\?\+\-\.\(\)\$\|\]"
 570     regsub -all -- $special_character $dir_name {\\&} dir_name
 571     regsub "^$dir_name/?" $file_name "" file_name
 572     return $file_name
 573 }
 574
 575 # dg-test -- runs a new style DejaGnu test
 576 #
 577 # Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
 578 #
 579 # PROG is the full path name of the file to pass to the tool (eg: compiler).
 580 # TOOL_FLAGS is a set of options to always pass.
 581 # DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none.
 582
 583 #proc dg-test { prog tool_flags default_extra_tool_flags } {
 584 proc dg-test { args } {
 585     global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
 586     global errorCode errorInfo
 587     global tool
 588     global srcdir
 589     global host_triplet target_triplet
 590
 591     set keep 0
 592     set i 0
 593
 594     if { [string index [lindex $args 0] 0] eq "-" } {
 595         for { set i 0 } { $i < [llength $args] } { incr i } {
 596             if { [lindex $args $i] eq "--" } {
 597                 incr i
 598                 break
 599             } elseif { [lindex $args $i] eq "-keep-output" } {
 600                 set keep 1
 601             } elseif { [string index [lindex $args $i] 0] eq "-" } {
 602                 clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
 603                 return
 604             } else {
 605                 break
 606             }
 607         }
 608     }
 609
 610     if { $i + 3 != [llength $args] } {
 611         clone_output "ERROR: dg-test: missing arguments in call"
 612         return
 613     }
 614     set prog [lindex $args $i]
 615     set tool_flags [lindex $args [expr {$i + 1}]]
 616     set default_extra_tool_flags [lindex $args [expr {$i + 2}]]
 617
 618     set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
 619
 620     set name [dg-trim-dirname $srcdir $prog]
 621     # If we couldn't rip $srcdir out of `prog' then just do the best we can.
 622     # The point is to reduce the unnecessary noise in the logs.  Don't strip
 623     # out too much because different testcases with the same name can confuse
 624     # `test-tool'.
 625     if {[string match "/*" $name]} {
 626         set name "[file tail [file dirname $prog]]/[file tail $prog]"
 627     }
 628
 629     # We append the compilation flags, if any, to ensure that the test case
 630     # names are unique.
 631     if { $tool_flags ne "" } {
 632         set name "$name $tool_flags"
 633     }
 634
 635     # Process any embedded dg options in the testcase.
 636
 637     # Use "" for the second element of dg-do-what so we can tell if it's been
 638     # explicitly set to "S".
 639     set dg-do-what [list ${dg-do-what-default} "" P]
 640     set dg-excess-errors-flag 0
 641     set dg-messages ""
 642     set dg-extra-tool-flags $default_extra_tool_flags
 643     set dg-final-code ""
 644
 645     # `dg-output-text' is a list of two elements: pass/fail and text.
 646     # Leave second element off for now (indicates "don't perform test")
 647     set dg-output-text "P"
 648
 649     # Define our own "special function" `unknown' so we catch spelling errors.
 650     # But first rename the existing one so we can restore it afterwards.
 651     if { [info procs dg-save-unknown] == [list] } {
 652         rename unknown dg-save-unknown
 653         proc unknown { args } {
 654             return -code error "unknown dg option: $args"
 655         }
 656     }
 657
 658     set tmp [dg-get-options $prog]
 659     foreach op $tmp {
 660         verbose "Processing option: $op" 3
 661         set status [catch $op errmsg]
 662         if { $status != 0 } {
 663             if { 0 && [info exists errorInfo] } {
 664                 # This also prints a backtrace which will just confuse
 665                 # testcase writers, so it's disabled.
 666                 perror "$name: $errorInfo\n"
 667             } else {
 668                 perror "$name: $errmsg for \"$op\"\n"
 669             }
 670             perror "$name: $errmsg for \"$op\"" 0
 671             return
 672         }
 673     }
 674
 675     # Restore normal error handling.
 676     if { [info procs dg-save-unknown] != [list] } {
 677         rename unknown ""
 678         rename dg-save-unknown unknown
 679     }
 680
 681     # If we're not supposed to try this test on this target, we're done.
 682     if { [lindex ${dg-do-what} 1] eq "N" } {
 683         unsupported $name
 684         verbose "$name not supported on this target, skipping it" 3
 685         return
 686     }
 687
 688     # Run the tool and analyze the results.
 689     # The result of ${tool}-dg-test is in a bit of flux.
 690     # Currently it is the name of the output file (or "" if none).
 691     # If we need more than this it will grow into a list of things.
 692     # No intention is made (at this point) to preserve upward compatibility
 693     # (though at some point we'll have to).
 694
 695     set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"]
 696
 697     set comp_output [lindex $results 0]
 698     set output_file [lindex $results 1]
 699
 700     # Store an analysis of the messages produced.
 701     foreach i ${dg-messages} {
 702         verbose "Scanning for message: $i" 4
 703
 704         # Remove all error messages for the line [lindex $i 0]
 705         # in the source file.  If we find any, success!
 706         set line [lindex $i 0]
 707         set pattern [lindex $i 2]
 708         set comment [lindex $i 3]
 709         if {[regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output]} {
 710             set comp_output [string trimleft $comp_output]
 711             set ok pass
 712             set uhoh fail
 713         } else {
 714             set ok fail
 715             set uhoh pass
 716         }
 717
 718         # $line will either be a formatted line number or a number all by
 719         # itself.  Delete the formatting.
 720         scan $line ${dg-linenum-format} line
 721         switch -- [lindex $i 1] {
 722             "ERROR" {
 723                 lappend scan_results $ok \
 724                     "$name $comment (test for errors, line $line)"
 725             }
 726             "XERROR" {
 727                 lappend scan_results x$ok \
 728                     "$name $comment (test for errors, line $line)"
 729             }
 730             "WARNING" {
 731                 lappend scan_results $ok \
 732                     "$name $comment (test for warnings, line $line)"
 733             }
 734             "XWARNING" {
 735                 lappend scan_results x$ok \
 736                     "$name $comment (test for warnings, line $line)"
 737             }
 738             "BOGUS" {
 739                 lappend scan_results $uhoh \
 740                     "$name $comment (test for bogus messages, line $line)"
 741             }
 742             "XBOGUS" {
 743                 lappend scan_results x$uhoh \
 744                     "$name $comment (test for bogus messages, line $line)"
 745             }
 746             "BUILD" {
 747                 lappend scan_results $uhoh \
 748                     "$name $comment (test for build failure, line $line)"
 749             }
 750             "XBUILD" {
 751                 lappend scan_results x$uhoh \
 752                     "$name $comment (test for build failure, line $line)"
 753             }
 754             "EXEC" { }
 755             "XEXEC" { }
 756         }
 757     }
 758
 759     # Remove messages from the tool that we can ignore.
 760     set comp_output [prune_warnings $comp_output]
 761
 762     if { [info procs ${tool}-dg-prune] ne "" } {
 763         set comp_output [${tool}-dg-prune $target_triplet $comp_output]
 764         switch -glob -- $comp_output {
 765             "::untested::*" {
 766                 regsub "::untested::" $comp_output "" message
 767                 untested "$name: $message"
 768                 return
 769             }
 770             "::unresolved::*" {
 771                 regsub "::unresolved::" $comp_output "" message
 772                 unresolved "$name: $message"
 773                 return
 774             }
 775             "::unsupported::*" {
 776                 regsub "::unsupported::" $comp_output "" message
 777                 unsupported "$name: $message"
 778                 return
 779             }
 780         }
 781     }
 782
 783     # Report the results of the message analysis.
 784     if { [info exists scan_results] } {
 785         foreach { result message } $scan_results { $result $message }
 786         unset scan_results
 787     }
 788
 789     # See if someone forgot to delete the extra lines.
 790     regsub -all "\n+" $comp_output "\n" comp_output
 791     regsub "^\n+" $comp_output "" comp_output
 792
 793     # Don't do this if we're testing an interpreter.
 794     # FIXME: why?
 795     if { ${dg-interpreter-batch-mode} == 0 } {
 796         # Catch excess errors (new bugs or incomplete testcases).
 797         if {${dg-excess-errors-flag}} {
 798             setup_xfail "*-*-*"
 799         }
 800         if {$comp_output ne ""} {
 801             fail "$name (test for excess errors)"
 802             send_log "Excess errors:\n$comp_output\n"
 803         } else {
 804             pass "$name (test for excess errors)"
 805         }
 806     }
 807
 808     # Run the executable image if asked to do so.
 809     # FIXME: This is the only place where we assume a standard meaning to
 810     # the `keyword' argument of dg-do.  This could be cleaned up.
 811     if { [lindex ${dg-do-what} 0] eq "run" } {
 812         if {![file exists $output_file]} {
 813             unresolved "$name compilation failed to produce executable"
 814         } else {
 815             set status -1
 816             set result [${tool}_load $output_file]
 817             set status [lindex $result 0]
 818             set output [lindex $result 1]
 819             if { [lindex ${dg-do-what} 2] eq "F" } {
 820                 setup_xfail "*-*-*"
 821             }
 822             if { $status eq "pass" } {
 823                 pass "$name execution test"
 824                 verbose "Exec succeeded." 3
 825                 if { [llength ${dg-output-text}] > 1 } {
 826                     if { [lindex ${dg-output-text} 0] eq "F" } {
 827                         setup_xfail "*-*-*"
 828                     }
 829                     set texttmp [lindex ${dg-output-text} 1]
 830                     if { ![regexp -- $texttmp $output] } {
 831                         fail "$name output pattern test"
 832                         send_log "Output was:\n${output}\nShould match:\n$texttmp\n"
 833                         verbose "Failed test for output pattern $texttmp" 3
 834                     } else {
 835                         pass "$name output pattern test"
 836                         verbose "Passed test for output pattern $texttmp" 3
 837                     }
 838                     unset texttmp
 839                 }
 840             } elseif { $status eq "fail" } {
 841                 # It would be nice to get some info out of errorCode.
 842                 if {[info exists errorCode]} {
 843                     verbose "Exec failed, errorCode: $errorCode" 3
 844                 } else {
 845                     verbose "Exec failed, errorCode not defined!" 3
 846                 }
 847                 fail "$name execution test"
 848             } else {
 849                 $status "$name execution test"
 850             }
 851         }
 852     }
 853
 854     # Are there any further tests to perform?
 855     # Note that if the program has special run-time requirements, running
 856     # of the program can be delayed until here.  Ditto for other situations.
 857     # It would be a bit cumbersome though.
 858
 859     if {${dg-final-code} ne ""} {
 860         regsub -all {\\([{}])} ${dg-final-code} {\1} dg-final-code
 861         # Note that the use of `args' here makes this a varargs proc.
 862         proc dg-final-proc { args } ${dg-final-code}
 863         verbose "Running dg-final tests." 3
 864         verbose "dg-final-proc:\n[info body dg-final-proc]" 4
 865         if {[catch "dg-final-proc $prog" errmsg]} {
 866             perror "$name: error executing dg-final: $errmsg" 0
 867         }
 868     }
 869
 870     # Do some final clean up.
 871     # When testing an interpreter, we don't compile something and leave an
 872     # output file.
 873     if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
 874         catch "file delete -force -- $output_file"
 875     }
 876 }
 877 \f
 878 # Do any necessary cleanups.
 879 # This is called at the end to undo anything dg-init did (that needs undoing).
 880 #
 881 proc dg-finish { } {
 882     # Reset this in case caller wonders whether s/he should.
 883     global prms_id
 884     set prms_id 0
 885
 886     # The framework doesn't like to see any error remnants, so remove them.
 887     global errorInfo
 888     if {[info exists errorInfo]} {
 889         unset errorInfo
 890     }
 891
 892     # If the tool has a "finish" routine, call it.
 893     # There may be a bit of duplication (eg: resetting prms_id), leave it.
 894     # Let's keep these procs robust.
 895     global tool
 896     if {[info procs ${tool}_finish] ne ""} {
 897         ${tool}_finish
 898     }
 899 }