blob: d31331bd5819e8439008886336dc1b18d30fbeca [file] [log] [blame]
# Copyright (C) 2015-2022 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/>.
# Testing of multiline output
# We have pre-existing testcases like this:
# |typedef struct _GMutex GMutex; // { dg-message "previously declared here"}
# (using "|" here to indicate the start of a line),
# generating output like this:
# |gcc/testsuite/g++.dg/diagnostic/wrong-tag-1.C:4:16: note: 'struct _GMutex' was previously declared here
# where the location of the dg-message determines the expected line at
# which the error should be reported.
#
# To handle rich error-reporting, we want to be able to verify that we
# get output like this:
# |gcc/testsuite/g++.dg/diagnostic/wrong-tag-1.C:4:16: note: 'struct _GMutex' was previously declared here
# | typedef struct _GMutex GMutex; // { dg-message "previously declared here"}
# | ^~~~~~~
# where the compiler's first line of output is as before, but in
# which it then echoes the source lines, adding annotations.
#
# We want to be able to write testcases that verify that the
# emitted source-and-annotations are sane.
#
# A complication here is that the source lines contain comments
# containing DejaGnu directives (such as the "dg-message" above).
#
# We punt this somewhat by only matching the beginnings of lines.
# so that we can write e.g.
# |/* { dg-begin-multiline-output "" }
# | typedef struct _GMutex GMutex;
# | ^~~~~~~
# | { dg-end-multiline-output "" } */
# to have the testsuite verify the expected output.
############################################################################
# Global variables.
############################################################################
# This is intended to only be used from within multiline.exp.
# The line number of the last dg-begin-multiline-output directive.
set _multiline_last_beginning_line -1
# A list of
# first-line-number, last-line-number, lines
# where each "lines" is a list of strings.
# This is cleared at the end of each test by gcc-dg.exp's wrapper for dg-test.
set multiline_expected_outputs []
# Was dg-enable-nn-line-numbers called?
set nn_line_numbers_enabled 0
############################################################################
# Exported functions.
############################################################################
# Mark the beginning of an expected multiline output
# All lines between this and the next dg-end-multiline-output are
# expected to be seen.
proc dg-begin-multiline-output { args } {
global _multiline_last_beginning_line
verbose "dg-begin-multiline-output: args: $args" 3
set line [expr [lindex $args 0] + 1]
# Complain if there hasn't been a dg-end-multiline-output
# since the last dg-begin-multiline-output
if { $_multiline_last_beginning_line != -1 } {
set last_directive_line [expr $_multiline_last_beginning_line - 1]
error "$last_directive_line: unterminated dg-begin-multiline-output"
}
set _multiline_last_beginning_line $line
}
# Mark the end of an expected multiline output
# All lines up to here since the last dg-begin-multiline-output are
# expected to be seen.
#
# dg-end-multiline-output comment [{ target/xfail selector }]
proc dg-end-multiline-output { args } {
global _multiline_last_beginning_line
verbose "dg-end-multiline-output: args: $args" 3
set first_line $_multiline_last_beginning_line
# Complain if there hasn't been a dg-begin-multiline-output
if { $first_line == -1 } {
error "[lindex $args 0]: dg-end-multiline-output without dg-begin-multiline-output"
return
}
set _multiline_last_beginning_line -1
set last_line [expr [lindex $args 0] - 1]
verbose "multiline output lines: $first_line-$last_line" 3
if { [llength $args] > 3 } {
error "[lindex $args 0]: too many arguments"
return
}
set maybe_x ""
if { [llength $args] >= 3 } {
switch [dg-process-target [lindex $args 2]] {
"F" { set maybe_x "x" }
"P" { set maybe_x "" }
"N" {
# If we get "N", this output doesn't apply to us so ignore it.
return
}
}
}
upvar 1 prog prog
verbose "prog: $prog" 3
# "prog" now contains the filename
# Load it and split it into lines
set lines [_get_lines $prog $first_line $last_line]
verbose "lines: $lines" 3
# Create an entry of the form: first-line, last-line, lines, maybe_x
set entry [list $first_line $last_line $lines $maybe_x]
global multiline_expected_outputs
lappend multiline_expected_outputs $entry
verbose "within dg-end-multiline-output: multiline_expected_outputs: $multiline_expected_outputs" 3
}
# Hook to be called by prune.exp's prune_gcc_output to
# look for the expected multiline outputs, 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-multiline-outputs { text } {
global multiline_expected_outputs
global testname_with_flags
set index 0
foreach entry $multiline_expected_outputs {
verbose " entry: $entry" 3
set start_line [lindex $entry 0]
set end_line [lindex $entry 1]
set multiline [lindex $entry 2]
set maybe_x [lindex $entry 3]
verbose " multiline: $multiline" 3
set rexp [_build_multiline_regex $multiline $index]
verbose "rexp: ${rexp}" 4
# 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 expected multiline pattern lines $start_line-$end_line"
# Use "regsub" to attempt to prune the pattern from $text
if {[regsub -line $rexp $text "" text]} {
# The multiline pattern was pruned.
${maybe_x}pass "$title was found: \"$escaped_regex\""
} else {
${maybe_x}fail "$title not found: \"$escaped_regex\""
}
set index [expr $index + 1]
}
return $text
}
# DejaGnu directive to enable post-processing the line numbers printed in
# the left-hand margin when printing the source code, converting them to
# "NN", e.g from:
#
# 100 | if (flag)
# | ^
# | |
# | (1) following 'true' branch...
# 101 | {
# 102 | foo ();
# | ^
# | |
# | (2) ...to here
#
# to:
#
# NN | if (flag)
# | ^
# | |
# | (1) following 'true' branch...
# NN | {
# NN | foo ();
# | ^
# | |
# | (2) ...to here
#
# This is useful e.g. when testing how interprocedural paths are printed
# via dg-begin/end-multiline-output, to avoid depending on precise line
# numbers.
proc dg-enable-nn-line-numbers { args } {
verbose "dg-nn-line-numbers: args: $args" 2
global nn_line_numbers_enabled
set nn_line_numbers_enabled 1
}
# Hook to be called by prune.exp's prune_gcc_output to convert such line
# numbers to "NN" form.
#
# Match substrings of the form:
# " 25 |"
# and convert them to:
# " NN |"
#
# It returns a copy of its input, with the above changes.
proc maybe-handle-nn-line-numbers { text } {
global testname_with_flags
verbose "maybe-handle-nn-line-numbers" 3
global nn_line_numbers_enabled
if { [expr {!$nn_line_numbers_enabled}] } {
verbose "nn_line_numbers_enabled false; bailing out" 3
return $text
}
verbose "maybe-handle-nn-line-numbers: text before: ${text}" 4
# dg.exp's dg-test trims leading whitespace from the output
# in this line:
# set comp_output [string trimleft $comp_output]
# so we can't rely on the exact leading whitespace for the
# first line in the output.
# Match initial input lines that start like:
# "25 |"
# and convert them to:
# " NN |"
set rexp2 {(^[0-9]+ \|)}
set count_a [regsub -all $rexp2 $text " NN |" text]
verbose "maybe-handle-nn-line-numbers: count_a: $count_a" 4
# Match lines that start like:
# " 25 |"
# and convert them to:
# " NN |"
set rexp {([ ]+[0-9]+ \|)}
set count_b [regsub -all $rexp $text " NN |" text]
verbose "maybe-handle-nn-line-numbers: count_b: $count_b" 4
verbose "maybe-handle-nn-line-numbers: text after: ${text}" 4
return $text
}
############################################################################
# Internal functions
############################################################################
# Load FILENAME and extract the lines from FIRST_LINE
# to LAST_LINE (inclusive) as a list of strings.
proc _get_lines { filename first_line last_line } {
verbose "_get_lines" 3
verbose " filename: $filename" 3
verbose " first_line: $first_line" 3
verbose " last_line: $last_line" 3
set fp [open $filename r]
set file_data [read $fp]
close $fp
set data [split $file_data "\n"]
set linenum 1
set lines []
foreach line $data {
verbose "line $linenum: $line" 4
if { $linenum >= $first_line && $linenum <= $last_line } {
lappend lines $line
}
set linenum [expr $linenum + 1]
}
return $lines
}
# Convert $multiline from a list of strings to a multiline regex
# We need to support matching arbitrary followup text on each line,
# to deal with comments containing containing DejaGnu directives.
proc _build_multiline_regex { multiline index } {
verbose "_build_multiline_regex: $multiline $index" 4
set rexp ""
foreach line $multiline {
verbose " line: $line" 4
# We need to escape "^" and other regexp metacharacters.
set line [string map {"^" "\\^"
"(" "\\("
")" "\\)"
"[" "\\["
"]" "\\]"
"{" "\\{"
"}" "\\}"
"." "\\."
"\\" "\\\\"
"?" "\\?"
"+" "\\+"
"*" "\\*"
"|" "\\|"} $line]
append rexp $line
if {[string match "*^" $line] || [string match "*~" $line]} {
# Assume a line containing a caret/range. This must be
# an exact match.
} else {
# Assume that we have a quoted source line.
if {![string equal "" $line] } {
# Support arbitrary followup text on each non-empty line,
# to deal with comments containing containing DejaGnu
# directives.
append rexp "\[^\\n\\r\]*"
}
}
append rexp "\n"
}
# dg.exp's dg-test trims leading whitespace from the output
# in this line:
# set comp_output [string trimleft $comp_output]
# so we can't rely on the exact leading whitespace for the
# first line in the *first* multiline regex.
#
# Trim leading whitespace from the regexp, replacing it with
# a "\s*", to match zero or more whitespace characters.
if { $index == 0 } {
set rexp [string trimleft $rexp]
set rexp "\\s*$rexp"
}
verbose "rexp: $rexp" 4
return $rexp
}