OSDN Git Service

* testsuite/lib/mfdg.exp (additional_prunes): New global.
[pf3gnuchains/gcc-fork.git] / libmudflap / testsuite / lib / mfdg.exp
1 # `mfdg' - overrides parts of general purpose testcase driver.
2 # Copyright (C) 1994 - 2001, 2003, 2009 Free Software Foundation, Inc.
3
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.
8
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.
13
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/>.
17
18
19 # This is a modified excerpt of dejagnu/lib/dg.exp.
20
21 load_lib dg.exp
22
23
24 # dg-test -- runs a new style DejaGnu test
25 #
26 # Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
27 #
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.
31
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
37     global tool
38     global srcdir               ;# eg: /calvin/dje/build/gcc/./testsuite/
39     global host_triplet target_triplet
40
41     set keep 0
42     set i 0
43     set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
44     unset_timeout_vars
45
46     if { [string index [lindex $args 0] 0] == "-" } {
47         for { set i 0 } { $i < [llength $args] } { incr i } {
48             if { [lindex $args $i] == "--" } {
49                 incr i
50                 break
51             } elseif { [lindex $args $i] == "-keep-output" } {
52                 set keep 1
53             } elseif { [string index [lindex $args $i] 0] == "-" } {
54                 clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
55                 return
56             } else {
57                 break
58             }
59         }
60     }
61
62     if { $i + 3 != [llength $args] } {
63         clone_output "ERROR: dg-test: missing arguments in call"
64         return
65     }
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]]
69
70     set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
71
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
76     # `test-tool'.
77     if [string match "/*" $name] {
78         set name "[file tail [file dirname $prog]]/[file tail $prog]"
79     }
80
81     if {$tool_flags != ""} {
82         append name " ($tool_flags)"
83     }
84
85     # Process any embedded dg options in the testcase.
86
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
91     set dg-messages ""
92     set dg-extra-tool-flags $default_extra_tool_flags
93     set dg-final-code ""
94
95     set additional_prunes ""
96
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"
100
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"
107     }
108
109     set tmp [dg-get-options $prog]
110     foreach op $tmp {
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"
118             } else {
119                 perror "$name: $errmsg for \"$op\"\n"
120             }
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\""
125             return
126         }
127     }
128
129     # Restore normal error handling.
130     rename unknown ""
131     rename dg-save-unknown unknown
132
133     # If we're not supposed to try this test on this target, we're done.
134     if { [lindex ${dg-do-what} 1] == "N" } {
135         unsupported "$name"
136         verbose "$name not supported on this target, skipping it" 3
137         return
138     }
139
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).
146
147     set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"];
148
149     set comp_output [lindex $results 0];
150     set output_file [lindex $results 1];
151
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"
155
156     foreach i ${dg-messages} {
157         verbose "Scanning for message: $i" 4
158
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]
167             set ok pass
168             set uhoh fail
169         } else {
170             set ok fail
171             set uhoh pass
172         }
173         #send_user "After:\n$comp_output\n"
174
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] {
179             "ERROR" {
180                 $ok "$name $comment (test for errors, line $line)"
181             }
182             "XERROR" {
183                 x$ok "$name $comment (test for errors, line $line)"
184             }
185             "WARNING" {
186                 $ok "$name $comment (test for warnings, line $line)"
187             }
188             "XWARNING" {
189                 x$ok "$name $comment (test for warnings, line $line)"
190             }
191             "BOGUS" {
192                 $uhoh "$name $comment (test for bogus messages, line $line)"
193             }
194             "XBOGUS" {
195                 x$uhoh "$name $comment (test for bogus messages, line $line)"
196             }
197             "BUILD" {
198                 $uhoh "$name $comment (test for build failure, line $line)"
199             }
200             "XBUILD" {
201                 x$uhoh "$name $comment (test for build failure, line $line)"
202             }
203             "EXEC" { }
204             "XEXEC" { }
205         }
206         #send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
207     }
208     #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
209
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]
213
214     if { [info proc ${tool}-dg-prune] != "" } {
215         set comp_output [${tool}-dg-prune $target_triplet $comp_output]
216         switch -glob $comp_output {
217             "::untested::*" {
218                 regsub "::untested::" $comp_output "" message
219                 untested "$name: $message"
220                 return
221             }
222             "::unresolved::*" {
223                 regsub "::unresolved::" $comp_output "" message
224                 unresolved "$name: $message"
225                 return
226             }
227             "::unsupported::*" {
228                 regsub "::unsupported::" $comp_output "" message
229                 unsupported "$name: $message"
230                 return
231             }
232         }
233     }
234
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"
239
240     # Don't do this if we're testing an interpreter.
241     # FIXME: why?
242     if { ${dg-interpreter-batch-mode} == 0 } {
243         # Catch excess errors (new bugs or incomplete testcases).
244         if ${dg-excess-errors-flag} {
245             setup_xfail "*-*-*"
246         }
247         if ![string match "" $comp_output] {
248             fail "$name (test for excess errors)"
249             send_log "Excess errors:\n$comp_output\n"
250         } else {
251             pass "$name (test for excess errors)"
252         }
253     }
254
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"
261         } else {
262             set testname $name
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)" }
266
267                 set status -1
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"
272
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
279                     } else {
280                         verbose "Exec failed, errorCode not defined!" 3
281                     }
282                 }
283                 
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 }
288                     set testtype "crash"
289                 } else { set testtype "execution" }
290                 
291                 $status "$name $testtype test"
292                 
293                 if { [llength ${dg-output-text}] > 1 } {
294                     #send_user "${dg-output-text}\n"
295                     if { [lindex ${dg-output-text} 0] == "F" } {
296                         setup_xfail "*-*-*"
297                     }
298                     set texttmp [lindex ${dg-output-text} 1]
299                     if { ![regexp $texttmp ${output}] } {
300                         fail "$name output pattern test"
301                     } else {
302                         pass "$name output pattern test"
303                     }
304                     verbose -log "Output pattern $texttmp"
305                     unset texttmp
306                 }
307             }
308         }
309     }
310
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.
315
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"
328         }
329     }
330
331     # Do some final clean up.
332     # When testing an interpreter, we don't compile something and leave an
333     # output file.
334     if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
335         catch "exec rm -f $output_file"
336     }
337 }
338
339
340
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.
346 #
347 proc dg-repetitions { line value } {
348     upvar dg-repetitions repetitions
349     set repetitions $value
350 }
351
352
353 # Prune any messages matching ARGS[1] (a regexp) from test output.
354 proc dg-prune-output { args } {
355     global additional_prunes
356
357     if { [llength $args] != 2 } {
358         error "[lindex $args 1]: need one argument"
359         return
360     }
361
362     lappend additional_prunes [lindex $args 1]
363 }
364
365 set additional_prunes ""