gcc/testsuite/lib/multiline.exp

   1 #   Copyright (C) 2015-2024 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 # Was dg-enable-nn-line-numbers called?
  64 set nn_line_numbers_enabled 0
  65
  66 ############################################################################
  67 # Exported functions.
  68 ############################################################################
  69
  70 # Mark the beginning of an expected multiline output
  71 # All lines between this and the next dg-end-multiline-output are
  72 # expected to be seen.
  73
  74 proc dg-begin-multiline-output { args } {
  75     global _multiline_last_beginning_line
  76     verbose "dg-begin-multiline-output: args: $args" 3
  77     set line [expr [lindex $args 0] + 1]
  78
  79     # Complain if there hasn't been a dg-end-multiline-output
  80     # since the last dg-begin-multiline-output
  81     if { $_multiline_last_beginning_line != -1 } {
  82         set last_directive_line [expr $_multiline_last_beginning_line - 1]
  83         error "$last_directive_line: unterminated dg-begin-multiline-output"
  84     }
  85
  86     set _multiline_last_beginning_line $line
  87 }
  88
  89 # Mark the end of an expected multiline output
  90 # All lines up to here since the last dg-begin-multiline-output are
  91 # expected to be seen.
  92 #
  93 # dg-end-multiline-output comment [{ target/xfail selector }]
  94
  95 proc dg-end-multiline-output { args } {
  96     global _multiline_last_beginning_line
  97     verbose "dg-end-multiline-output: args: $args" 3
  98     set first_line $_multiline_last_beginning_line
  99
 100     # Complain if there hasn't been a dg-begin-multiline-output
 101     if { $first_line == -1 } {
 102         error "[lindex $args 0]: dg-end-multiline-output without dg-begin-multiline-output"
 103         return
 104     }
 105     set _multiline_last_beginning_line -1
 106
 107     set last_line [expr [lindex $args 0] - 1]
 108     verbose "multiline output lines: $first_line-$last_line" 3
 109
 110     if { [llength $args] > 3 } {
 111         error "[lindex $args 0]: too many arguments"
 112         return
 113     }
 114
 115     set maybe_x ""
 116     if { [llength $args] >= 3 } {
 117         switch [dg-process-target [lindex $args 2]] {
 118             "F" { set maybe_x "x" }
 119             "P" { set maybe_x "" }
 120             "N" {
 121                 # If we get "N", this output doesn't apply to us so ignore it.
 122                 return
 123             }
 124         }
 125     }
 126
 127     upvar 1 prog prog
 128     verbose "prog: $prog" 3
 129     # "prog" now contains the filename
 130     # Load it and split it into lines
 131
 132     set lines [_get_lines $prog $first_line $last_line]
 133
 134     verbose "lines: $lines" 3
 135     # Create an entry of the form:  first-line, last-line, lines, maybe_x
 136     set entry [list $first_line $last_line $lines $maybe_x]
 137     global multiline_expected_outputs
 138     lappend multiline_expected_outputs $entry
 139     verbose "within dg-end-multiline-output: multiline_expected_outputs: $multiline_expected_outputs" 3
 140 }
 141
 142 # Hook to be called by gcc-dg.exp's gcc-dg-prune to
 143 # look for the expected multiline outputs, pruning them,
 144 # reporting PASS for those that are found, and FAIL for
 145 # those that weren't found.
 146 #
 147 # It returns a pruned version of its output.
 148
 149 proc handle-multiline-outputs { text } {
 150     global multiline_expected_outputs
 151     global testname_with_flags
 152
 153     # If dg-enable-nn-line-numbers was provided, then obscure source-margin
 154     # line numbers by converting them to "NN" form.
 155     set text [maybe-handle-nn-line-numbers $text]
 156
 157     set index 0
 158     foreach entry $multiline_expected_outputs {
 159         verbose "  entry: $entry" 3
 160         set start_line [lindex $entry 0]
 161         set end_line   [lindex $entry 1]
 162         set multiline  [lindex $entry 2]
 163         set maybe_x    [lindex $entry 3]
 164         verbose "  multiline: $multiline" 3
 165         set rexp [_build_multiline_regex $multiline $index]
 166         verbose "rexp: ${rexp}" 4
 167         # Escape newlines in $rexp so that we can print them in
 168         # pass/fail results.
 169         set escaped_regex [string map {"\n" "\\n"} $rexp]
 170         verbose "escaped_regex: ${escaped_regex}" 4
 171
 172         set title "$testname_with_flags expected multiline pattern lines $start_line-$end_line"
 173
 174         # Use "regsub" to attempt to prune the pattern from $text
 175         if {[regsub -line $rexp $text "" text]} {
 176             # The multiline pattern was pruned.
 177             ${maybe_x}pass "$title"
 178         } else {
 179             ${maybe_x}fail "$title"
 180         }
 181
 182         set index [expr $index + 1]
 183     }
 184
 185     return $text
 186 }
 187
 188 # DejaGnu directive to enable post-processing the line numbers printed in
 189 # the left-hand margin when printing the source code, converting them to
 190 # "NN", e.g from:
 191 #
 192 #    100 |   if (flag)
 193 #        |      ^
 194 #        |      |
 195 #        |      (1) following 'true' branch...
 196 #    101 |     {
 197 #    102 |       foo ();
 198 #        |       ^
 199 #        |       |
 200 #        |       (2) ...to here
 201 #
 202 # to:
 203 #
 204 #     NN |   if (flag)
 205 #        |      ^
 206 #        |      |
 207 #        |      (1) following 'true' branch...
 208 #     NN |     {
 209 #     NN |       foo ();
 210 #        |       ^
 211 #        |       |
 212 #        |       (2) ...to here
 213 #
 214 # This is useful e.g. when testing how interprocedural paths are printed
 215 # via dg-begin/end-multiline-output, to avoid depending on precise line
 216 # numbers.
 217
 218 proc dg-enable-nn-line-numbers { args } {
 219     verbose "dg-nn-line-numbers: args: $args" 2
 220     global nn_line_numbers_enabled
 221     set nn_line_numbers_enabled 1
 222 }
 223
 224 # Hook to be called by prune.exp's prune_gcc_output to convert such line
 225 # numbers to "NN" form.
 226 #
 227 # Match substrings of the form:
 228 #  "   25 |"
 229 # and convert them to:
 230 #  "   NN |"
 231 #
 232 # It returns a copy of its input, with the above changes.
 233
 234 proc maybe-handle-nn-line-numbers { text } {
 235     global testname_with_flags
 236
 237     verbose "maybe-handle-nn-line-numbers" 3
 238
 239     global nn_line_numbers_enabled
 240     if { [expr {!$nn_line_numbers_enabled}] } {
 241         verbose "nn_line_numbers_enabled false; bailing out" 3
 242         return $text
 243     }
 244
 245     verbose "maybe-handle-nn-line-numbers: text before: ${text}" 4
 246
 247     # dg.exp's dg-test trims leading whitespace from the output
 248     # in this line:
 249     #   set comp_output [string trimleft $comp_output]
 250     # so we can't rely on the exact leading whitespace for the
 251     # first line in the output.
 252     # Match initial input lines that start like:
 253     #  "25 |"
 254     # and convert them to:
 255     #  "   NN |"
 256     set rexp2 {(^[0-9]+ \|)}
 257     set count_a [regsub -all $rexp2 $text "   NN |" text]
 258     verbose "maybe-handle-nn-line-numbers: count_a: $count_a" 4
 259
 260     # Match lines that start like:
 261     #  "   25 |"
 262     # and convert them to:
 263     #  "   NN |"
 264     set rexp {([ ]+[0-9]+ \|)}
 265     set count_b [regsub -all $rexp $text "   NN |" text]
 266     verbose "maybe-handle-nn-line-numbers: count_b: $count_b" 4
 267
 268     verbose "maybe-handle-nn-line-numbers: text after: ${text}" 4
 269
 270     return $text
 271 }
 272
 273 ############################################################################
 274 # Internal functions
 275 ############################################################################
 276
 277 # Load FILENAME and extract the lines from FIRST_LINE
 278 # to LAST_LINE (inclusive) as a list of strings.
 279
 280 proc _get_lines { filename first_line last_line } {
 281     verbose "_get_lines" 3
 282     verbose "  filename: $filename" 3
 283     verbose "  first_line: $first_line" 3
 284     verbose "  last_line: $last_line" 3
 285
 286     set fp [open $filename r]
 287     set file_data [read $fp]
 288     close $fp
 289     set data [split $file_data "\n"]
 290     set linenum 1
 291     set lines []
 292     foreach line $data {
 293         verbose "line $linenum: $line" 4
 294         if { $linenum >= $first_line && $linenum <= $last_line } {
 295             lappend lines $line
 296         }
 297         set linenum [expr $linenum + 1]
 298     }
 299
 300     return $lines
 301 }
 302
 303 # Convert $multiline from a list of strings to a multiline regex
 304 # We need to support matching arbitrary followup text on each line,
 305 # to deal with comments containing DejaGnu directives.
 306
 307 proc _build_multiline_regex { multiline index } {
 308     verbose "_build_multiline_regex: $multiline $index" 4
 309
 310     set rexp ""
 311     foreach line $multiline {
 312         verbose "  line: $line" 4
 313
 314         # We need to escape "^" and other regexp metacharacters.
 315         set line [string map {"\{re:" "("
 316                               ":re?\}" ")?"
 317                               ":re\}" ")"
 318                               "^" "\\^"
 319                               "(" "\\("
 320                               ")" "\\)"
 321                               "[" "\\["
 322                               "]" "\\]"
 323                               "{" "\\{"
 324                               "}" "\\}"
 325                               "." "\\."
 326                               "\\" "\\\\"
 327                               "?" "\\?"
 328                               "+" "\\+"
 329                               "*" "\\*"
 330                               "|" "\\|"} $line]
 331
 332         append rexp $line
 333         if {[string match "*^" $line] || [string match "*~" $line]} {
 334             # Assume a line containing a caret/range.  This must be
 335             # an exact match.
 336         } else {
 337             # Assume that we have a quoted source line.
 338             if {![string equal "" $line] }  {
 339                 # Support arbitrary followup text on each non-empty line,
 340                 # to deal with comments containing containing DejaGnu
 341                 # directives.
 342                 append rexp "\[^\\n\\r\]*"
 343             }
 344         }
 345         append rexp "\n"
 346     }
 347
 348     # dg.exp's dg-test trims leading whitespace from the output
 349     # in this line:
 350     #   set comp_output [string trimleft $comp_output]
 351     # so we can't rely on the exact leading whitespace for the
 352     # first line in the *first* multiline regex.
 353     #
 354     # Trim leading whitespace from the regexp, replacing it with
 355     # a "\s*", to match zero or more whitespace characters.
 356     if { $index == 0 } {
 357         set rexp [string trimleft $rexp]
 358         set rexp "\\s*$rexp"
 359     }
 360
 361     verbose "rexp: $rexp" 4
 362
 363     return $rexp
 364 }