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
  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
  92 proc 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
 146 proc 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
 187 proc _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
 214 proc _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 }