summaryrefslogtreecommitdiff
path: root/gcc/testsuite/lib/gcc-defs.exp
blob: 1186e5ba1a35f82ec3a338651a95988d89dc170b (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
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
# Copyright (C) 2001-2016 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 GCC; see the file COPYING3.  If not see
# <http://www.gnu.org/licenses/>.

load_lib target-libpath.exp

load_lib wrapper.exp

load_lib target-utils.exp

#
# ${tool}_check_compile -- Reports and returns pass/fail for a compilation
#

proc ${tool}_check_compile {testcase option objname gcc_output} {
    global tool
    set fatal_signal "*cc: Internal compiler error: program*got fatal signal"
 
    if [string match "$fatal_signal 6" $gcc_output] then {
	${tool}_fail $testcase "Got Signal 6, $option"
	return 0
    }

    if [string match "$fatal_signal 11" $gcc_output] then {
	${tool}_fail $testcase "Got Signal 11, $option"
	return 0
    }

    if [string match "*internal compiler error*" $gcc_output] then {
	${tool}_fail $testcase "$option (internal compiler error)"
	return 0
    }

    # We shouldn't get these because of -w, but just in case.
    if [string match "*cc:*warning:*" $gcc_output] then {
	warning "$testcase: (with warnings) $option"
	send_log "$gcc_output\n"
	unresolved "$testcase, $option"
	return 0
    }

    set gcc_output [prune_warnings $gcc_output]

    if { [info proc ${tool}-dg-prune] != "" } {
	global target_triplet
	set gcc_output [${tool}-dg-prune $target_triplet $gcc_output]
	if [string match "*::unsupported::*" $gcc_output] then {
	    regsub -- "::unsupported::" $gcc_output "" gcc_output
	    unsupported "$testcase: $gcc_output"
	    return 0
	}
    } else {
	set unsupported_message [${tool}_check_unsupported_p $gcc_output]
	if { $unsupported_message != "" } {
	    unsupported "$testcase: $unsupported_message"
	    return 0
	}
    }

    # remove any leftover LF/CR to make sure any output is legit
    regsub -all -- "\[\r\n\]*" $gcc_output "" gcc_output

    # If any message remains, we fail.
    if ![string match "" $gcc_output] then {
	${tool}_fail $testcase $option
	return 0
    }

    # fail if the desired object file doesn't exist.
    # FIXME: there's no way of checking for existence on a remote host.
    if {$objname != "" && ![is3way] && ![file exists $objname]} {
	${tool}_fail $testcase $option
	return 0
    }

    ${tool}_pass $testcase $option
    return 1
}

#
# ${tool}_pass -- utility to record a testcase passed
#

proc ${tool}_pass { testcase cflags } {
    if { "$cflags" == "" } {
	pass "$testcase"
    } else {
	pass "$testcase, $cflags"
    }
}

#
# ${tool}_fail -- utility to record a testcase failed
#

proc ${tool}_fail { testcase cflags } {
    if { "$cflags" == "" } {
	fail "$testcase"
    } else {
	fail "$testcase, $cflags"
    }
}

#
# ${tool}_finish -- called at the end of every script that calls ${tool}_init
#
# Hide all quirks of the testing environment from the testsuites.  Also
# undo anything that ${tool}_init did that needs undoing.
#

proc ${tool}_finish { } {
    # The testing harness apparently requires this.
    global errorInfo

    if [info exists errorInfo] then {
	unset errorInfo
    }

    # Might as well reset these (keeps our caller from wondering whether
    # s/he has to or not).
    global prms_id bug_id
    set prms_id 0
    set bug_id 0
}

#
# ${tool}_exit -- Does final cleanup when testing is complete
#

proc ${tool}_exit { } {
    global gluefile

    if [info exists gluefile] {
	file_on_build delete $gluefile
	unset gluefile
    }
}

#
# runtest_file_p -- Provide a definition for older dejagnu releases
# 		    and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
# 		    (delete after next dejagnu release).
#

if { [info procs runtest_file_p] == "" } then {
    proc runtest_file_p { runtests testcase } {
	if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
	    if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
		return 1
	    } else {
		return 0
	    }
	}
	return 1
    }
}

if { [info exists env(GCC_RUNTEST_PARALLELIZE_DIR)] \
     && [info procs runtest_file_p] != [list] \
     && [info procs gcc_parallelize_saved_runtest_file_p] == [list] } then {
    global gcc_runtest_parallelize_counter
    global gcc_runtest_parallelize_counter_minor
    global gcc_runtest_parallelize_enable
    global gcc_runtest_parallelize_dir
    global gcc_runtest_parallelize_last

    set gcc_runtest_parallelize_counter 0
    set gcc_runtest_parallelize_counter_minor 0
    set gcc_runtest_parallelize_enable 1
    set gcc_runtest_parallelize_dir [getenv GCC_RUNTEST_PARALLELIZE_DIR]
    set gcc_runtest_parallelize_last 0

    proc gcc_parallel_test_run_p { testcase } {
	global gcc_runtest_parallelize_counter
	global gcc_runtest_parallelize_counter_minor
	global gcc_runtest_parallelize_enable
	global gcc_runtest_parallelize_dir
	global gcc_runtest_parallelize_last

	if { $gcc_runtest_parallelize_enable == 0 } {
	    return 1
	}

	# Only test the filesystem every 10th iteration
	incr gcc_runtest_parallelize_counter_minor
	if { $gcc_runtest_parallelize_counter_minor == 10 } {
	    set gcc_runtest_parallelize_counter_minor 0
	}
	if { $gcc_runtest_parallelize_counter_minor != 1 } {
	    #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter $gcc_runtest_parallelize_last"
	    return $gcc_runtest_parallelize_last
	}

	set path $gcc_runtest_parallelize_dir/$gcc_runtest_parallelize_counter

	if {![catch {open $path {RDWR CREAT EXCL} 0600} fd]} {
	    close $fd
	    set gcc_runtest_parallelize_last 1
	    #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 1"
	    incr gcc_runtest_parallelize_counter
	    return 1
	}
	set gcc_runtest_parallelize_last 0
	#verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 0"
	incr gcc_runtest_parallelize_counter
	return 0
    }

    proc gcc_parallel_test_enable { val } {
	global gcc_runtest_parallelize_enable
	set gcc_runtest_parallelize_enable $val
    }

    rename runtest_file_p gcc_parallelize_saved_runtest_file_p
    proc runtest_file_p { runtests testcase } {
	if ![gcc_parallelize_saved_runtest_file_p $runtests $testcase] {
	    return 0
	}
	return [gcc_parallel_test_run_p $testcase]
    }

} else {

    proc gcc_parallel_test_run_p { testcase } {
	return 1
    }

    proc gcc_parallel_test_enable { val } {
    }

}

# Like dg-options, but adds to the default options rather than replacing them.

proc dg-additional-options { args } {
    upvar dg-extra-tool-flags extra-tool-flags

    if { [llength $args] > 3 } {
	error "[lindex $args 0]: too many arguments"
	return
    }

    if { [llength $args] >= 3 } {
	switch [dg-process-target [lindex $args 2]] {
	    "S" { eval lappend extra-tool-flags [lindex $args 1] }
	    "N" { }
	    "F" { error "[lindex $args 0]: `xfail' not allowed here" }
	    "P" { error "[lindex $args 0]: `xfail' not allowed here" }
	}
    } else {
	eval lappend extra-tool-flags [lindex $args 1]
    }
}

# Record additional sources files that must be compiled along with the
# main source file.

set additional_sources ""
set additional_sources_used ""

proc dg-additional-sources { args } {
    global additional_sources
    set additional_sources [lindex $args 1]
}

# Record additional files -- other than source files -- that must be
# present on the system where the compiler runs.

set additional_files ""

proc dg-additional-files { args } {
    global additional_files
    set additional_files [lindex $args 1]
}

# Return an updated version of OPTIONS that mentions any additional
# source files registered with dg-additional-sources.  SOURCE is the
# name of the test case.

proc dg-additional-files-options { options source } {
    global additional_sources
    global additional_sources_used
    global additional_files
    set to_download [list]
    if { $additional_sources != "" } then {
	if [is_remote host] {
	    lappend options "additional_flags=$additional_sources"
	}
	regsub -all "^| " $additional_sources " [file dirname $source]/" additional_sources
	if ![is_remote host] {
	    lappend options "additional_flags=$additional_sources"
	}
	set to_download [concat $to_download $additional_sources]
	set additional_sources_used "$additional_sources"
	set additional_sources ""
    }
    if { $additional_files != "" } then { 
	regsub -all "^| " $additional_files " [file dirname $source]/" additional_files
	set to_download [concat $to_download $additional_files]
	set additional_files ""
    }
    if [is_remote host] {
	foreach file $to_download {
	    remote_download host $file
	}
    }

    return $options
}

# Return a colon-separate list of directories to search for libraries
# for COMPILER, including multilib directories.

proc gcc-set-multilib-library-path { compiler } {
    global rootme

    # ??? rootme will not be set when testing an installed compiler.
    # In that case, we should perhaps use some other method to find
    # libraries.
    if {![info exists rootme]} {
	return ""
    }

    set libpath ":${rootme}"
    set options [lrange $compiler 1 end]
    set compiler [lindex $compiler 0]
    if { [is_remote host] == 0 && [which $compiler] != 0 } {
	foreach i "[eval exec $compiler $options --print-multi-lib]" {
	    set mldir ""
	    regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir
	    set mldir [string trimright $mldir "\;@"]
	    if { "$mldir" == "." } {
		continue
	    }
	    if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s*.so.*]] >= 1 } {
		append libpath ":${rootme}/${mldir}"
	    }
	}
    }

    return $libpath
}

# A list of all uses of dg-regexp, each entry of the form:
#   line-number regexp
# This is cleared at the end of each test by gcc-dg.exp's wrapper for dg-test.
set freeform_regexps []

# Directive for looking for a regexp, without any line numbers or other
# prefixes.

proc dg-regexp { args } {
    verbose "dg-regexp: args: $args" 2

    global freeform_regexps
    lappend freeform_regexps $args
}

# Hook to be called by prune.exp's prune_gcc_output to
# look for the expected dg-regexp expressions, pruning them,
# reporting PASS for those that are found, and FAIL for
# those that weren't found.
#
# It returns a pruned version of its output.

proc handle-dg-regexps { text } {
    global freeform_regexps
    global testname_with_flags

    foreach entry $freeform_regexps {
	verbose "  entry: $entry" 3

	set linenum [lindex $entry 0]
	set rexp [lindex $entry 1]

	# Escape newlines in $rexp so that we can print them in
	# pass/fail results.
	set escaped_regex [string map {"\n" "\\n"} $rexp]
	verbose "escaped_regex: ${escaped_regex}" 4

	set title "$testname_with_flags dg-regexp $linenum"

	# Use "regsub" to attempt to prune the pattern from $text
	if {[regsub -line $rexp $text "" text]} {
	    # Success; the multiline pattern was pruned.
	    pass "$title was found: \"$escaped_regex\""
	} else {
	    fail "$title not found: \"$escaped_regex\""
	}
    }

    return $text
}