gcc/testsuite/lib/multiline.exp

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