gcc/testsuite/lib/multiline.exp - gcc - Git at Google

 #   Copyright (C) 2015-2021 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 ".*"
 	    }
 	}
 	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
 }
	# Copyright (C) 2015-2021 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 ".*"
	}
	}
	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
	}