| # Copyright (C) 1997, 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, |
| # 2010 Free Software Foundation, Inc. |
| |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 3 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # You should have received a copy of the GNU General Public License |
| # along with GCC; see the file COPYING3. If not see |
| # <http://www.gnu.org/licenses/>. |
| |
| load_lib dg.exp |
| load_lib file-format.exp |
| load_lib target-supports.exp |
| load_lib target-supports-dg.exp |
| load_lib scanasm.exp |
| load_lib scanrtl.exp |
| load_lib scantree.exp |
| load_lib scanipa.exp |
| load_lib timeout.exp |
| load_lib timeout-dg.exp |
| load_lib prune.exp |
| load_lib libgloss.exp |
| load_lib target-libpath.exp |
| load_lib torture-options.exp |
| load_lib fortran-modules.exp |
| |
| # We set LC_ALL and LANG to C so that we get the same error messages as expected. |
| setenv LC_ALL C |
| setenv LANG C |
| |
| # Many hosts now default to a non-ASCII C locale, however, so |
| # they can set a charset encoding here if they need. |
| if { [ishost "*-*-cygwin*"] } { |
| setenv LC_ALL C.ASCII |
| setenv LANG C.ASCII |
| } |
| |
| global GCC_UNDER_TEST |
| if ![info exists GCC_UNDER_TEST] { |
| set GCC_UNDER_TEST "[find_gcc]" |
| } |
| |
| if [info exists TORTURE_OPTIONS] { |
| set DG_TORTURE_OPTIONS $TORTURE_OPTIONS |
| } else { |
| # It is theoretically beneficial to group all of the O2/O3 options together, |
| # as in many cases the compiler will generate identical executables for |
| # all of them--and the c-torture testsuite will skip testing identical |
| # executables multiple times. |
| # Also note that -finline-functions is explicitly included in one of the |
| # items below, even though -O3 is also specified, because some ports may |
| # choose to disable inlining functions by default, even when optimizing. |
| set DG_TORTURE_OPTIONS [list \ |
| { -O0 } \ |
| { -O1 } \ |
| { -O2 } \ |
| { -O3 -fomit-frame-pointer } \ |
| { -O3 -fomit-frame-pointer -funroll-loops } \ |
| { -O3 -fomit-frame-pointer -funroll-all-loops -finline-functions } \ |
| { -O3 -g } \ |
| { -Os } ] |
| } |
| |
| if [info exists ADDITIONAL_TORTURE_OPTIONS] { |
| set DG_TORTURE_OPTIONS \ |
| [concat $DG_TORTURE_OPTIONS $ADDITIONAL_TORTURE_OPTIONS] |
| } |
| |
| set LTO_TORTURE_OPTIONS "" |
| |
| # Some torture-options cause intermediate code output, unusable for |
| # testing using e.g. scan-assembler. In this variable are the options |
| # how to force it, when needed. |
| global gcc_force_conventional_output |
| set gcc_force_conventional_output "" |
| |
| if [check_effective_target_lto] { |
| # When having plugin test both slim and fat LTO and plugin/nonplugin |
| # path. |
| if [check_linker_plugin_available] { |
| set LTO_TORTURE_OPTIONS [list \ |
| { -O2 -flto -fno-use-linker-plugin -flto-partition=none } \ |
| { -O2 -flto -fuse-linker-plugin -fno-fat-lto-objects } |
| ] |
| set gcc_force_conventional_output "-ffat-lto-objects" |
| } else { |
| set LTO_TORTURE_OPTIONS [list \ |
| { -O2 -flto -flto-partition=none } \ |
| { -O2 -flto } |
| ] |
| } |
| } |
| |
| global orig_environment_saved |
| |
| # This file may be sourced, so don't override environment settings |
| # that have been previously setup. |
| if { $orig_environment_saved == 0 } { |
| append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] |
| set_ld_library_path_env_vars |
| } |
| |
| # Define gcc callbacks for dg.exp. |
| |
| proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } { |
| # Set up the compiler flags, based on what we're going to do. |
| |
| set options [list] |
| |
| # Tests should be able to use "dg-do repo". However, the dg test |
| # driver checks the argument to dg-do against a list of acceptable |
| # options, and "repo" is not among them. Therefore, we resort to |
| # this ugly approach. |
| if [string match "*-frepo*" $extra_tool_flags] then { |
| set do_what "repo" |
| } |
| |
| switch $do_what { |
| "preprocess" { |
| set compile_type "preprocess" |
| set output_file "[file rootname [file tail $prog]].i" |
| } |
| "compile" { |
| set compile_type "assembly" |
| set output_file "[file rootname [file tail $prog]].s" |
| } |
| "assemble" { |
| set compile_type "object" |
| set output_file "[file rootname [file tail $prog]].o" |
| } |
| "precompile" { |
| set compile_type "precompiled_header" |
| set output_file "[file tail $prog].gch" |
| } |
| "link" { |
| set compile_type "executable" |
| set output_file "[file rootname [file tail $prog]].exe" |
| # The following line is needed for targets like the i960 where |
| # the default output file is b.out. Sigh. |
| } |
| "repo" { |
| set compile_type "object" |
| set output_file "[file rootname [file tail $prog]].o" |
| } |
| "run" { |
| set compile_type "executable" |
| # FIXME: "./" is to cope with "." not being in $PATH. |
| # Should this be handled elsewhere? |
| # YES. |
| set output_file "./[file rootname [file tail $prog]].exe" |
| # This is the only place where we care if an executable was |
| # created or not. If it was, dg.exp will try to run it. |
| catch { remote_file build delete $output_file } |
| } |
| default { |
| perror "$do_what: not a valid dg-do keyword" |
| return "" |
| } |
| } |
| |
| # Let { dg-final { action } } force options as returned by an |
| # optional proc ${action}_required_options. |
| upvar 2 dg-final-code finalcode |
| foreach x [split $finalcode "\n"] { |
| set finalcmd [lindex $x 0] |
| if { [info procs ${finalcmd}_required_options] != "" } { |
| set req [${finalcmd}_required_options] |
| if { $req != "" } { |
| lappend extra_tool_flags $req |
| } |
| } |
| } |
| |
| if { $extra_tool_flags != "" } { |
| lappend options "additional_flags=$extra_tool_flags" |
| } |
| |
| set comp_output [$target_compile "$prog" "$output_file" "$compile_type" $options] |
| |
| # Look for an internal compiler error, which sometimes masks the fact |
| # that we didn't get an expected error message. XFAIL an ICE via |
| # dg-xfail-if and use { dg-prune-output ".*internal compiler error.*" } |
| # to avoid a second failure for excess errors. |
| if [string match "*internal compiler error*" $comp_output] { |
| upvar 2 name name |
| fail "$name (internal compiler error)" |
| } |
| |
| if { $do_what == "repo" } { |
| set object_file "$output_file" |
| set output_file "[file rootname [file tail $prog]].exe" |
| set comp_output \ |
| [ concat $comp_output \ |
| [$target_compile "$object_file" "$output_file" \ |
| "executable" $options] ] |
| } |
| |
| return [list $comp_output $output_file] |
| } |
| |
| proc gcc-dg-test { prog do_what extra_tool_flags } { |
| return [gcc-dg-test-1 gcc_target_compile $prog $do_what $extra_tool_flags] |
| } |
| |
| proc gcc-dg-prune { system text } { |
| global additional_prunes |
| |
| # Extra prune rules that will apply to tests defined in a .exp file. |
| # Always remember to clear it in .exp file after executed all tests. |
| global dg_runtest_extra_prunes |
| |
| set text [prune_gcc_output $text] |
| |
| foreach p "$additional_prunes $dg_runtest_extra_prunes" { |
| if { [string length $p] > 0 } { |
| # Following regexp matches a complete line containing $p. |
| regsub -all "(^|\n)\[^\n\]*$p\[^\n\]*" $text "" text |
| } |
| } |
| |
| # If we see "region xxx is full" then the testcase is too big for ram. |
| # This is tricky to deal with in a large testsuite like c-torture so |
| # deal with it here. Just mark the testcase as unsupported. |
| if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] { |
| # The format here is important. See dg.exp. |
| return "::unsupported::memory full" |
| } |
| |
| # Likewise, if we see ".text exceeds local store range" or |
| # similar. |
| if {[string match "spu-*" $system] && \ |
| [string match "*exceeds local store*" $text]} { |
| # The format here is important. See dg.exp. |
| return "::unsupported::memory full" |
| } |
| |
| return $text |
| } |
| |
| # Replace ${tool}_load with a wrapper to provide for an expected nonzero |
| # exit status. Multiple languages include this file so this handles them |
| # all, not just gcc. |
| if { [info procs ${tool}_load] != [list] \ |
| && [info procs saved_${tool}_load] == [list] } { |
| rename ${tool}_load saved_${tool}_load |
| |
| proc ${tool}_load { program args } { |
| global tool |
| global shouldfail |
| set result [eval [list saved_${tool}_load $program] $args] |
| if { $shouldfail != 0 } { |
| switch [lindex $result 0] { |
| "pass" { set status "fail" } |
| "fail" { set status "pass" } |
| } |
| set result [list $status [lindex $result 1]] |
| } |
| return $result |
| } |
| } |
| |
| # Utility routines. |
| |
| # |
| # search_for -- looks for a string match in a file |
| # |
| proc search_for { file pattern } { |
| set fd [open $file r] |
| while { [gets $fd cur_line]>=0 } { |
| if [string match "*$pattern*" $cur_line] then { |
| close $fd |
| return 1 |
| } |
| } |
| close $fd |
| return 0 |
| } |
| |
| # Modified dg-runtest that can cycle through a list of optimization options |
| # as c-torture does. |
| proc gcc-dg-runtest { testcases default-extra-flags } { |
| global runtests |
| |
| # Some callers set torture options themselves; don't override those. |
| set existing_torture_options [torture-options-exist] |
| if { $existing_torture_options == 0 } { |
| global DG_TORTURE_OPTIONS LTO_TORTURE_OPTIONS |
| torture-init |
| set-torture-options $DG_TORTURE_OPTIONS [list {}] $LTO_TORTURE_OPTIONS |
| } |
| dump-torture-options |
| |
| foreach test $testcases { |
| global torture_with_loops torture_without_loops |
| # If we're only testing specific files and this isn't one of |
| # them, skip it. |
| if ![runtest_file_p $runtests $test] { |
| continue |
| } |
| |
| # Look for a loop within the source code - if we don't find one, |
| # don't pass -funroll[-all]-loops. |
| if [expr [search_for $test "for*("]+[search_for $test "while*("]] { |
| set option_list $torture_with_loops |
| } else { |
| set option_list $torture_without_loops |
| } |
| |
| set nshort [file tail [file dirname $test]]/[file tail $test] |
| |
| foreach flags $option_list { |
| verbose "Testing $nshort, $flags" 1 |
| dg-test $test $flags ${default-extra-flags} |
| } |
| } |
| |
| if { $existing_torture_options == 0 } { |
| torture-finish |
| } |
| } |
| |
| proc gcc-dg-debug-runtest { target_compile trivial opt_opts testcases } { |
| global srcdir subdir |
| |
| if ![info exists DEBUG_TORTURE_OPTIONS] { |
| set DEBUG_TORTURE_OPTIONS "" |
| foreach type {-gdwarf-2 -gstabs -gstabs+ -gxcoff -gxcoff+ -gcoff} { |
| set comp_output [$target_compile \ |
| "$srcdir/$subdir/$trivial" "trivial.S" assembly \ |
| "additional_flags=$type"] |
| if { ! [string match "*: target system does not support the * debug format*" \ |
| $comp_output] } { |
| remove-build-file "trivial.S" |
| foreach level {1 "" 3} { |
| if { ($type == "-gdwarf-2") && ($level != "") } { |
| lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"] |
| foreach opt $opt_opts { |
| lappend DEBUG_TORTURE_OPTIONS \ |
| [list "${type}" "-g${level}" "$opt" ] |
| } |
| } else { |
| lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"] |
| foreach opt $opt_opts { |
| lappend DEBUG_TORTURE_OPTIONS \ |
| [list "${type}${level}" "$opt" ] |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| verbose -log "Using options $DEBUG_TORTURE_OPTIONS" |
| |
| global runtests |
| |
| foreach test $testcases { |
| # If we're only testing specific files and this isn't one of |
| # them, skip it. |
| if ![runtest_file_p $runtests $test] { |
| continue |
| } |
| |
| set nshort [file tail [file dirname $test]]/[file tail $test] |
| |
| foreach flags $DEBUG_TORTURE_OPTIONS { |
| set doit 1 |
| |
| # These tests check for information which may be deliberately |
| # suppressed at -g1. |
| if { ([string match {*/debug-[126].c} "$nshort"] \ |
| || [string match {*/enum-1.c} "$nshort"] \ |
| || [string match {*/enum-[12].C} "$nshort"]) \ |
| && ([string match "*1" [lindex "$flags" 0] ] |
| || [lindex "$flags" 1] == "-g1") } { |
| set doit 0 |
| } |
| |
| # High optimization can remove the variable whose existence is tested. |
| # Dwarf debugging with commentary (-dA) preserves the symbol name in the |
| # assembler output, but stabs debugging does not. |
| # http://gcc.gnu.org/ml/gcc-regression/2003-04/msg00095.html |
| if { [string match {*/debug-[12].c} "$nshort"] \ |
| && [string match "*O*" "$flags"] \ |
| && ( [string match "*coff*" "$flags"] \ |
| || [string match "*stabs*" "$flags"] ) } { |
| set doit 0 |
| } |
| |
| if { $doit } { |
| verbose -log "Testing $nshort, $flags" 1 |
| dg-test $test $flags "" |
| } |
| } |
| } |
| } |
| |
| # Prune any messages matching ARGS[1] (a regexp) from test output. |
| proc dg-prune-output { args } { |
| global additional_prunes |
| |
| if { [llength $args] != 2 } { |
| error "[lindex $args 1]: need one argument" |
| return |
| } |
| |
| lappend additional_prunes [lindex $args 1] |
| } |
| |
| # Remove files matching the pattern from the build machine. |
| proc remove-build-file { pat } { |
| verbose "remove-build-file `$pat'" 2 |
| set file_list "[glob -nocomplain $pat]" |
| verbose "remove-build-file `$file_list'" 2 |
| foreach output_file $file_list { |
| if [is_remote host] { |
| # Ensure the host knows the file is gone by deleting there |
| # first. |
| remote_file host delete $output_file |
| } |
| remote_file build delete $output_file |
| } |
| } |
| |
| # Remove runtime-generated profile file for the current test. |
| proc cleanup-profile-file { } { |
| remove-build-file "mon.out" |
| remove-build-file "gmon.out" |
| } |
| |
| # Remove compiler-generated coverage files for the current test. |
| proc cleanup-coverage-files { } { |
| set testcase [testname-for-summary] |
| # The name might include a list of options; extract the file name. |
| set testcase [lindex $testcase 0] |
| remove-build-file "[file rootname [file tail $testcase]].gc??" |
| |
| # Clean up coverage files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| remove-build-file "[file rootname [file tail $srcfile]].gc??" |
| } |
| } |
| } |
| |
| # Remove compiler-generated files from -repo for the current test. |
| proc cleanup-repo-files { } { |
| set testcase [testname-for-summary] |
| # The name might include a list of options; extract the file name. |
| set testcase [lindex $testcase 0] |
| remove-build-file "[file rootname [file tail $testcase]].o" |
| remove-build-file "[file rootname [file tail $testcase]].rpo" |
| |
| # Clean up files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| remove-build-file "[file rootname [file tail $srcfile]].o" |
| remove-build-file "[file rootname [file tail $srcfile]].rpo" |
| } |
| } |
| } |
| |
| # Remove compiler-generated RTL dump files for the current test. |
| # |
| # SUFFIX is the filename suffix pattern. |
| proc cleanup-rtl-dump { suffix } { |
| cleanup-dump "\[0-9\]\[0-9\]\[0-9\]r.$suffix" |
| } |
| |
| # Remove a specific tree dump file for the current test. |
| # |
| # SUFFIX is the tree dump file suffix pattern. |
| proc cleanup-tree-dump { suffix } { |
| cleanup-dump "\[0-9\]\[0-9\]\[0-9\]t.$suffix" |
| } |
| |
| # Remove a specific ipa dump file for the current test. |
| # |
| # SUFFIX is the ipa dump file suffix pattern. |
| proc cleanup-ipa-dump { suffix } { |
| cleanup-dump "\[0-9\]\[0-9\]\[0-9\]i.$suffix" |
| } |
| |
| # Remove a stack usage file for the current test. |
| proc cleanup-stack-usage { } { |
| set testcase [testname-for-summary] |
| # The name might include a list of options; extract the file name. |
| set testcase [lindex $testcase 0] |
| remove-build-file "[file rootname [file tail $testcase]].su" |
| |
| # Clean up files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| remove-build-file "[file rootname [file tail $srcfile]].su" |
| } |
| } |
| } |
| |
| # Remove an Ada spec file for the current test. |
| proc cleanup-ada-spec { } { |
| set testcase [testname-for-summary] |
| remove-build-file "[get_ada_spec_filename $testcase]" |
| |
| # Clean up files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| remove-build-file "[get_ada_spec_filename $srcfile]" |
| } |
| } |
| } |
| |
| # Remove all dump files with the provided suffix. |
| proc cleanup-dump { suffix } { |
| set testcase [testname-for-summary] |
| # The name might include a list of options; extract the file name. |
| set src [file tail [lindex $testcase 0]] |
| remove-build-file "[file tail $src].$suffix" |
| remove-build-file "[file rootname [file tail $src]].exe.$suffix" |
| remove-build-file "[file rootname [file tail $src]].exe.ltrans\[0-9\]*.$suffix" |
| # -fcompare-debug dumps |
| remove-build-file "[file tail $src].gk.$suffix" |
| |
| # Clean up dump files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| remove-build-file "[file tail $srcfile].$suffix" |
| remove-build-file "[file rootname [file tail $srcfile]].exe.$suffix" |
| remove-build-file "[file rootname [file tail $srcfile]].exe.ltrans\[0-9\]*.$suffix" |
| # -fcompare-debug dumps |
| remove-build-file "[file tail $srcfile].gk.$suffix" |
| } |
| } |
| } |
| |
| # Remove files kept by --save-temps for the current test. |
| # |
| # Currently this is only .i, .ii, .s and .o files, but more can be added |
| # if there are tests generating them. |
| # ARGS is a list of suffixes to NOT delete. |
| proc cleanup-saved-temps { args } { |
| global additional_sources |
| set suffixes {} |
| |
| # add the to-be-kept suffixes |
| foreach suffix {".ii" ".i" ".s" ".o" ".gkd"} { |
| if {[lsearch $args $suffix] < 0} { |
| lappend suffixes $suffix |
| } |
| } |
| |
| set testcase [testname-for-summary] |
| # The name might include a list of options; extract the file name. |
| set testcase [lindex $testcase 0] |
| foreach suffix $suffixes { |
| remove-build-file "[file rootname [file tail $testcase]]$suffix" |
| # -fcompare-debug dumps |
| remove-build-file "[file rootname [file tail $testcase]].gk$suffix" |
| } |
| |
| # Clean up saved temp files for additional source files. |
| if [info exists additional_sources] { |
| foreach srcfile $additional_sources { |
| foreach suffix $suffixes { |
| remove-build-file "[file rootname [file tail $srcfile]]$suffix" |
| # -fcompare-debug dumps |
| remove-build-file "[file rootname [file tail $srcfile]].gk$suffix" |
| } |
| } |
| } |
| } |
| |
| # Scan Fortran modules for a given regexp. |
| # |
| # Argument 0 is the module name |
| # Argument 1 is the regexp to match |
| proc scan-module { args } { |
| set modfilename [string tolower [lindex $args 0]].mod |
| set fd [open $modfilename r] |
| set text [read $fd] |
| close $fd |
| |
| set testcase [testname-for-summary] |
| if [regexp -- [lindex $args 1] $text] { |
| pass "$testcase scan-module [lindex $args 1]" |
| } else { |
| fail "$testcase scan-module [lindex $args 1]" |
| } |
| } |
| |
| # Scan Fortran modules for absence of a given regexp. |
| # |
| # Argument 0 is the module name |
| # Argument 1 is the regexp to match |
| proc scan-module-absence { args } { |
| set modfilename [string tolower [lindex $args 0]].mod |
| set fd [open $modfilename r] |
| set text [read $fd] |
| close $fd |
| |
| set testcase [testname-for-summary] |
| if [regexp -- [lindex $args 1] $text] { |
| fail "$testcase scan-module [lindex $args 1]" |
| } else { |
| pass "$testcase scan-module [lindex $args 1]" |
| } |
| } |
| |
| # Verify that the compiler output file exists, invoked via dg-final. |
| proc output-exists { args } { |
| # Process an optional target or xfail list. |
| if { [llength $args] >= 1 } { |
| switch [dg-process-target [lindex $args 0]] { |
| "S" { } |
| "N" { return } |
| "F" { setup_xfail "*-*-*" } |
| "P" { } |
| } |
| } |
| |
| set testcase [testname-for-summary] |
| # Access variable from gcc-dg-test-1. |
| upvar 2 output_file output_file |
| |
| if [file exists $output_file] { |
| pass "$testcase output-exists $output_file" |
| } else { |
| fail "$testcase output-exists $output_file" |
| } |
| } |
| |
| # Verify that the compiler output file does not exist, invoked via dg-final. |
| proc output-exists-not { args } { |
| # Process an optional target or xfail list. |
| if { [llength $args] >= 1 } { |
| switch [dg-process-target [lindex $args 0]] { |
| "S" { } |
| "N" { return } |
| "F" { setup_xfail "*-*-*" } |
| "P" { } |
| } |
| } |
| |
| set testcase [testname-for-summary] |
| # Access variable from gcc-dg-test-1. |
| upvar 2 output_file output_file |
| |
| if [file exists $output_file] { |
| fail "$testcase output-exists-not $output_file" |
| } else { |
| pass "$testcase output-exists-not $output_file" |
| } |
| } |
| |
| # We need to make sure that additional_* are cleared out after every |
| # test. It is not enough to clear them out *before* the next test run |
| # because gcc-target-compile gets run directly from some .exp files |
| # (outside of any test). (Those uses should eventually be eliminated.) |
| |
| # Because the DG framework doesn't provide a hook that is run at the |
| # end of a test, we must replace dg-test with a wrapper. |
| |
| if { [info procs saved-dg-test] == [list] } { |
| rename dg-test saved-dg-test |
| |
| proc dg-test { args } { |
| global additional_files |
| global additional_sources |
| global additional_prunes |
| global errorInfo |
| global compiler_conditional_xfail_data |
| global shouldfail |
| global testname_with_flags |
| |
| if { [ catch { eval saved-dg-test $args } errmsg ] } { |
| set saved_info $errorInfo |
| set additional_files "" |
| set additional_sources "" |
| set additional_prunes "" |
| set shouldfail 0 |
| if [info exists compiler_conditional_xfail_data] { |
| unset compiler_conditional_xfail_data |
| } |
| if [info exists testname_with_flags] { |
| unset testname_with_flags |
| } |
| unset_timeout_vars |
| error $errmsg $saved_info |
| } |
| set additional_files "" |
| set additional_sources "" |
| set additional_prunes "" |
| set shouldfail 0 |
| unset_timeout_vars |
| if [info exists compiler_conditional_xfail_data] { |
| unset compiler_conditional_xfail_data |
| } |
| if [info exists testname_with_flags] { |
| unset testname_with_flags |
| } |
| } |
| } |
| |
| if { [info procs saved-dg-warning] == [list] \ |
| && [info exists gcc_warning_prefix] } { |
| rename dg-warning saved-dg-warning |
| |
| proc dg-warning { args } { |
| # Make this variable available here and to the saved proc. |
| upvar dg-messages dg-messages |
| global gcc_warning_prefix |
| |
| process-message saved-dg-warning "$gcc_warning_prefix" "$args" |
| } |
| } |
| |
| if { [info procs saved-dg-error] == [list] \ |
| && [info exists gcc_error_prefix] } { |
| rename dg-error saved-dg-error |
| |
| proc dg-error { args } { |
| # Make this variable available here and to the saved proc. |
| upvar dg-messages dg-messages |
| global gcc_error_prefix |
| |
| process-message saved-dg-error "$gcc_error_prefix" "$args" |
| } |
| |
| # Override dg-bogus at the same time. It doesn't handle a prefix |
| # but its expression should include a column number. Otherwise the |
| # line number can match the column number for other messages, leading |
| # to insanity. |
| rename dg-bogus saved-dg-bogus |
| |
| proc dg-bogus { args } { |
| upvar dg-messages dg-messages |
| process-message saved-dg-bogus "" $args |
| } |
| } |
| |
| # Modify the regular expression saved by a DejaGnu message directive to |
| # include a prefix and to force the expression to match a single line. |
| # MSGPROC is the procedure to call. |
| # MSGPREFIX is the prefix to prepend. |
| # DGARGS is the original argument list. |
| |
| proc process-message { msgproc msgprefix dgargs } { |
| upvar dg-messages dg-messages |
| |
| # Process the dg- directive, including adding the regular expression |
| # to the new message entry in dg-messages. |
| set msgcnt [llength ${dg-messages}] |
| eval $msgproc $dgargs |
| |
| # If the target expression wasn't satisfied there is no new message. |
| if { [llength ${dg-messages}] == $msgcnt } { |
| return; |
| } |
| |
| # Get the entry for the new message. Prepend the message prefix to |
| # the regular expression and make it match a single line. |
| set newentry [lindex ${dg-messages} end] |
| set expmsg [lindex $newentry 2] |
| |
| # Handle column numbers from the specified expression (if there is |
| # one) and set up the search expression that will be used by DejaGnu. |
| if [regexp "^(\[0-9\]+):" $expmsg "" column] { |
| # The expression in the directive included a column number. |
| # Remove "COLUMN:" from the original expression and move it |
| # to the proper place in the search expression. |
| regsub "^\[0-9\]+:" $expmsg "" expmsg |
| set expmsg "$column: $msgprefix\[^\n\]*$expmsg" |
| } elseif [string match "" [lindex $newentry 0]] { |
| # The specified line number is 0; don't expect a column number. |
| set expmsg "$msgprefix\[^\n\]*$expmsg" |
| } else { |
| # There is no column number in the search expression, but we |
| # should expect one in the message itself. |
| set expmsg "\[0-9\]+: $msgprefix\[^\n\]*$expmsg" |
| } |
| |
| set newentry [lreplace $newentry 2 2 $expmsg] |
| set dg-messages [lreplace ${dg-messages} end end $newentry] |
| verbose "process-message:\n${dg-messages}" 2 |
| } |
| |
| # Look for messages that don't have standard prefixes. |
| |
| proc dg-message { args } { |
| upvar dg-messages dg-messages |
| process-message saved-dg-warning "" $args |
| } |
| |
| # Check the existence of a gdb in the path, and return true if there |
| # is one. |
| # |
| # Set env(GDB_FOR_GCC_TESTING) accordingly. |
| |
| proc gdb-exists { args } { |
| if ![info exists ::env(GDB_FOR_GCC_TESTING)] { |
| global GDB |
| if ![info exists ::env(GDB_FOR_GCC_TESTING)] { |
| if [info exists GDB] { |
| setenv GDB_FOR_GCC_TESTING "$GDB" |
| } else { |
| setenv GDB_FOR_GCC_TESTING "[transform gdb]" |
| } |
| } |
| } |
| if { [which $::env(GDB_FOR_GCC_TESTING)] != 0 } { |
| return 1; |
| } |
| return 0; |
| } |
| |
| set additional_prunes "" |
| set dg_runtest_extra_prunes "" |