1#   Copyright (C) 2015-2019 Free Software Foundation, Inc.
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.
51############################################################################
52
53# This is intended to only be used from within multiline.exp.
54# The line number of the last dg-begin-multiline-output directive.
55set _multiline_last_beginning_line -1
56
57# A list of
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.
61set multiline_expected_outputs []
62
63############################################################################
64# Exported functions.
65############################################################################
66
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.
70
71proc 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
76    # Complain if there hasn't been a dg-end-multiline-output
77    # since the last dg-begin-multiline-output
78    if { $_multiline_last_beginning_line != -1 } {
79	set last_directive_line [expr $_multiline_last_beginning_line - 1]
80	error "$last_directive_line: unterminated dg-begin-multiline-output"
81    }
82
83    set _multiline_last_beginning_line $line
84}
85
86# Mark the end of an expected multiline output
87# All lines up to here since the last dg-begin-multiline-output are
88# expected to be seen.
89#
90# dg-end-multiline-output comment [{ target/xfail selector }]
91
92proc dg-end-multiline-output { args } {
93    global _multiline_last_beginning_line
94    verbose "dg-end-multiline-output: args: $args" 3
95    set first_line $_multiline_last_beginning_line
96
97    # Complain if there hasn't been a dg-begin-multiline-output
98    if { $first_line == -1 } {
99	error "[lindex $args 0]: dg-end-multiline-output without dg-begin-multiline-output"
100	return
101    }
102    set _multiline_last_beginning_line -1
103
104    set last_line [expr [lindex $args 0] - 1]
105    verbose "multiline output lines: $first_line-$last_line" 3
106
107    if { [llength $args] > 3 } {
108	error "[lindex $args 0]: too many arguments"
109	return
110    }
111
112    set maybe_x ""
113    if { [llength $args] >= 3 } {
114	switch [dg-process-target [lindex $args 2]] {
115	    "F" { set maybe_x "x" }
116	    "P" { set maybe_x "" }
117	    "N" {
118		# If we get "N", this output doesn't apply to us so ignore it.
119		return
120	    }
121	}
122    }
123
124    upvar 1 prog prog
125    verbose "prog: $prog" 3
126    # "prog" now contains the filename
127    # Load it and split it into lines
128
129    set lines [_get_lines $prog $first_line $last_line]
130
131    verbose "lines: $lines" 3
132    # Create an entry of the form:  first-line, last-line, lines, maybe_x
133    set entry [list $first_line $last_line $lines $maybe_x]
134    global multiline_expected_outputs
135    lappend multiline_expected_outputs $entry
136    verbose "within dg-end-multiline-output: multiline_expected_outputs: $multiline_expected_outputs" 3
137}
138
139# Hook to be called by prune.exp's prune_gcc_output to
140# look for the expected multiline outputs, pruning them,
141# reporting PASS for those that are found, and FAIL for
142# those that weren't found.
143#
144# It returns a pruned version of its output.
145
146proc handle-multiline-outputs { text } {
147    global multiline_expected_outputs
148    global testname_with_flags
149    set index 0
150    foreach entry $multiline_expected_outputs {
151	verbose "  entry: $entry" 3
152	set start_line [lindex $entry 0]
153	set end_line   [lindex $entry 1]
154	set multiline  [lindex $entry 2]
155	set maybe_x    [lindex $entry 3]
156	verbose "  multiline: $multiline" 3
157	set rexp [_build_multiline_regex $multiline $index]
158	verbose "rexp: ${rexp}" 4
159	# Escape newlines in $rexp so that we can print them in
160	# pass/fail results.
161	set escaped_regex [string map {"\n" "\\n"} $rexp]
162	verbose "escaped_regex: ${escaped_regex}" 4
163
164	set title "$testname_with_flags expected multiline pattern lines $start_line-$end_line"
165
166	# Use "regsub" to attempt to prune the pattern from $text
167	if {[regsub -line $rexp $text "" text]} {
168	    # The multiline pattern was pruned.
169	    ${maybe_x}pass "$title was found: \"$escaped_regex\""
170	} else {
171	    ${maybe_x}fail "$title not found: \"$escaped_regex\""
172	}
173
174	set index [expr $index + 1]
175    }
176
177    return $text
178}
179
180############################################################################
181# Internal functions
182############################################################################
183
184# Load FILENAME and extract the lines from FIRST_LINE
185# to LAST_LINE (inclusive) as a list of strings.
186
187proc _get_lines { filename first_line last_line } {
188    verbose "_get_lines" 3
189    verbose "  filename: $filename" 3
190    verbose "  first_line: $first_line" 3
191    verbose "  last_line: $last_line" 3
192
193    set fp [open $filename r]
194    set file_data [read $fp]
195    close $fp
196    set data [split $file_data "\n"]
197    set linenum 1
198    set lines []
199    foreach line $data {
200	verbose "line $linenum: $line" 4
201	if { $linenum >= $first_line && $linenum <= $last_line } {
202	    lappend lines $line
203	}
204	set linenum [expr $linenum + 1]
205    }
206
207    return $lines
208}
209
210# Convert $multiline from a list of strings to a multiline regex
211# We need to support matching arbitrary followup text on each line,
212# to deal with comments containing containing DejaGnu directives.
213
214proc _build_multiline_regex { multiline index } {
215    verbose "_build_multiline_regex: $multiline $index" 4
216
217    set rexp ""
218    foreach line $multiline {
219	verbose "  line: $line" 4
220
221	# We need to escape "^" and other regexp metacharacters.
222	set line [string map {"^" "\\^"
223	                      "(" "\\("
224	                      ")" "\\)"
225	                      "[" "\\["
226	                      "]" "\\]"
227	                      "{" "\\{"
228	                      "}" "\\}"
229	                      "." "\\."
230	                      "\\" "\\\\"
231	                      "?" "\\?"
232	                      "+" "\\+"
233	                      "*" "\\*"
234	                      "|" "\\|"} $line]
235
236	append rexp $line
237	if {[string match "*^" $line] || [string match "*~" $line]} {
238	    # Assume a line containing a caret/range.  This must be
239	    # an exact match.
240	} else {
241	    # Assume that we have a quoted source line.
242	    if {![string equal "" $line] }  {
243		# Support arbitrary followup text on each non-empty line,
244		# to deal with comments containing containing DejaGnu
245		# directives.
246		append rexp ".*"
247	    }
248	}
249	append rexp "\n"
250    }
251
252    # dg.exp's dg-test trims leading whitespace from the output
253    # in this line:
254    #   set comp_output [string trimleft $comp_output]
255    # so we can't rely on the exact leading whitespace for the
256    # first line in the *first* multiline regex.
257    #
258    # Trim leading whitespace from the regexp, replacing it with
259    # a "\s*", to match zero or more whitespace characters.
260    if { $index == 0 } {
261	set rexp [string trimleft $rexp]
262	set rexp "\\s*$rexp"
263    }
264
265    verbose "rexp: $rexp" 4
266
267    return $rexp
268}
269