OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libmudflap/] [testsuite/] [lib/] [mfdg.exp] - Blame information for rev 738

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 738 jeremybenn
# `mfdg' - overrides parts of general purpose testcase driver.
2
# Copyright (C) 1994 - 2001, 2003, 2009, 2010 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
# .
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 ""

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.