summaryrefslogtreecommitdiff
path: root/libmudflap/testsuite/lib/mfdg.exp
blob: 9e340c0bd15757e373921195363fbaa36051535d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
# `mfdg' - overrides parts of general purpose testcase driver.
# Copyright (C) 1994 - 2001, 2003, 2009, 2010 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; see the file COPYING3.  If not see
# <http://www.gnu.org/licenses/>.


# This is a modified excerpt of dejagnu/lib/dg.exp.

load_lib dg.exp


# dg-test -- runs a new style DejaGnu test
#
# Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
#
# PROG is the full path name of the file to pass to the tool (eg: compiler).
# TOOL_FLAGS is a set of options to always pass.
# DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none.

#proc dg-test { prog tool_flags default_extra_tool_flags } {
proc dg-test { args } {
    global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
    global errorCode errorInfo
    global additional_prunes
    global tool
    global srcdir		;# eg: /calvin/dje/build/gcc/./testsuite/
    global host_triplet target_triplet

    set keep 0
    set i 0
    set dg-repetitions 1 ;# may be overridden by { dg-repetitions N }
    unset_timeout_vars

    if { [string index [lindex $args 0] 0] == "-" } {
	for { set i 0 } { $i < [llength $args] } { incr i } {
	    if { [lindex $args $i] == "--" } {
		incr i
		break
	    } elseif { [lindex $args $i] == "-keep-output" } {
		set keep 1
	    } elseif { [string index [lindex $args $i] 0] == "-" } {
		clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
		return
	    } else {
		break
	    }
	}
    }

    if { $i + 3 != [llength $args] } {
	clone_output "ERROR: dg-test: missing arguments in call"
	return
    }
    set prog [lindex $args $i]
    set tool_flags [lindex $args [expr $i + 1]]
    set default_extra_tool_flags [lindex $args [expr $i + 2]]

    set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"

    set name [dg-trim-dirname $srcdir $prog]
    # If we couldn't rip $srcdir out of `prog' then just do the best we can.
    # The point is to reduce the unnecessary noise in the logs.  Don't strip
    # out too much because different testcases with the same name can confuse
    # `test-tool'.
    if [string match "/*" $name] {
	set name "[file tail [file dirname $prog]]/[file tail $prog]"
    }

    if {$tool_flags != ""} {
	append name " ($tool_flags)"
    }

    # Process any embedded dg options in the testcase.

    # Use "" for the second element of dg-do-what so we can tell if it's been
    # explicitly set to "S".
    set dg-do-what [list ${dg-do-what-default} "" P]
    set dg-excess-errors-flag 0
    set dg-messages ""
    set dg-extra-tool-flags $default_extra_tool_flags
    set dg-final-code ""

    set additional_prunes ""

    # `dg-output-text' is a list of two elements: pass/fail and text.
    # Leave second element off for now (indicates "don't perform test")
    set dg-output-text "P"

    # Define our own "special function" `unknown' so we catch spelling errors.
    # But first rename the existing one so we can restore it afterwards.
    catch {rename dg-save-unknown ""}
    rename unknown dg-save-unknown
    proc unknown { args } {
	return -code error "unknown dg option: $args"
    }

    set tmp [dg-get-options $prog]
    foreach op $tmp {
	verbose "Processing option: $op" 3
	set status [catch "$op" errmsg]
	if { $status != 0 } {
	    if { 0 && [info exists errorInfo] } {
		# This also prints a backtrace which will just confuse
		# testcase writers, so it's disabled.
		perror "$name: $errorInfo\n"
	    } else {
		perror "$name: $errmsg for \"$op\"\n"
	    }
	    # ??? The call to unresolved here is necessary to clear `errcnt'.
	    # What we really need is a proc like perror that doesn't set errcnt.
	    # It should also set exit_status to 1.
	    unresolved "$name: $errmsg for \"$op\""
	    return
	}
    }

    # Restore normal error handling.
    rename unknown ""
    rename dg-save-unknown unknown

    # If we're not supposed to try this test on this target, we're done.
    if { [lindex ${dg-do-what} 1] == "N" } {
	unsupported "$name"
	verbose "$name not supported on this target, skipping it" 3
	return
    }

    # Run the tool and analyze the results.
    # The result of ${tool}-dg-test is in a bit of flux.
    # Currently it is the name of the output file (or "" if none).
    # If we need more than this it will grow into a list of things.
    # No intention is made (at this point) to preserve upward compatibility
    # (though at some point we'll have to).

    set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"];

    set comp_output [lindex $results 0];
    set output_file [lindex $results 1];

    #send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
    #send_user "\nold_dejagnu.exp: message = :$message:\n\n"
    #send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n"

    foreach i ${dg-messages} {
	verbose "Scanning for message: $i" 4

	# Remove all error messages for the line [lindex $i 0]
	# in the source file.  If we find any, success!
	set line [lindex $i 0]
	set pattern [lindex $i 2]
	set comment [lindex $i 3]
	#send_user "Before:\n$comp_output\n"
	if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
            set comp_output [string trimleft $comp_output]
	    set ok pass
	    set uhoh fail
	} else {
	    set ok fail
	    set uhoh pass
	}
	#send_user "After:\n$comp_output\n"

	# $line will either be a formatted line number or a number all by
	# itself.  Delete the formatting.
	scan $line ${dg-linenum-format} line
	switch [lindex $i 1] {
	    "ERROR" {
		$ok "$name $comment (test for errors, line $line)"
	    }
	    "XERROR" {
		x$ok "$name $comment (test for errors, line $line)"
	    }
	    "WARNING" {
		$ok "$name $comment (test for warnings, line $line)"
	    }
	    "XWARNING" {
		x$ok "$name $comment (test for warnings, line $line)"
	    }
	    "BOGUS" {
		$uhoh "$name $comment (test for bogus messages, line $line)"
	    }
	    "XBOGUS" {
		x$uhoh "$name $comment (test for bogus messages, line $line)"
	    }
	    "BUILD" {
		$uhoh "$name $comment (test for build failure, line $line)"
	    }
	    "XBUILD" {
		x$uhoh "$name $comment (test for build failure, line $line)"
	    }
	    "EXEC" { }
	    "XEXEC" { }
	}
	#send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
    }
    #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"

    # Remove messages from the tool that we can ignore.
    #send_user "comp_output: $comp_output\n"
    set comp_output [prune_warnings $comp_output]

    if { [info proc ${tool}-dg-prune] != "" } {
	set comp_output [${tool}-dg-prune $target_triplet $comp_output]
	switch -glob $comp_output {
	    "::untested::*" {
		regsub "::untested::" $comp_output "" message
		untested "$name: $message"
		return
	    }
	    "::unresolved::*" {
		regsub "::unresolved::" $comp_output "" message
		unresolved "$name: $message"
		return
	    }
	    "::unsupported::*" {
		regsub "::unsupported::" $comp_output "" message
		unsupported "$name: $message"
		return
	    }
	}
    }

    # See if someone forgot to delete the extra lines.
    regsub -all "\n+" $comp_output "\n" comp_output
    regsub "^\n+" $comp_output "" comp_output
    #send_user "comp_output: $comp_output\n"

    # Don't do this if we're testing an interpreter.
    # FIXME: why?
    if { ${dg-interpreter-batch-mode} == 0 } {
	# Catch excess errors (new bugs or incomplete testcases).
	if ${dg-excess-errors-flag} {
	    setup_xfail "*-*-*"
	}
	if ![string match "" $comp_output] {
	    fail "$name (test for excess errors)"
	    send_log "Excess errors:\n$comp_output\n"
	} else {
	    pass "$name (test for excess errors)"
	}
    }

    # Run the executable image if asked to do so.
    # FIXME: This is the only place where we assume a standard meaning to
    # the `keyword' argument of dg-do.  This could be cleaned up.
    if { [lindex ${dg-do-what} 0] == "run" } {
	if ![file exists $output_file] {
	    warning "$name compilation failed to produce executable"
	} else {
	    set testname $name
	    for {set rep 0} {$rep < ${dg-repetitions}} {incr rep} {
		# include repetition number in test name
		if {$rep > 0} { set name "$testname (rerun $rep)" }

		set status -1
		set result [${tool}_load $output_file]
		set status [lindex $result 0];
		set output [lindex $result 1];
		#send_user "After exec, status: $status\n"

		if { "$status" == "pass" } {
		    verbose "Exec succeeded." 3
		} elseif { "$status" == "fail" } {
		    # It would be nice to get some info out of errorCode.
		    if [info exists errorCode] {
			verbose "Exec failed, errorCode: $errorCode" 3
		    } else {
			verbose "Exec failed, errorCode not defined!" 3
		    }
		}
		
		if { [lindex ${dg-do-what} 2] == "F" } {
		    # Instead of modelling this as an xfail (via setup_xfail), 
		    # treat an expected crash as a success.
		    if { $status == "pass" } then { set status fail } else { set status pass }
		    set testtype "crash"
		} else { set testtype "execution" }
		
		$status "$name $testtype test"
		
		if { [llength ${dg-output-text}] > 1 } {
		    #send_user "${dg-output-text}\n"
		    if { [lindex ${dg-output-text} 0] == "F" } {
			setup_xfail "*-*-*"
		    }
		    set texttmp [lindex ${dg-output-text} 1]
		    if { ![regexp $texttmp ${output}] } {
			fail "$name output pattern test"
		    } else {
			pass "$name output pattern test"
		    }
		    verbose -log "Output pattern $texttmp"
		    unset texttmp
		}
	    }
	}
    }

    # Are there any further tests to perform?
    # Note that if the program has special run-time requirements, running
    # of the program can be delayed until here.  Ditto for other situations.
    # It would be a bit cumbersome though.

    if ![string match ${dg-final-code} ""] {
	regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
	# Note that the use of `args' here makes this a varargs proc.
	proc dg-final-proc { args } ${dg-final-code}
	verbose "Running dg-final tests." 3
	verbose "dg-final-proc:\n[info body dg-final-proc]" 4
	if [catch "dg-final-proc $prog" errmsg] {
	    perror "$name: error executing dg-final: $errmsg"
	    # ??? The call to unresolved here is necessary to clear `errcnt'.
	    # What we really need is a proc like perror that doesn't set errcnt.
	    # It should also set exit_status to 1.
	    unresolved "$name: error executing dg-final: $errmsg"
	}
    }

    # Do some final clean up.
    # When testing an interpreter, we don't compile something and leave an
    # output file.
    if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
	catch "exec rm -f $output_file"
    }
}


# 
# Indicate that this test case is to be rerun several times.  This
# is useful if it is nondeterministic.  This applies to rerunning the
# test program only, not rebuilding it.
# The embedded format is "{ dg-repetitions N }", where N is the number
# of repetitions.  It better be greater than zero.
#
proc dg-repetitions { line value } {
    upvar dg-repetitions repetitions
    set repetitions $value
}


# Prune any messages matching ARGS[1] (a regexp) from test output.
proc dg-prune-output { args } {
    global additional_prunes

    if { [llength $args] != 2 } {
	error "[lindex $args 1]: need one argument"
	return
    }

    lappend additional_prunes [lindex $args 1]
}

set additional_prunes ""