1 # `mfdg
' - overrides parts of general purpose testcase driver.
2 # Copyright (C) 1994 - 2001, 2003 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 2 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; if not, write to the Free Software
16 # Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
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
37 global srcdir ;# eg: /calvin/dje/build/gcc/./testsuite/
38 global host_triplet target_triplet
42 set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
44 set dg-timeout 0 ;# likewise by { dg-timeout 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 # `dg
-output
-text' is a list of two elements: pass/fail and text.
96 # Leave second element off for now (indicates "don't perform test
")
97 set dg
-output
-text "P"
99 #
Define our own
"special function" `unknown' so we catch spelling errors.
100 # But first
rename the existing one so we can restore it afterwards.
101 catch
{rename dg
-save
-unknown
""}
102 rename unknown dg
-save
-unknown
103 proc unknown
{ args } {
104 return -code error
"unknown dg option: $args"
107 set tmp
[dg
-get-options $prog
]
109 verbose
"Processing option: $op" 3
110 set status [catch
"$op" errmsg]
111 if { $
status != 0 } {
112 if { 0 && [info exists errorInfo
] } {
113 # This also prints a backtrace which will just confuse
114 # testcase writers
, so it
's disabled.
115 perror "$name: $errorInfo\n"
117 perror "$name: $errmsg for \"$op\"\n"
119 # ??? The call to unresolved here is necessary to clear `errcnt'.
120 # What we really need is a proc like perror that doesn
't set errcnt.
121 # It should also set exit_status to 1.
122 unresolved "$name: $errmsg for \"$op\""
127 # Restore normal error handling.
129 rename dg-save-unknown unknown
131 # If we're not supposed to try this test
on this target
, we
're done.
132 if { [lindex ${dg-do-what} 1] == "N" } {
134 verbose "$name not supported on this target, skipping it" 3
138 # Run the tool and analyze the results.
139 # The result of ${tool}-dg-test is in a bit of flux.
140 # Currently it is the name of the output file (or "" if none).
141 # If we need more than this it will grow into a list of things.
142 # No intention is made (at this point) to preserve upward compatibility
143 # (though at some point we'll have to
).
145 set results
[$
{tool
}-dg
-test $prog
[lindex $
{dg
-do-what
} 0] "$tool_flags ${dg-extra-tool-flags}"];
147 set comp_output
[lindex $results
0];
148 set output_file
[lindex $results
1];
150 #send_user
"\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
151 #send_user
"\nold_dejagnu.exp: message = :$message:\n\n"
152 #send_user
"\nold_dejagnu.exp: message length = [llength $message]\n\n"
154 foreach i $
{dg
-messages
} {
155 verbose
"Scanning for message: $i" 4
157 # Remove all error messages
for the line
[lindex $i
0]
158 # in the source file.
If we find
any, success
!
159 set line
[lindex $i
0]
160 set pattern
[lindex $i
2]
161 set comment
[lindex $i
3]
162 #send_user
"Before:\n$comp_output\n"
163 if [regsub
-all
"(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
164 set comp_output
[string trimleft $comp_output
]
171 #send_user
"After:\n$comp_output\n"
173 # $line will either be a formatted line number or a number all by
174 # itself.
Delete the formatting.
175 scan $line $
{dg
-linenum-format
} line
176 switch [lindex $i
1] {
178 $ok
"$name $comment (test for errors, line $line)"
181 x$ok
"$name $comment (test for errors, line $line)"
184 $ok
"$name $comment (test for warnings, line $line)"
187 x$ok
"$name $comment (test for warnings, line $line)"
190 $uhoh
"$name $comment (test for bogus messages, line $line)"
193 x$uhoh
"$name $comment (test for bogus messages, line $line)"
196 $uhoh
"$name $comment (test for build failure, line $line)"
199 x$uhoh
"$name $comment (test for build failure, line $line)"
204 #send_user
"\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
206 #send_user
"\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
208 # Remove messages from the tool that we can ignore.
209 #send_user
"comp_output: $comp_output\n"
210 set comp_output
[prune_warnings $comp_output
]
212 if { [info proc $
{tool
}-dg
-prune
] != "" } {
213 set comp_output
[$
{tool
}-dg
-prune $target_triplet $comp_output
]
214 switch -glob $comp_output
{
216 regsub
"::untested::" $comp_output "" message
217 untested
"$name: $message"
221 regsub
"::unresolved::" $comp_output "" message
222 unresolved
"$name: $message"
226 regsub
"::unsupported::" $comp_output "" message
227 unsupported
"$name: $message"
233 # See
if someone forgot to
delete the extra lines.
234 regsub
-all
"\n+" $comp_output "\n" comp_output
235 regsub
"^\n+" $comp_output "" comp_output
236 #send_user
"comp_output: $comp_output\n"
238 # Don
't do this if we're testing an interpreter.
240 if { $
{dg
-interpreter
-batch
-mode} == 0 } {
241 # Catch excess errors
(new bugs or incomplete testcases
).
242 if $
{dg
-excess
-errors
-flag
} {
245 if ![string match
"" $comp_output] {
246 fail
"$name (test for excess errors)"
247 send_log
"Excess errors:\n$comp_output\n"
249 pass
"$name (test for excess errors)"
253 # Run the executable image
if asked to
do so.
254 # FIXME
: This is the only place where we assume a standard meaning to
255 # the `keyword
' argument of dg-do. This could be cleaned up.
256 if { [lindex ${dg-do-what} 0] == "run" } {
257 if ![file exists $output_file] {
258 warning "$name compilation failed to produce executable"
261 for {set rep 0} {$rep < ${dg-repetitions}} {incr rep} {
262 # include repetition number in test name
263 if {$rep > 0} { set name "$testname (rerun $rep)" }
266 set result [${tool}_load $output_file]
267 set status [lindex $result 0];
268 set output [lindex $result 1];
269 #send_user "After exec, status: $status\n"
271 if { "$status" == "pass" } {
272 verbose "Exec succeeded." 3
273 } elseif { "$status" == "fail" } {
274 # It would be nice to get some info out of errorCode.
275 if [info exists errorCode] {
276 verbose "Exec failed, errorCode: $errorCode" 3
278 verbose "Exec failed, errorCode not defined!" 3
282 if { [lindex ${dg-do-what} 2] == "F" } {
283 # Instead of modelling this as an xfail (via setup_xfail),
284 # treat an expected crash as a success.
285 if { $status == "pass" } then { set status fail } else { set status pass }
287 } else { set testtype "execution" }
289 $status "$name $testtype test"
291 if { [llength ${dg-output-text}] > 1 } {
292 #send_user "${dg-output-text}\n"
293 if { [lindex ${dg-output-text} 0] == "F" } {
296 set texttmp [lindex ${dg-output-text} 1]
297 if { ![regexp $texttmp ${output}] } {
298 fail "$name output pattern test"
300 pass "$name output pattern test"
302 verbose -log "Output pattern $texttmp"
309 # Are there any further tests to perform?
310 # Note that if the program has special run-time requirements, running
311 # of the program can be delayed until here. Ditto for other situations.
312 # It would be a bit cumbersome though.
314 if ![string match ${dg-final-code} ""] {
315 regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
316 # Note that the use of `args' here makes this a varargs proc.
317 proc dg
-final
-proc
{ args } $
{dg
-final
-code
}
318 verbose
"Running dg-final tests." 3
319 verbose
"dg-final-proc:\n[info body dg-final-proc]" 4
320 if [catch
"dg-final-proc $prog" errmsg] {
321 perror
"$name: error executing dg-final: $errmsg"
322 # ??? The
call to unresolved here is necessary to clear `errcnt
'.
323 # What we really need is a proc like perror that doesn't
set errcnt.
324 # It should also
set exit_status to
1.
325 unresolved
"$name: error executing dg-final: $errmsg"
329 #
Do some final clean up.
330 # When testing an interpreter
, we don
't compile something and leave an
332 if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
333 catch "exec rm -f $output_file"
340 # Indicate that this test case is to be rerun several times. This
341 # is useful if it is nondeterministic. This applies to rerunning the
342 # test program only, not rebuilding it.
343 # The embedded format is "{ dg-repetitions N }", where N is the number
344 # of repetitions. It better be greater than zero.
346 proc dg-repetitions { line value } {
347 upvar dg-repetitions repetitions
348 set repetitions $value
353 # Indicate that this test case is to be run with a short timeout.
354 # The embedded format is "{ dg-timeout N }", where N is in seconds.
356 proc dg-timeout { line value } {
358 set dg-timeout $value
362 # dejagnu's config
/unix.exp hard
-codes
300 seconds as the timeout
363 #
for any natively run executable. That
's too long for tests run
364 # multiple times and that may possibly hang. So we override it here
365 # to provide some degree of control.
366 rename standard_wait hooked_standard_wait
367 proc standard_wait { dest timeout } {
369 if {[info exists dg-timeout]} {
370 if {${dg-timeout} > 0} {
371 verbose -log "Overriding timeout = ${dg-timeout}"
372 set timeout ${dg-timeout}
376 hooked_standard_wait $dest $timeout