1 # Copyright
(C
) 2015-2018 Free Software Foundation
, Inc.
3 # This
program is free software
; you can redistribute it and
/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation
; either version
3 of the License
, or
6 #
(at your option
) any later version.
8 # This
program is distributed in the hope that it will be useful
,
9 # but WITHOUT
ANY WARRANTY
; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License
for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with GCC
; see the file COPYING3.
If not see
15 #
<http
://www.gnu.org
/licenses
/>.
17 # Testing of multiline output
19 # We have pre
-existing testcases like this
:
20 # |typedef struct _GMutex GMutex
; // { dg
-message
"previously declared here"}
21 #
(using
"|" here to indicate the start of a line),
22 # generating output like this
:
23 # |gcc
/testsuite
/g
++.dg
/diagnostic
/wrong
-tag
-1.C
:4:16: note
: 'struct _GMutex' was previously declared here
24 # where the location of the dg
-message determines the expected line at
25 # which the error should be reported.
27 # To handle rich error
-reporting
, we want to be able to verify that we
28 #
get output like this
:
29 # |gcc
/testsuite
/g
++.dg
/diagnostic
/wrong
-tag
-1.C
:4:16: note
: 'struct _GMutex' was previously declared here
30 # | typedef struct _GMutex GMutex
; // { dg
-message
"previously declared here"}
32 # where the compiler
's first line of output is as before, but in
33 # which it then echoes the source lines, adding annotations.
35 # We want to be able to write testcases that verify that the
36 # emitted source-and-annotations are sane.
38 # A complication here is that the source lines contain comments
39 # containing DejaGnu directives (such as the "dg-message" above).
41 # We punt this somewhat by only matching the beginnings of lines.
42 # so that we can write e.g.
43 # |/* { dg-begin-multiline-output "" }
44 # | typedef struct _GMutex GMutex;
46 # | { dg-end-multiline-output "" } */
47 # to have the testsuite verify the expected output.
49 ############################################################################
51 ############################################################################
53 # This is intended to only be used from within multiline.exp.
54 # The line number of the last dg-begin-multiline-output directive.
55 set _multiline_last_beginning_line -1
58 # first-line-number, last-line-number, lines
59 # where each "lines" is a list of strings.
60 # This is cleared at the end of each test by gcc-dg.exp's wrapper
for dg
-test.
61 set multiline_expected_outputs
[]
63 ############################################################################
65 ############################################################################
67 # Mark the beginning of an expected multiline output
68 # All lines between this and the next dg
-end
-multiline
-output are
69 # expected to be seen.
71 proc dg
-begin
-multiline
-output
{ args } {
72 global _multiline_last_beginning_line
73 verbose
"dg-begin-multiline-output: args: $args" 3
74 set line
[expr
[lindex $
args 0] + 1]
75 set _multiline_last_beginning_line $line
78 # Mark the end of an expected multiline output
79 # All lines up to here since the last dg
-begin
-multiline
-output are
80 # expected to be seen.
82 # dg
-end
-multiline
-output comment
[{ target
/xfail selector
}]
84 proc dg
-end
-multiline
-output
{ args } {
85 global _multiline_last_beginning_line
86 verbose
"dg-end-multiline-output: args: $args" 3
87 set line
[expr
[lindex $
args 0] - 1]
88 verbose
"multiline output lines: $_multiline_last_beginning_line-$line" 3
90 if { [llength $
args] > 3 } {
91 error
"[lindex $args 0]: too many arguments"
96 if { [llength $
args] >= 3 } {
97 switch [dg
-process
-target
[lindex $
args 2]] {
98 "F" { set maybe_x "x" }
99 "P" { set maybe_x "" }
101 #
If we
get "N", this output doesn't apply to us so ignore it.
108 verbose
"prog: $prog" 3
109 #
"prog" now contains the filename
110 #
Load it and split it into lines
112 set lines
[_get_lines $prog $_multiline_last_beginning_line $line
]
114 verbose
"lines: $lines" 3
115 # Create an entry of the form
: first
-line
, last
-line
, lines
, maybe_x
116 set entry
[list $_multiline_last_beginning_line $line $lines $maybe_x
]
117 global multiline_expected_outputs
118 lappend multiline_expected_outputs $entry
119 verbose
"within dg-end-multiline-output: multiline_expected_outputs: $multiline_expected_outputs" 3
121 set _multiline_last_beginning_line
-1
124 # Hook to be called by prune.exp
's prune_gcc_output to
125 # look for the expected multiline outputs, pruning them,
126 # reporting PASS for those that are found, and FAIL for
127 # those that weren't found.
129 # It returns a pruned version of its output.
131 proc handle
-multiline
-outputs
{ text } {
132 global multiline_expected_outputs
133 global testname_with_flags
135 foreach entry $multiline_expected_outputs
{
136 verbose
" entry: $entry" 3
137 set start_line
[lindex $entry
0]
138 set end_line
[lindex $entry
1]
139 set multiline
[lindex $entry
2]
140 set maybe_x
[lindex $entry
3]
141 verbose
" multiline: $multiline" 3
142 set rexp
[_build_multiline_regex $multiline $index
]
143 verbose
"rexp: ${rexp}" 4
144 # Escape newlines in $rexp so that we can print them in
146 set escaped_regex
[string map
{"\n" "\\n"} $rexp]
147 verbose
"escaped_regex: ${escaped_regex}" 4
149 set title
"$testname_with_flags expected multiline pattern lines $start_line-$end_line"
151 # Use
"regsub" to attempt to prune the pattern from $text
152 if {[regsub
-line $rexp $
text "" text]} {
153 # The multiline pattern was pruned.
154 $
{maybe_x
}pass
"$title was found: \"$escaped_regex\""
156 $
{maybe_x
}fail
"$title not found: \"$escaped_regex\""
159 set index
[expr $index
+ 1]
165 ############################################################################
167 ############################################################################
169 #
Load FILENAME and extract the lines from FIRST_LINE
170 # to LAST_LINE
(inclusive
) as a list of strings.
172 proc _get_lines
{ filename first_line last_line
} {
173 verbose
"_get_lines" 3
174 verbose
" filename: $filename" 3
175 verbose
" first_line: $first_line" 3
176 verbose
" last_line: $last_line" 3
178 set fp
[open $filename r
]
179 set file_data
[read $fp
]
181 set data
[split $file_data
"\n"]
185 verbose
"line $linenum: $line" 4
186 if { $
linenum >= $first_line
&& $
linenum <= $last_line
} {
189 set linenum [expr $
linenum + 1]
195 #
Convert $multiline from a list of strings to a multiline regex
196 # We need to support matching arbitrary followup
text on each line
,
197 # to deal with comments containing containing DejaGnu directives.
199 proc _build_multiline_regex
{ multiline index
} {
200 verbose
"_build_multiline_regex: $multiline $index" 4
203 foreach line $multiline
{
204 verbose
" line: $line" 4
206 # We need to escape
"^" and other regexp metacharacters.
207 set line
[string map
{"^" "\\^"
222 if {[string match
"*^" $line] || [string match "*~" $line]} {
223 # Assume a line containing a caret
/range. This must be
226 # Assume that we have a quoted source line.
227 if {![string equal
"" $line] } {
228 # Support arbitrary followup
text on each non
-empty line
,
229 # to deal with comments containing containing DejaGnu
237 # dg.exp
's dg-test trims leading whitespace from the output
239 # set comp_output [string trimleft $comp_output]
240 # so we can't rely
on the exact leading whitespace
for the
241 # first line in the
*first
* multiline regex.
243 # Trim leading whitespace from the regexp
, replacing it with
244 # a
"\s*", to match zero or more whitespace characters.
246 set rexp
[string trimleft $rexp
]
250 verbose
"rexp: $rexp" 4