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.
24 # dg-test -- runs a new style DejaGnu test
26 # Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
28 # PROG is the full path name of the file to pass to the tool (eg: compiler).
29 # TOOL_FLAGS is a set of options to always pass.
30 # DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none.
32 #proc dg-test { prog tool_flags default_extra_tool_flags } {
33 proc dg-test { args } {
34 global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
35 global errorCode errorInfo
36 global additional_prunes
38 global srcdir ;# eg: /calvin/dje/build/gcc/./testsuite/
39 global host_triplet target_triplet
43 set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
46 if { [string index [lindex $args 0] 0] == "-" } {
47 for { set i 0 } { $i < [llength $args] } { incr i } {
48 if { [lindex $args $i] == "--" } {
51 } elseif { [lindex $args $i] == "-keep-output" } {
53 } elseif { [string index [lindex $args $i] 0] == "-" } {
54 clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
62 if { $i + 3 != [llength $args] } {
63 clone_output "ERROR: dg-test: missing arguments in call"
66 set prog [lindex $args $i]
67 set tool_flags [lindex $args [expr $i + 1]]
68 set default_extra_tool_flags [lindex $args [expr $i + 2]]
70 set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
72 set name [dg-trim-dirname $srcdir $prog]
73 # If we couldn't rip $srcdir out of `prog
' then just do the best we can.
74 # The point is to reduce the unnecessary noise in the logs. Don't
strip
75 # out too much because different testcases with the same
name can confuse
77 if [string match "/*" $name] {
78 set name "[file tail [file dirname $prog]]/[file tail $prog]"
81 if {$tool_flags != ""} {
82 append name " ($tool_flags)"
85 # Process any embedded dg options in the testcase.
87 # Use "" for the second element of dg-do-what so we can tell if it's been
88 # explicitly
set to
"S".
89 set dg
-do-what
[list $
{dg
-do-what
-default
} "" P]
90 set dg
-excess
-errors
-flag
0
92 set dg
-extra
-tool
-flags $default_extra_tool_flags
95 set additional_prunes
""
97 # `dg
-output
-text' is a list of two elements: pass/fail and text.
98 # Leave second element off for now (indicates "don't perform test
")
99 set dg
-output
-text "P"
101 #
Define our own
"special function" `unknown' so we catch spelling errors.
102 # But first
rename the existing one so we can restore it afterwards.
103 catch
{rename dg
-save
-unknown
""}
104 rename unknown dg
-save
-unknown
105 proc unknown
{ args } {
106 return -code error
"unknown dg option: $args"
109 set tmp
[dg
-get-options $prog
]
111 verbose
"Processing option: $op" 3
112 set status [catch
"$op" errmsg]
113 if { $
status != 0 } {
114 if { 0 && [info exists errorInfo
] } {
115 # This also prints a backtrace which will just confuse
116 # testcase writers
, so it
's disabled.
117 perror "$name: $errorInfo\n"
119 perror "$name: $errmsg for \"$op\"\n"
121 # ??? The call to unresolved here is necessary to clear `errcnt'.
122 # What we really need is a proc like perror that doesn
't set errcnt.
123 # It should also set exit_status to 1.
124 unresolved "$name: $errmsg for \"$op\""
129 # Restore normal error handling.
131 rename dg-save-unknown unknown
133 # If we're not supposed to try this test
on this target
, we
're done.
134 if { [lindex ${dg-do-what} 1] == "N" } {
136 verbose "$name not supported on this target, skipping it" 3
140 # Run the tool and analyze the results.
141 # The result of ${tool}-dg-test is in a bit of flux.
142 # Currently it is the name of the output file (or "" if none).
143 # If we need more than this it will grow into a list of things.
144 # No intention is made (at this point) to preserve upward compatibility
145 # (though at some point we'll have to
).
147 set results
[$
{tool
}-dg
-test $prog
[lindex $
{dg
-do-what
} 0] "$tool_flags ${dg-extra-tool-flags}"];
149 set comp_output
[lindex $results
0];
150 set output_file
[lindex $results
1];
152 #send_user
"\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
153 #send_user
"\nold_dejagnu.exp: message = :$message:\n\n"
154 #send_user
"\nold_dejagnu.exp: message length = [llength $message]\n\n"
156 foreach i $
{dg
-messages
} {
157 verbose
"Scanning for message: $i" 4
159 # Remove all error messages
for the line
[lindex $i
0]
160 # in the source file.
If we find
any, success
!
161 set line
[lindex $i
0]
162 set pattern
[lindex $i
2]
163 set comment
[lindex $i
3]
164 #send_user
"Before:\n$comp_output\n"
165 if [regsub
-all
"(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
166 set comp_output
[string trimleft $comp_output
]
173 #send_user
"After:\n$comp_output\n"
175 # $line will either be a formatted line number or a number all by
176 # itself.
Delete the formatting.
177 scan $line $
{dg
-linenum-format
} line
178 switch [lindex $i
1] {
180 $ok
"$name $comment (test for errors, line $line)"
183 x$ok
"$name $comment (test for errors, line $line)"
186 $ok
"$name $comment (test for warnings, line $line)"
189 x$ok
"$name $comment (test for warnings, line $line)"
192 $uhoh
"$name $comment (test for bogus messages, line $line)"
195 x$uhoh
"$name $comment (test for bogus messages, line $line)"
198 $uhoh
"$name $comment (test for build failure, line $line)"
201 x$uhoh
"$name $comment (test for build failure, line $line)"
206 #send_user
"\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
208 #send_user
"\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
210 # Remove messages from the tool that we can ignore.
211 #send_user
"comp_output: $comp_output\n"
212 set comp_output
[prune_warnings $comp_output
]
214 if { [info proc $
{tool
}-dg
-prune
] != "" } {
215 set comp_output
[$
{tool
}-dg
-prune $target_triplet $comp_output
]
216 switch -glob $comp_output
{
218 regsub
"::untested::" $comp_output "" message
219 untested
"$name: $message"
223 regsub
"::unresolved::" $comp_output "" message
224 unresolved
"$name: $message"
228 regsub
"::unsupported::" $comp_output "" message
229 unsupported
"$name: $message"
235 # See
if someone forgot to
delete the extra lines.
236 regsub
-all
"\n+" $comp_output "\n" comp_output
237 regsub
"^\n+" $comp_output "" comp_output
238 #send_user
"comp_output: $comp_output\n"
240 # Don
't do this if we're testing an interpreter.
242 if { $
{dg
-interpreter
-batch
-mode} == 0 } {
243 # Catch excess errors
(new bugs or incomplete testcases
).
244 if $
{dg
-excess
-errors
-flag
} {
247 if ![string match
"" $comp_output] {
248 fail
"$name (test for excess errors)"
249 send_log
"Excess errors:\n$comp_output\n"
251 pass
"$name (test for excess errors)"
255 # Run the executable image
if asked to
do so.
256 # FIXME
: This is the only place where we assume a standard meaning to
257 # the `keyword
' argument of dg-do. This could be cleaned up.
258 if { [lindex ${dg-do-what} 0] == "run" } {
259 if ![file exists $output_file] {
260 warning "$name compilation failed to produce executable"
263 for {set rep 0} {$rep < ${dg-repetitions}} {incr rep} {
264 # include repetition number in test name
265 if {$rep > 0} { set name "$testname (rerun $rep)" }
268 set result [${tool}_load $output_file]
269 set status [lindex $result 0];
270 set output [lindex $result 1];
271 #send_user "After exec, status: $status\n"
273 if { "$status" == "pass" } {
274 verbose "Exec succeeded." 3
275 } elseif { "$status" == "fail" } {
276 # It would be nice to get some info out of errorCode.
277 if [info exists errorCode] {
278 verbose "Exec failed, errorCode: $errorCode" 3
280 verbose "Exec failed, errorCode not defined!" 3
284 if { [lindex ${dg-do-what} 2] == "F" } {
285 # Instead of modelling this as an xfail (via setup_xfail),
286 # treat an expected crash as a success.
287 if { $status == "pass" } then { set status fail } else { set status pass }
289 } else { set testtype "execution" }
291 $status "$name $testtype test"
293 if { [llength ${dg-output-text}] > 1 } {
294 #send_user "${dg-output-text}\n"
295 if { [lindex ${dg-output-text} 0] == "F" } {
298 set texttmp [lindex ${dg-output-text} 1]
299 if { ![regexp $texttmp ${output}] } {
300 fail "$name output pattern test"
302 pass "$name output pattern test"
304 verbose -log "Output pattern $texttmp"
311 # Are there any further tests to perform?
312 # Note that if the program has special run-time requirements, running
313 # of the program can be delayed until here. Ditto for other situations.
314 # It would be a bit cumbersome though.
316 if ![string match ${dg-final-code} ""] {
317 regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
318 # Note that the use of `args' here makes this a varargs proc.
319 proc dg
-final
-proc
{ args } $
{dg
-final
-code
}
320 verbose
"Running dg-final tests." 3
321 verbose
"dg-final-proc:\n[info body dg-final-proc]" 4
322 if [catch
"dg-final-proc $prog" errmsg] {
323 perror
"$name: error executing dg-final: $errmsg"
324 # ??? The
call to unresolved here is necessary to clear `errcnt
'.
325 # What we really need is a proc like perror that doesn't
set errcnt.
326 # It should also
set exit_status to
1.
327 unresolved
"$name: error executing dg-final: $errmsg"
331 #
Do some final clean up.
332 # When testing an interpreter
, we don
't compile something and leave an
334 if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
335 catch "exec rm -f $output_file"
341 # Indicate that this test case is to be rerun several times. This
342 # is useful if it is nondeterministic. This applies to rerunning the
343 # test program only, not rebuilding it.
344 # The embedded format is "{ dg-repetitions N }", where N is the number
345 # of repetitions. It better be greater than zero.
347 proc dg-repetitions { line value } {
348 upvar dg-repetitions repetitions
349 set repetitions $value
353 # Prune any messages matching ARGS[1] (a regexp) from test output.
354 proc dg-prune-output { args } {
355 global additional_prunes
357 if { [llength $args] != 2 } {
358 error "[lindex $args 1]: need one argument"
362 lappend additional_prunes [lindex $args 1]
365 set additional_prunes ""