]>
Commit | Line | Data |
---|---|---|
f1717362 | 1 | # Copyright (C) 2015-2016 Free Software Foundation, Inc. |
71c8cbfe | 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 | ############################################################################ | |
50 | # Global variables. Although global, these are intended to only be used from | |
51 | # within multiline.exp. | |
52 | ############################################################################ | |
53 | ||
54 | # The line number of the last dg-begin-multiline-output directive. | |
55 | set _multiline_last_beginning_line -1 | |
56 | ||
1e662142 | 57 | # A list of |
58 | # first-line-number, last-line-number, lines | |
59 | # where each "lines" is a list of strings. | |
71c8cbfe | 60 | set _multiline_expected_outputs [] |
61 | ||
62 | ############################################################################ | |
63 | # Exported functions. | |
64 | ############################################################################ | |
65 | ||
66 | # Mark the beginning of an expected multiline output | |
67 | # All lines between this and the next dg-end-multiline-output are | |
68 | # expected to be seen. | |
69 | ||
70 | proc dg-begin-multiline-output { args } { | |
71 | global _multiline_last_beginning_line | |
72 | verbose "dg-begin-multiline-output: args: $args" 3 | |
73 | set line [expr [lindex $args 0] + 1] | |
74 | set _multiline_last_beginning_line $line | |
75 | } | |
76 | ||
77 | # Mark the end of an expected multiline output | |
78 | # All lines up to here since the last dg-begin-multiline-output are | |
79 | # expected to be seen. | |
80 | ||
81 | proc dg-end-multiline-output { args } { | |
82 | global _multiline_last_beginning_line | |
83 | verbose "dg-end-multiline-output: args: $args" 3 | |
84 | set line [expr [lindex $args 0] - 1] | |
85 | verbose "multiline output lines: $_multiline_last_beginning_line-$line" 3 | |
86 | ||
87 | upvar 1 prog prog | |
88 | verbose "prog: $prog" 3 | |
89 | # "prog" now contains the filename | |
90 | # Load it and split it into lines | |
91 | ||
92 | set lines [_get_lines $prog $_multiline_last_beginning_line $line] | |
71c8cbfe | 93 | |
94 | verbose "lines: $lines" 3 | |
1e662142 | 95 | # Create an entry of the form: first-line, last-line, lines |
96 | set entry [list $_multiline_last_beginning_line $line $lines] | |
71c8cbfe | 97 | global _multiline_expected_outputs |
1e662142 | 98 | lappend _multiline_expected_outputs $entry |
71c8cbfe | 99 | verbose "within dg-end-multiline-output: _multiline_expected_outputs: $_multiline_expected_outputs" 3 |
1e662142 | 100 | |
101 | set _multiline_last_beginning_line -1 | |
71c8cbfe | 102 | } |
103 | ||
104 | # Hook to be called by prune.exp's prune_gcc_output to | |
105 | # look for the expected multiline outputs, pruning them, | |
106 | # reporting PASS for those that are found, and FAIL for | |
107 | # those that weren't found. | |
108 | # | |
109 | # It returns a pruned version of its output. | |
110 | # | |
111 | # It also clears the list of expected multiline outputs. | |
112 | ||
113 | proc handle-multiline-outputs { text } { | |
114 | global _multiline_expected_outputs | |
1e662142 | 115 | global testname_with_flags |
71c8cbfe | 116 | set index 0 |
1e662142 | 117 | foreach entry $_multiline_expected_outputs { |
118 | verbose " entry: $entry" 3 | |
119 | set start_line [lindex $entry 0] | |
120 | set end_line [lindex $entry 1] | |
121 | set multiline [lindex $entry 2] | |
122 | verbose " multiline: $multiline" 3 | |
71c8cbfe | 123 | set rexp [_build_multiline_regex $multiline $index] |
124 | verbose "rexp: ${rexp}" 4 | |
125 | # Escape newlines in $rexp so that we can print them in | |
126 | # pass/fail results. | |
127 | set escaped_regex [string map {"\n" "\\n"} $rexp] | |
128 | verbose "escaped_regex: ${escaped_regex}" 4 | |
129 | ||
1e662142 | 130 | set title "$testname_with_flags expected multiline pattern lines $start_line-$end_line" |
131 | ||
71c8cbfe | 132 | # Use "regsub" to attempt to prune the pattern from $text |
133 | if {[regsub -line $rexp $text "" text]} { | |
134 | # Success; the multiline pattern was pruned. | |
1e662142 | 135 | pass "$title was found: \"$escaped_regex\"" |
71c8cbfe | 136 | } else { |
1e662142 | 137 | fail "$title not found: \"$escaped_regex\"" |
71c8cbfe | 138 | } |
139 | ||
140 | set index [expr $index + 1] | |
141 | } | |
142 | ||
143 | # Clear the list of expected multiline outputs | |
144 | set _multiline_expected_outputs [] | |
145 | ||
146 | return $text | |
147 | } | |
148 | ||
149 | ############################################################################ | |
150 | # Internal functions | |
151 | ############################################################################ | |
152 | ||
153 | # Load FILENAME and extract the lines from FIRST_LINE | |
154 | # to LAST_LINE (inclusive) as a list of strings. | |
155 | ||
156 | proc _get_lines { filename first_line last_line } { | |
157 | verbose "_get_lines" 3 | |
158 | verbose " filename: $filename" 3 | |
159 | verbose " first_line: $first_line" 3 | |
160 | verbose " last_line: $last_line" 3 | |
161 | ||
162 | set fp [open $filename r] | |
163 | set file_data [read $fp] | |
164 | close $fp | |
165 | set data [split $file_data "\n"] | |
166 | set linenum 1 | |
167 | set lines [] | |
168 | foreach line $data { | |
169 | verbose "line $linenum: $line" 4 | |
170 | if { $linenum >= $first_line && $linenum <= $last_line } { | |
171 | lappend lines $line | |
172 | } | |
173 | set linenum [expr $linenum + 1] | |
174 | } | |
175 | ||
176 | return $lines | |
177 | } | |
178 | ||
179 | # Convert $multiline from a list of strings to a multiline regex | |
180 | # We need to support matching arbitrary followup text on each line, | |
181 | # to deal with comments containing containing DejaGnu directives. | |
182 | ||
183 | proc _build_multiline_regex { multiline index } { | |
184 | verbose "_build_multiline_regex: $multiline $index" 4 | |
185 | ||
186 | set rexp "" | |
187 | foreach line $multiline { | |
188 | verbose " line: $line" 4 | |
189 | ||
190 | # We need to escape "^" and other regexp metacharacters. | |
191 | set line [string map {"^" "\\^" | |
192 | "(" "\\(" | |
193 | ")" "\\)" | |
194 | "[" "\\[" | |
195 | "]" "\\]" | |
9dfffd6d | 196 | "{" "\\{" |
197 | "}" "\\}" | |
71c8cbfe | 198 | "." "\\." |
199 | "\\" "\\\\" | |
200 | "?" "\\?" | |
201 | "+" "\\+" | |
202 | "*" "\\*" | |
203 | "|" "\\|"} $line] | |
204 | ||
205 | append rexp $line | |
206 | if {[string match "*^" $line] || [string match "*~" $line]} { | |
207 | # Assume a line containing a caret/range. This must be | |
208 | # an exact match. | |
209 | } elseif {[string match "*\\|" $line]} { | |
210 | # Assume a source line with a right-margin. Support | |
211 | # arbitrary text in place of any whitespace before the | |
212 | # right-margin, to deal with comments containing containing | |
213 | # DejaGnu directives. | |
214 | ||
215 | # Remove final "\|": | |
216 | set rexp [string range $rexp 0 [expr [string length $rexp] - 3]] | |
217 | ||
218 | # Trim off trailing whitespace: | |
219 | set old_length [string length $rexp] | |
220 | set rexp [string trimright $rexp] | |
221 | set new_length [string length $rexp] | |
222 | ||
223 | # Replace the trimmed whitespace with "." chars to match anything: | |
224 | set ws [string repeat "." [expr $old_length - $new_length]] | |
225 | set rexp "${rexp}${ws}" | |
226 | ||
227 | # Add back the trailing '\|': | |
228 | set rexp "${rexp}\\|" | |
229 | } else { | |
230 | # Assume that we have a quoted source line. | |
231 | # Support arbitrary followup text on each line, | |
232 | # to deal with comments containing containing DejaGnu | |
233 | # directives. | |
234 | append rexp ".*" | |
235 | } | |
236 | append rexp "\n" | |
237 | } | |
238 | ||
239 | # dg.exp's dg-test trims leading whitespace from the output | |
240 | # in this line: | |
241 | # set comp_output [string trimleft $comp_output] | |
242 | # so we can't rely on the exact leading whitespace for the | |
243 | # first line in the *first* multiline regex. | |
244 | # | |
245 | # Trim leading whitespace from the regexp, replacing it with | |
246 | # a "\s*", to match zero or more whitespace characters. | |
247 | if { $index == 0 } { | |
248 | set rexp [string trimleft $rexp] | |
249 | set rexp "\\s*$rexp" | |
250 | } | |
251 | ||
252 | verbose "rexp: $rexp" 4 | |
253 | ||
254 | return $rexp | |
255 | } |