gcc-dg.exp

用于进行gcc测试

    # 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 {
	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 { } {
    # This assumes that we are two frames down from dg-test or some other proc
    # that stores the filename of the testcase in a local variable "name".
    # A cleaner solution would require a new DejaGnu release.
    upvar 2 name testcase
    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 { } {
    # This assumes that we are two frames down from dg-test or some other proc
    # that stores the filename of the testcase in a local variable "name".
    # A cleaner solution would require a new DejaGnu release.
    upvar 2 name testcase
    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 all dump files with the provided suffix.
proc cleanup-dump { suffix } {
    # This assumes that we are three frames down from dg-test or some other
    # proc that stores the filename of the testcase in a local variable
    # "name".  A cleaner solution would require a new DejaGnu release.
    upvar 3 name testcase
    # 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"

    # 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 files kept by --save-temps for the current test.
#
# Currently this is only .i, .ii and .s files, but more can be added
# if there are tests generating them.
proc cleanup-saved-temps { } {
    global additional_sources

    # This assumes that we are two frames down from dg-test or some other proc
    # that stores the filename of the testcase in a local variable "name".
    # A cleaner solution would require a new DejaGnu release.
    upvar 2 name testcase
    remove-build-file "[file rootname [file tail $testcase]].ii"
    remove-build-file "[file rootname [file tail $testcase]].i"

    # Clean up saved temp files for additional source files.
    if [info exists additional_sources] {
	foreach srcfile $additional_sources {
            remove-build-file "[file rootname [file tail $srcfile]].ii"
            remove-build-file "[file rootname [file tail $srcfile]].i"
	}
    }
}

# Remove files for specified Fortran modules.
proc cleanup-modules { modlist } {
    foreach modname $modlist {
	remove-build-file [string tolower $modname].mod
    }
}

# 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

    upvar 2 name testcase
    if [regexp -- [lindex $args 1] $text] {
      pass "$testcase scan-module [lindex $args 1]"
    } else {
      fail "$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" { }
	}
    }

    # Access variables from gcc-dg-test-1.
    upvar 2 name testcase
    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" { }
	}
    }

    # Access variables from gcc-dg-test-1.
    upvar 2 name testcase
    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

	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
	    }
	    error $errmsg $saved_info
	}
	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 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"
    }
}

# 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}]
    catch { eval $msgproc $dgargs }

    # If the target expression wasn't satisfied there is no new message.
    if { [llength ${dg-messages}] == $msgcnt } {
	return;
    }

    # 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]
    set expmsg "$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
}

set additional_prunes ""