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