OSDN Git Service

0db44d5fbbd87f4f8a611a382b81420e40b7cd1d
[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 tool
37     global srcdir               ;# eg: /calvin/dje/build/gcc/./testsuite/
38     global host_triplet target_triplet
39
40     set keep 0
41     set i 0
42     set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
43     unset_timeout_vars
44
45     if { [string index [lindex $args 0] 0] == "-" } {
46         for { set i 0 } { $i < [llength $args] } { incr i } {
47             if { [lindex $args $i] == "--" } {
48                 incr i
49                 break
50             } elseif { [lindex $args $i] == "-keep-output" } {
51                 set keep 1
52             } elseif { [string index [lindex $args $i] 0] == "-" } {
53                 clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
54                 return
55             } else {
56                 break
57             }
58         }
59     }
60
61     if { $i + 3 != [llength $args] } {
62         clone_output "ERROR: dg-test: missing arguments in call"
63         return
64     }
65     set prog [lindex $args $i]
66     set tool_flags [lindex $args [expr $i + 1]]
67     set default_extra_tool_flags [lindex $args [expr $i + 2]]
68
69     set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
70
71     set name [dg-trim-dirname $srcdir $prog]
72     # If we couldn't rip $srcdir out of `prog' then just do the best we can.
73     # The point is to reduce the unnecessary noise in the logs.  Don't strip
74     # out too much because different testcases with the same name can confuse
75     # `test-tool'.
76     if [string match "/*" $name] {
77         set name "[file tail [file dirname $prog]]/[file tail $prog]"
78     }
79
80     if {$tool_flags != ""} {
81         append name " ($tool_flags)"
82     }
83
84     # Process any embedded dg options in the testcase.
85
86     # Use "" for the second element of dg-do-what so we can tell if it's been
87     # explicitly set to "S".
88     set dg-do-what [list ${dg-do-what-default} "" P]
89     set dg-excess-errors-flag 0
90     set dg-messages ""
91     set dg-extra-tool-flags $default_extra_tool_flags
92     set dg-final-code ""
93
94     # `dg-output-text' is a list of two elements: pass/fail and text.
95     # Leave second element off for now (indicates "don't perform test")
96     set dg-output-text "P"
97
98     # Define our own "special function" `unknown' so we catch spelling errors.
99     # But first rename the existing one so we can restore it afterwards.
100     catch {rename dg-save-unknown ""}
101     rename unknown dg-save-unknown
102     proc unknown { args } {
103         return -code error "unknown dg option: $args"
104     }
105
106     set tmp [dg-get-options $prog]
107     foreach op $tmp {
108         verbose "Processing option: $op" 3
109         set status [catch "$op" errmsg]
110         if { $status != 0 } {
111             if { 0 && [info exists errorInfo] } {
112                 # This also prints a backtrace which will just confuse
113                 # testcase writers, so it's disabled.
114                 perror "$name: $errorInfo\n"
115             } else {
116                 perror "$name: $errmsg for \"$op\"\n"
117             }
118             # ??? The call to unresolved here is necessary to clear `errcnt'.
119             # What we really need is a proc like perror that doesn't set errcnt.
120             # It should also set exit_status to 1.
121             unresolved "$name: $errmsg for \"$op\""
122             return
123         }
124     }
125
126     # Restore normal error handling.
127     rename unknown ""
128     rename dg-save-unknown unknown
129
130     # If we're not supposed to try this test on this target, we're done.
131     if { [lindex ${dg-do-what} 1] == "N" } {
132         unsupported "$name"
133         verbose "$name not supported on this target, skipping it" 3
134         return
135     }
136
137     # Run the tool and analyze the results.
138     # The result of ${tool}-dg-test is in a bit of flux.
139     # Currently it is the name of the output file (or "" if none).
140     # If we need more than this it will grow into a list of things.
141     # No intention is made (at this point) to preserve upward compatibility
142     # (though at some point we'll have to).
143
144     set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"];
145
146     set comp_output [lindex $results 0];
147     set output_file [lindex $results 1];
148
149     #send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
150     #send_user "\nold_dejagnu.exp: message = :$message:\n\n"
151     #send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n"
152
153     foreach i ${dg-messages} {
154         verbose "Scanning for message: $i" 4
155
156         # Remove all error messages for the line [lindex $i 0]
157         # in the source file.  If we find any, success!
158         set line [lindex $i 0]
159         set pattern [lindex $i 2]
160         set comment [lindex $i 3]
161         #send_user "Before:\n$comp_output\n"
162         if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
163             set comp_output [string trimleft $comp_output]
164             set ok pass
165             set uhoh fail
166         } else {
167             set ok fail
168             set uhoh pass
169         }
170         #send_user "After:\n$comp_output\n"
171
172         # $line will either be a formatted line number or a number all by
173         # itself.  Delete the formatting.
174         scan $line ${dg-linenum-format} line
175         switch [lindex $i 1] {
176             "ERROR" {
177                 $ok "$name $comment (test for errors, line $line)"
178             }
179             "XERROR" {
180                 x$ok "$name $comment (test for errors, line $line)"
181             }
182             "WARNING" {
183                 $ok "$name $comment (test for warnings, line $line)"
184             }
185             "XWARNING" {
186                 x$ok "$name $comment (test for warnings, line $line)"
187             }
188             "BOGUS" {
189                 $uhoh "$name $comment (test for bogus messages, line $line)"
190             }
191             "XBOGUS" {
192                 x$uhoh "$name $comment (test for bogus messages, line $line)"
193             }
194             "BUILD" {
195                 $uhoh "$name $comment (test for build failure, line $line)"
196             }
197             "XBUILD" {
198                 x$uhoh "$name $comment (test for build failure, line $line)"
199             }
200             "EXEC" { }
201             "XEXEC" { }
202         }
203         #send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
204     }
205     #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
206
207     # Remove messages from the tool that we can ignore.
208     #send_user "comp_output: $comp_output\n"
209     set comp_output [prune_warnings $comp_output]
210
211     if { [info proc ${tool}-dg-prune] != "" } {
212         set comp_output [${tool}-dg-prune $target_triplet $comp_output]
213         switch -glob $comp_output {
214             "::untested::*" {
215                 regsub "::untested::" $comp_output "" message
216                 untested "$name: $message"
217                 return
218             }
219             "::unresolved::*" {
220                 regsub "::unresolved::" $comp_output "" message
221                 unresolved "$name: $message"
222                 return
223             }
224             "::unsupported::*" {
225                 regsub "::unsupported::" $comp_output "" message
226                 unsupported "$name: $message"
227                 return
228             }
229         }
230     }
231
232     # See if someone forgot to delete the extra lines.
233     regsub -all "\n+" $comp_output "\n" comp_output
234     regsub "^\n+" $comp_output "" comp_output
235     #send_user "comp_output: $comp_output\n"
236
237     # Don't do this if we're testing an interpreter.
238     # FIXME: why?
239     if { ${dg-interpreter-batch-mode} == 0 } {
240         # Catch excess errors (new bugs or incomplete testcases).
241         if ${dg-excess-errors-flag} {
242             setup_xfail "*-*-*"
243         }
244         if ![string match "" $comp_output] {
245             fail "$name (test for excess errors)"
246             send_log "Excess errors:\n$comp_output\n"
247         } else {
248             pass "$name (test for excess errors)"
249         }
250     }
251
252     # Run the executable image if asked to do so.
253     # FIXME: This is the only place where we assume a standard meaning to
254     # the `keyword' argument of dg-do.  This could be cleaned up.
255     if { [lindex ${dg-do-what} 0] == "run" } {
256         if ![file exists $output_file] {
257             warning "$name compilation failed to produce executable"
258         } else {
259             set testname $name
260             for {set rep 0} {$rep < ${dg-repetitions}} {incr rep} {
261                 # include repetition number in test name
262                 if {$rep > 0} { set name "$testname (rerun $rep)" }
263
264                 set status -1
265                 set result [${tool}_load $output_file]
266                 set status [lindex $result 0];
267                 set output [lindex $result 1];
268                 #send_user "After exec, status: $status\n"
269
270                 if { "$status" == "pass" } {
271                     verbose "Exec succeeded." 3
272                 } elseif { "$status" == "fail" } {
273                     # It would be nice to get some info out of errorCode.
274                     if [info exists errorCode] {
275                         verbose "Exec failed, errorCode: $errorCode" 3
276                     } else {
277                         verbose "Exec failed, errorCode not defined!" 3
278                     }
279                 }
280                 
281                 if { [lindex ${dg-do-what} 2] == "F" } {
282                     # Instead of modelling this as an xfail (via setup_xfail), 
283                     # treat an expected crash as a success.
284                     if { $status == "pass" } then { set status fail } else { set status pass }
285                     set testtype "crash"
286                 } else { set testtype "execution" }
287                 
288                 $status "$name $testtype test"
289                 
290                 if { [llength ${dg-output-text}] > 1 } {
291                     #send_user "${dg-output-text}\n"
292                     if { [lindex ${dg-output-text} 0] == "F" } {
293                         setup_xfail "*-*-*"
294                     }
295                     set texttmp [lindex ${dg-output-text} 1]
296                     if { ![regexp $texttmp ${output}] } {
297                         fail "$name output pattern test"
298                     } else {
299                         pass "$name output pattern test"
300                     }
301                     verbose -log "Output pattern $texttmp"
302                     unset texttmp
303                 }
304             }
305         }
306     }
307
308     # Are there any further tests to perform?
309     # Note that if the program has special run-time requirements, running
310     # of the program can be delayed until here.  Ditto for other situations.
311     # It would be a bit cumbersome though.
312
313     if ![string match ${dg-final-code} ""] {
314         regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
315         # Note that the use of `args' here makes this a varargs proc.
316         proc dg-final-proc { args } ${dg-final-code}
317         verbose "Running dg-final tests." 3
318         verbose "dg-final-proc:\n[info body dg-final-proc]" 4
319         if [catch "dg-final-proc $prog" errmsg] {
320             perror "$name: error executing dg-final: $errmsg"
321             # ??? The call to unresolved here is necessary to clear `errcnt'.
322             # What we really need is a proc like perror that doesn't set errcnt.
323             # It should also set exit_status to 1.
324             unresolved "$name: error executing dg-final: $errmsg"
325         }
326     }
327
328     # Do some final clean up.
329     # When testing an interpreter, we don't compile something and leave an
330     # output file.
331     if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
332         catch "exec rm -f $output_file"
333     }
334 }
335
336
337
338
339 # Indicate that this test case is to be rerun several times.  This
340 # is useful if it is nondeterministic.  This applies to rerunning the
341 # test program only, not rebuilding it.
342 # The embedded format is "{ dg-repetitions N }", where N is the number
343 # of repetitions.  It better be greater than zero.
344 #
345 proc dg-repetitions { line value } {
346     upvar dg-repetitions repetitions
347     set repetitions $value
348 }