1 # `mfdg' - overrides parts of general purpose testcase driver.
2 # Copyright (C) 1994-2013 Free Software Foundation, Inc.
4 # This program is free software; you can redistribute it and/or modify
5 # it under the terms of the GNU General Public License as published by
6 # the Free Software Foundation; either version 3 of the License, or
7 # (at your option) any later version.
9 # This program is distributed in the hope that it will be useful,
10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 # GNU General Public License for more details.
14 # You should have received a copy of the GNU General Public License
15 # along with this program; see the file COPYING3. If not see
16 # <http://www.gnu.org/licenses/>.
19 # This is a modified excerpt of dejagnu/lib/dg.exp.
23 # We set LC_ALL and LANG to C so that we get the same error messages as expected.
27 # Many hosts now default to a non-ASCII C locale, however, so
28 # they can set a charset encoding here if they need.
29 if { [ishost "*-*-cygwin*"] } {
34 # dg-test -- runs a new style DejaGnu test
36 # Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
38 # PROG is the full path name of the file to pass to the tool (eg: compiler).
39 # TOOL_FLAGS is a set of options to always pass.
40 # DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none.
42 #proc dg-test { prog tool_flags default_extra_tool_flags } {
43 proc dg-test { args } {
44 global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
45 global errorCode errorInfo
46 global additional_prunes
48 global srcdir ;# eg: /calvin/dje/build/gcc/./testsuite/
49 global host_triplet target_triplet
53 set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
56 if { [string index [lindex $args 0] 0] == "-" } {
57 for { set i 0 } { $i < [llength $args] } { incr i } {
58 if { [lindex $args $i] == "--" } {
61 } elseif { [lindex $args $i] == "-keep-output" } {
63 } elseif { [string index [lindex $args $i] 0] == "-" } {
64 clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
72 if { $i + 3 != [llength $args] } {
73 clone_output "ERROR: dg-test: missing arguments in call"
76 set prog [lindex $args $i]
77 set tool_flags [lindex $args [expr $i + 1]]
78 set default_extra_tool_flags [lindex $args [expr $i + 2]]
80 set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
82 set name [dg-trim-dirname $srcdir $prog]
83 # If we couldn't rip $srcdir out of `prog' then just do the best we can.
84 # The point is to reduce the unnecessary noise in the logs. Don't strip
85 # out too much because different testcases with the same name can confuse
87 if [string match "/*" $name] {
88 set name "[file tail [file dirname $prog]]/[file tail $prog]"
91 if {$tool_flags != ""} {
92 append name " ($tool_flags)"
95 # Process any embedded dg options in the testcase.
97 # Use "" for the second element of dg-do-what so we can tell if it's been
98 # explicitly set to "S".
99 set dg-do-what [list ${dg-do-what-default} "" P]
100 set dg-excess-errors-flag 0
102 set dg-extra-tool-flags $default_extra_tool_flags
105 set additional_prunes ""
107 # `dg-output-text' is a list of two elements: pass/fail and text.
108 # Leave second element off for now (indicates "don't perform test")
109 set dg-output-text "P"
111 # Define our own "special function" `unknown' so we catch spelling errors.
112 # But first rename the existing one so we can restore it afterwards.
113 catch {rename dg-save-unknown ""}
114 rename unknown dg-save-unknown
115 proc unknown { args } {
116 return -code error "unknown dg option: $args"
119 set tmp [dg-get-options $prog]
121 verbose "Processing option: $op" 3
122 set status [catch "$op" errmsg]
123 if { $status != 0 } {
124 if { 0 && [info exists errorInfo] } {
125 # This also prints a backtrace which will just confuse
126 # testcase writers, so it's disabled.
127 perror "$name: $errorInfo\n"
129 perror "$name: $errmsg for \"$op\"\n"
131 # ??? The call to unresolved here is necessary to clear `errcnt'.
132 # What we really need is a proc like perror that doesn't set errcnt.
133 # It should also set exit_status to 1.
134 unresolved "$name: $errmsg for \"$op\""
139 # Restore normal error handling.
141 rename dg-save-unknown unknown
143 # If we're not supposed to try this test on this target, we're done.
144 if { [lindex ${dg-do-what} 1] == "N" } {
146 verbose "$name not supported on this target, skipping it" 3
150 # Run the tool and analyze the results.
151 # The result of ${tool}-dg-test is in a bit of flux.
152 # Currently it is the name of the output file (or "" if none).
153 # If we need more than this it will grow into a list of things.
154 # No intention is made (at this point) to preserve upward compatibility
155 # (though at some point we'll have to).
157 set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"];
159 set comp_output [lindex $results 0];
160 set output_file [lindex $results 1];
162 #send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
163 #send_user "\nold_dejagnu.exp: message = :$message:\n\n"
164 #send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n"
166 foreach i ${dg-messages} {
167 verbose "Scanning for message: $i" 4
169 # Remove all error messages for the line [lindex $i 0]
170 # in the source file. If we find any, success!
171 set line [lindex $i 0]
172 set pattern [lindex $i 2]
173 set comment [lindex $i 3]
174 #send_user "Before:\n$comp_output\n"
175 if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
176 set comp_output [string trimleft $comp_output]
183 #send_user "After:\n$comp_output\n"
185 # $line will either be a formatted line number or a number all by
186 # itself. Delete the formatting.
187 scan $line ${dg-linenum-format} line
188 switch [lindex $i 1] {
190 $ok "$name $comment (test for errors, line $line)"
193 x$ok "$name $comment (test for errors, line $line)"
196 $ok "$name $comment (test for warnings, line $line)"
199 x$ok "$name $comment (test for warnings, line $line)"
202 $uhoh "$name $comment (test for bogus messages, line $line)"
205 x$uhoh "$name $comment (test for bogus messages, line $line)"
208 $uhoh "$name $comment (test for build failure, line $line)"
211 x$uhoh "$name $comment (test for build failure, line $line)"
216 #send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
218 #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
220 # Remove messages from the tool that we can ignore.
221 #send_user "comp_output: $comp_output\n"
222 set comp_output [prune_warnings $comp_output]
224 if { [info proc ${tool}-dg-prune] != "" } {
225 set comp_output [${tool}-dg-prune $target_triplet $comp_output]
226 switch -glob $comp_output {
228 regsub "::untested::" $comp_output "" message
229 untested "$name: $message"
233 regsub "::unresolved::" $comp_output "" message
234 unresolved "$name: $message"
238 regsub "::unsupported::" $comp_output "" message
239 unsupported "$name: $message"
245 # See if someone forgot to delete the extra lines.
246 regsub -all "\n+" $comp_output "\n" comp_output
247 regsub "^\n+" $comp_output "" comp_output
248 #send_user "comp_output: $comp_output\n"
250 # Don't do this if we're testing an interpreter.
252 if { ${dg-interpreter-batch-mode} == 0 } {
253 # Catch excess errors (new bugs or incomplete testcases).
254 if ${dg-excess-errors-flag} {
257 if ![string match "" $comp_output] {
258 fail "$name (test for excess errors)"
259 send_log "Excess errors:\n$comp_output\n"
261 pass "$name (test for excess errors)"
265 # Run the executable image if asked to do so.
266 # FIXME: This is the only place where we assume a standard meaning to
267 # the `keyword' argument of dg-do. This could be cleaned up.
268 if { [lindex ${dg-do-what} 0] == "run" } {
269 if ![file exists $output_file] {
270 warning "$name compilation failed to produce executable"
273 for {set rep 0} {$rep < ${dg-repetitions}} {incr rep} {
274 # include repetition number in test name
275 if {$rep > 0} { set name "$testname (rerun $rep)" }
278 set result [${tool}_load $output_file]
279 set status [lindex $result 0];
280 set output [lindex $result 1];
281 #send_user "After exec, status: $status\n"
283 if { "$status" == "pass" } {
284 verbose "Exec succeeded." 3
285 } elseif { "$status" == "fail" } {
286 # It would be nice to get some info out of errorCode.
287 if [info exists errorCode] {
288 verbose "Exec failed, errorCode: $errorCode" 3
290 verbose "Exec failed, errorCode not defined!" 3
294 if { [lindex ${dg-do-what} 2] == "F" } {
295 # Instead of modelling this as an xfail (via setup_xfail),
296 # treat an expected crash as a success.
297 if { $status == "pass" } then { set status fail } else { set status pass }
299 } else { set testtype "execution" }
301 $status "$name $testtype test"
303 if { [llength ${dg-output-text}] > 1 } {
304 #send_user "${dg-output-text}\n"
305 if { [lindex ${dg-output-text} 0] == "F" } {
308 set texttmp [lindex ${dg-output-text} 1]
309 if { ![regexp $texttmp ${output}] } {
310 fail "$name output pattern test"
312 pass "$name output pattern test"
314 verbose -log "Output pattern $texttmp"
321 # Are there any further tests to perform?
322 # Note that if the program has special run-time requirements, running
323 # of the program can be delayed until here. Ditto for other situations.
324 # It would be a bit cumbersome though.
326 if ![string match ${dg-final-code} ""] {
327 regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
328 # Note that the use of `args' here makes this a varargs proc.
329 proc dg-final-proc { args } ${dg-final-code}
330 verbose "Running dg-final tests." 3
331 verbose "dg-final-proc:\n[info body dg-final-proc]" 4
332 if [catch "dg-final-proc $prog" errmsg] {
333 perror "$name: error executing dg-final: $errmsg"
334 # ??? The call to unresolved here is necessary to clear `errcnt'.
335 # What we really need is a proc like perror that doesn't set errcnt.
336 # It should also set exit_status to 1.
337 unresolved "$name: error executing dg-final: $errmsg"
341 # Do some final clean up.
342 # When testing an interpreter, we don't compile something and leave an
344 if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
345 catch "exec rm -f $output_file"
351 # Indicate that this test case is to be rerun several times. This
352 # is useful if it is nondeterministic. This applies to rerunning the
353 # test program only, not rebuilding it.
354 # The embedded format is "{ dg-repetitions N }", where N is the number
355 # of repetitions. It better be greater than zero.
357 proc dg-repetitions { line value } {
358 upvar dg-repetitions repetitions
359 set repetitions $value
363 # Prune any messages matching ARGS[1] (a regexp) from test output.
364 proc dg-prune-output { args } {
365 global additional_prunes
367 if { [llength $args] != 2 } {
368 error "[lindex $args 1]: need one argument"
372 lappend additional_prunes [lindex $args 1]
375 set additional_prunes ""