]>
Commit | Line | Data |
---|---|---|
83ffe9cd | 1 | # Copyright (C) 2015-2023 Free Software Foundation, Inc. |
9e531d37 DM |
2 | |
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. | |
7 | # | |
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. | |
12 | # | |
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/>. | |
16 | ||
17 | # Testing of multiline output | |
18 | ||
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. | |
26 | # | |
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"} | |
31 | # | ^~~~~~~ | |
32 | # where the compiler's first line of output is as before, but in | |
33 | # which it then echoes the source lines, adding annotations. | |
34 | # | |
35 | # We want to be able to write testcases that verify that the | |
36 | # emitted source-and-annotations are sane. | |
37 | # | |
38 | # A complication here is that the source lines contain comments | |
39 | # containing DejaGnu directives (such as the "dg-message" above). | |
40 | # | |
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; | |
45 | # | ^~~~~~~ | |
46 | # | { dg-end-multiline-output "" } */ | |
47 | # to have the testsuite verify the expected output. | |
48 | ||
49 | ############################################################################ | |
9617fd08 | 50 | # Global variables. |
9e531d37 DM |
51 | ############################################################################ |
52 | ||
9617fd08 | 53 | # This is intended to only be used from within multiline.exp. |
9e531d37 DM |
54 | # The line number of the last dg-begin-multiline-output directive. |
55 | set _multiline_last_beginning_line -1 | |
56 | ||
b5b44c62 DM |
57 | # A list of |
58 | # first-line-number, last-line-number, lines | |
59 | # where each "lines" is a list of strings. | |
9617fd08 DM |
60 | # This is cleared at the end of each test by gcc-dg.exp's wrapper for dg-test. |
61 | set multiline_expected_outputs [] | |
9e531d37 | 62 | |
83f604e7 DM |
63 | # Was dg-enable-nn-line-numbers called? |
64 | set nn_line_numbers_enabled 0 | |
65 | ||
9e531d37 DM |
66 | ############################################################################ |
67 | # Exported functions. | |
68 | ############################################################################ | |
69 | ||
70 | # Mark the beginning of an expected multiline output | |
71 | # All lines between this and the next dg-end-multiline-output are | |
72 | # expected to be seen. | |
73 | ||
74 | proc dg-begin-multiline-output { args } { | |
75 | global _multiline_last_beginning_line | |
76 | verbose "dg-begin-multiline-output: args: $args" 3 | |
77 | set line [expr [lindex $args 0] + 1] | |
cbd8652b DM |
78 | |
79 | # Complain if there hasn't been a dg-end-multiline-output | |
80 | # since the last dg-begin-multiline-output | |
81 | if { $_multiline_last_beginning_line != -1 } { | |
82 | set last_directive_line [expr $_multiline_last_beginning_line - 1] | |
83 | error "$last_directive_line: unterminated dg-begin-multiline-output" | |
84 | } | |
85 | ||
9e531d37 DM |
86 | set _multiline_last_beginning_line $line |
87 | } | |
88 | ||
89 | # Mark the end of an expected multiline output | |
90 | # All lines up to here since the last dg-begin-multiline-output are | |
91 | # expected to be seen. | |
9a85d982 DM |
92 | # |
93 | # dg-end-multiline-output comment [{ target/xfail selector }] | |
9e531d37 DM |
94 | |
95 | proc dg-end-multiline-output { args } { | |
96 | global _multiline_last_beginning_line | |
97 | verbose "dg-end-multiline-output: args: $args" 3 | |
cbd8652b DM |
98 | set first_line $_multiline_last_beginning_line |
99 | ||
100 | # Complain if there hasn't been a dg-begin-multiline-output | |
101 | if { $first_line == -1 } { | |
102 | error "[lindex $args 0]: dg-end-multiline-output without dg-begin-multiline-output" | |
103 | return | |
104 | } | |
105 | set _multiline_last_beginning_line -1 | |
106 | ||
107 | set last_line [expr [lindex $args 0] - 1] | |
108 | verbose "multiline output lines: $first_line-$last_line" 3 | |
9e531d37 | 109 | |
9a85d982 DM |
110 | if { [llength $args] > 3 } { |
111 | error "[lindex $args 0]: too many arguments" | |
112 | return | |
113 | } | |
114 | ||
115 | set maybe_x "" | |
116 | if { [llength $args] >= 3 } { | |
117 | switch [dg-process-target [lindex $args 2]] { | |
118 | "F" { set maybe_x "x" } | |
119 | "P" { set maybe_x "" } | |
120 | "N" { | |
121 | # If we get "N", this output doesn't apply to us so ignore it. | |
122 | return | |
123 | } | |
124 | } | |
125 | } | |
126 | ||
9e531d37 DM |
127 | upvar 1 prog prog |
128 | verbose "prog: $prog" 3 | |
129 | # "prog" now contains the filename | |
130 | # Load it and split it into lines | |
131 | ||
cbd8652b | 132 | set lines [_get_lines $prog $first_line $last_line] |
9e531d37 DM |
133 | |
134 | verbose "lines: $lines" 3 | |
9a85d982 | 135 | # Create an entry of the form: first-line, last-line, lines, maybe_x |
cbd8652b | 136 | set entry [list $first_line $last_line $lines $maybe_x] |
9617fd08 DM |
137 | global multiline_expected_outputs |
138 | lappend multiline_expected_outputs $entry | |
139 | verbose "within dg-end-multiline-output: multiline_expected_outputs: $multiline_expected_outputs" 3 | |
9e531d37 DM |
140 | } |
141 | ||
142 | # Hook to be called by prune.exp's prune_gcc_output to | |
143 | # look for the expected multiline outputs, pruning them, | |
144 | # reporting PASS for those that are found, and FAIL for | |
145 | # those that weren't found. | |
146 | # | |
147 | # It returns a pruned version of its output. | |
9e531d37 DM |
148 | |
149 | proc handle-multiline-outputs { text } { | |
9617fd08 | 150 | global multiline_expected_outputs |
b5b44c62 | 151 | global testname_with_flags |
9e531d37 | 152 | set index 0 |
9617fd08 | 153 | foreach entry $multiline_expected_outputs { |
b5b44c62 DM |
154 | verbose " entry: $entry" 3 |
155 | set start_line [lindex $entry 0] | |
156 | set end_line [lindex $entry 1] | |
157 | set multiline [lindex $entry 2] | |
9a85d982 | 158 | set maybe_x [lindex $entry 3] |
b5b44c62 | 159 | verbose " multiline: $multiline" 3 |
9e531d37 DM |
160 | set rexp [_build_multiline_regex $multiline $index] |
161 | verbose "rexp: ${rexp}" 4 | |
162 | # Escape newlines in $rexp so that we can print them in | |
163 | # pass/fail results. | |
164 | set escaped_regex [string map {"\n" "\\n"} $rexp] | |
165 | verbose "escaped_regex: ${escaped_regex}" 4 | |
166 | ||
b5b44c62 DM |
167 | set title "$testname_with_flags expected multiline pattern lines $start_line-$end_line" |
168 | ||
9e531d37 DM |
169 | # Use "regsub" to attempt to prune the pattern from $text |
170 | if {[regsub -line $rexp $text "" text]} { | |
9a85d982 DM |
171 | # The multiline pattern was pruned. |
172 | ${maybe_x}pass "$title was found: \"$escaped_regex\"" | |
9e531d37 | 173 | } else { |
9a85d982 | 174 | ${maybe_x}fail "$title not found: \"$escaped_regex\"" |
9e531d37 DM |
175 | } |
176 | ||
177 | set index [expr $index + 1] | |
178 | } | |
179 | ||
9e531d37 DM |
180 | return $text |
181 | } | |
182 | ||
83f604e7 DM |
183 | # DejaGnu directive to enable post-processing the line numbers printed in |
184 | # the left-hand margin when printing the source code, converting them to | |
185 | # "NN", e.g from: | |
186 | # | |
187 | # 100 | if (flag) | |
188 | # | ^ | |
189 | # | | | |
190 | # | (1) following 'true' branch... | |
191 | # 101 | { | |
192 | # 102 | foo (); | |
193 | # | ^ | |
194 | # | | | |
195 | # | (2) ...to here | |
196 | # | |
197 | # to: | |
198 | # | |
199 | # NN | if (flag) | |
200 | # | ^ | |
201 | # | | | |
202 | # | (1) following 'true' branch... | |
203 | # NN | { | |
204 | # NN | foo (); | |
205 | # | ^ | |
206 | # | | | |
207 | # | (2) ...to here | |
208 | # | |
209 | # This is useful e.g. when testing how interprocedural paths are printed | |
210 | # via dg-begin/end-multiline-output, to avoid depending on precise line | |
211 | # numbers. | |
212 | ||
213 | proc dg-enable-nn-line-numbers { args } { | |
214 | verbose "dg-nn-line-numbers: args: $args" 2 | |
215 | global nn_line_numbers_enabled | |
216 | set nn_line_numbers_enabled 1 | |
217 | } | |
218 | ||
219 | # Hook to be called by prune.exp's prune_gcc_output to convert such line | |
220 | # numbers to "NN" form. | |
221 | # | |
222 | # Match substrings of the form: | |
223 | # " 25 |" | |
224 | # and convert them to: | |
225 | # " NN |" | |
226 | # | |
227 | # It returns a copy of its input, with the above changes. | |
228 | ||
229 | proc maybe-handle-nn-line-numbers { text } { | |
230 | global testname_with_flags | |
231 | ||
232 | verbose "maybe-handle-nn-line-numbers" 3 | |
233 | ||
234 | global nn_line_numbers_enabled | |
235 | if { [expr {!$nn_line_numbers_enabled}] } { | |
236 | verbose "nn_line_numbers_enabled false; bailing out" 3 | |
237 | return $text | |
238 | } | |
239 | ||
240 | verbose "maybe-handle-nn-line-numbers: text before: ${text}" 4 | |
241 | ||
242 | # dg.exp's dg-test trims leading whitespace from the output | |
243 | # in this line: | |
244 | # set comp_output [string trimleft $comp_output] | |
245 | # so we can't rely on the exact leading whitespace for the | |
246 | # first line in the output. | |
247 | # Match initial input lines that start like: | |
248 | # "25 |" | |
249 | # and convert them to: | |
250 | # " NN |" | |
251 | set rexp2 {(^[0-9]+ \|)} | |
252 | set count_a [regsub -all $rexp2 $text " NN |" text] | |
253 | verbose "maybe-handle-nn-line-numbers: count_a: $count_a" 4 | |
254 | ||
255 | # Match lines that start like: | |
256 | # " 25 |" | |
257 | # and convert them to: | |
258 | # " NN |" | |
259 | set rexp {([ ]+[0-9]+ \|)} | |
260 | set count_b [regsub -all $rexp $text " NN |" text] | |
261 | verbose "maybe-handle-nn-line-numbers: count_b: $count_b" 4 | |
262 | ||
263 | verbose "maybe-handle-nn-line-numbers: text after: ${text}" 4 | |
264 | ||
265 | return $text | |
266 | } | |
267 | ||
9e531d37 DM |
268 | ############################################################################ |
269 | # Internal functions | |
270 | ############################################################################ | |
271 | ||
272 | # Load FILENAME and extract the lines from FIRST_LINE | |
273 | # to LAST_LINE (inclusive) as a list of strings. | |
274 | ||
275 | proc _get_lines { filename first_line last_line } { | |
276 | verbose "_get_lines" 3 | |
277 | verbose " filename: $filename" 3 | |
278 | verbose " first_line: $first_line" 3 | |
279 | verbose " last_line: $last_line" 3 | |
280 | ||
281 | set fp [open $filename r] | |
282 | set file_data [read $fp] | |
283 | close $fp | |
284 | set data [split $file_data "\n"] | |
285 | set linenum 1 | |
286 | set lines [] | |
287 | foreach line $data { | |
288 | verbose "line $linenum: $line" 4 | |
289 | if { $linenum >= $first_line && $linenum <= $last_line } { | |
290 | lappend lines $line | |
291 | } | |
292 | set linenum [expr $linenum + 1] | |
293 | } | |
294 | ||
295 | return $lines | |
296 | } | |
297 | ||
298 | # Convert $multiline from a list of strings to a multiline regex | |
299 | # We need to support matching arbitrary followup text on each line, | |
300 | # to deal with comments containing containing DejaGnu directives. | |
301 | ||
302 | proc _build_multiline_regex { multiline index } { | |
303 | verbose "_build_multiline_regex: $multiline $index" 4 | |
304 | ||
305 | set rexp "" | |
306 | foreach line $multiline { | |
307 | verbose " line: $line" 4 | |
308 | ||
309 | # We need to escape "^" and other regexp metacharacters. | |
310 | set line [string map {"^" "\\^" | |
311 | "(" "\\(" | |
312 | ")" "\\)" | |
313 | "[" "\\[" | |
314 | "]" "\\]" | |
bef08b71 DM |
315 | "{" "\\{" |
316 | "}" "\\}" | |
9e531d37 DM |
317 | "." "\\." |
318 | "\\" "\\\\" | |
319 | "?" "\\?" | |
320 | "+" "\\+" | |
321 | "*" "\\*" | |
322 | "|" "\\|"} $line] | |
323 | ||
324 | append rexp $line | |
325 | if {[string match "*^" $line] || [string match "*~" $line]} { | |
326 | # Assume a line containing a caret/range. This must be | |
327 | # an exact match. | |
9e531d37 DM |
328 | } else { |
329 | # Assume that we have a quoted source line. | |
01e1dea3 DM |
330 | if {![string equal "" $line] } { |
331 | # Support arbitrary followup text on each non-empty line, | |
332 | # to deal with comments containing containing DejaGnu | |
333 | # directives. | |
14c7757e | 334 | append rexp "\[^\\n\\r\]*" |
01e1dea3 | 335 | } |
9e531d37 DM |
336 | } |
337 | append rexp "\n" | |
338 | } | |
339 | ||
340 | # dg.exp's dg-test trims leading whitespace from the output | |
341 | # in this line: | |
342 | # set comp_output [string trimleft $comp_output] | |
343 | # so we can't rely on the exact leading whitespace for the | |
344 | # first line in the *first* multiline regex. | |
345 | # | |
346 | # Trim leading whitespace from the regexp, replacing it with | |
347 | # a "\s*", to match zero or more whitespace characters. | |
348 | if { $index == 0 } { | |
349 | set rexp [string trimleft $rexp] | |
350 | set rexp "\\s*$rexp" | |
351 | } | |
352 | ||
353 | verbose "rexp: $rexp" 4 | |
354 | ||
355 | return $rexp | |
356 | } |