gcc/testsuite/lib/scandump.exp

   1 # Copyright (C) 2000-2025 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 # Various utilities for scanning dump output, used by gcc-dg.exp and
  18 # g++-dg.exp.
  19 #
  20 # This is largely borrowed from scanasm.exp.
  21
  22 # Extract the constant part of the dump file suffix from the regexp.
  23 # Argument 0 is the regular expression.
  24 proc dump-suffix { arg } {
  25     set idx [expr [string first "." $arg] + 1]
  26     return [string range $arg $idx end]
  27 }
  28
  29 # Construct the dumpbase.
  30 # Argument 0 is the src file
  31 # Argument 1 is the dump base suffix
  32 proc dump-base { args } {
  33     set src [lindex $args 0]
  34     set dumpbase_suf [lindex $args 1]
  35     # The dump basename may vary depending on the output name, on
  36     # whether there are multiple sources.  We use -dumpbase "" in
  37     # gcc-defs to base compilation dumps only on the source basename.
  38     set dumpbase $src
  39     if { [string length $dumpbase_suf] != 0 } {
  40         # Accept {} as dump base suffix to drop the source suffix entirely.
  41         if { "$dumpbase_suf" == "{}" } {
  42             set dumpbase_suf ""
  43         }
  44         regsub {[.][^.]*$} $src $dumpbase_suf dumpbase
  45     }
  46     return $dumpbase
  47 }
  48
  49 # Expand dump file name pattern to exactly one file.
  50 # Return a single dump file name or an empty string
  51 # if the pattern matches no file or more than one file.
  52 #
  53 # Argument 0 is the testcase name
  54 # Argument 1 is the dump file glob pattern
  55 proc glob-dump-file { args } {
  56
  57     set pattern [lindex $args 1]
  58     set dump_file "[glob -nocomplain $pattern]"
  59     set num_files [llength $dump_file]
  60
  61     if { $num_files != 1 } {
  62         set testcase [lindex $args 0]
  63         if { $num_files == 0 } {
  64             verbose -log "$testcase: dump file does not exist"
  65         }
  66
  67         if { $num_files > 1 } {
  68             verbose -log "$testcase: multiple dump files found"
  69         }
  70
  71         return
  72     }
  73
  74     return $dump_file
  75 }
  76
  77 # Utility for scanning compiler result, invoked via dg-final.
  78 # Call pass if pattern is present, otherwise fail.
  79 #
  80 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
  81 # Argument 1 is the regexp to match.
  82 # Argument 2 is the suffix for the dump file
  83 # Argument 3 is the suffix of the dump base
  84 # Argument 4 handles expected failures and the like
  85 proc scan-dump { args } {
  86
  87     if { [llength $args] >= 5 } {
  88         switch [dg-process-target [lindex $args 4]] {
  89             "S" { }
  90             "N" { return }
  91             "F" { setup_xfail "*-*-*" }
  92             "P" { }
  93         }
  94     }
  95
  96     set testcase [testname-for-summary]
  97     # The name might include a list of options; extract the file name.
  98     set filename [lindex $testcase 0]
  99
 100     set printable_pattern [make_pattern_printable [lindex $args 1]]
 101     set suf [dump-suffix [lindex $args 2]]
 102     set testname "$testcase scan-[lindex $args 0]-dump $suf \"$printable_pattern\""
 103     set src [file tail $filename]
 104     set dumpbase [dump-base $src [lindex $args 3]]
 105
 106     set pattern "$dumpbase.[lindex $args 2]"
 107     set output_file "[glob-dump-file $testcase $pattern]"
 108     if { $output_file == "" } {
 109         unresolved "$testname"
 110         return
 111     }
 112
 113     set fd [open $output_file r]
 114     set text [read $fd]
 115     close $fd
 116
 117     if [regexp -- [lindex $args 1] $text] {
 118         pass "$testname"
 119     } else {
 120         fail "$testname"
 121     }
 122 }
 123
 124 # Call pass if pattern is present given number of times, otherwise fail.
 125 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 126 # Argument 1 is the regexp to match.
 127 # Argument 2 is number of times the regexp must be found
 128 # Argument 3 is the suffix for the dump file
 129 # Argument 4 is the suffix of the dump base
 130 # Argument 5 handles expected failures and the like
 131 proc scan-dump-times { args } {
 132
 133     if { [llength $args] >= 6 } {
 134         switch [dg-process-target [lindex $args 5]] {
 135             "S" { }
 136             "N" { return }
 137             "F" { setup_xfail "*-*-*" }
 138             "P" { }
 139         }
 140     }
 141
 142     set testcase [testname-for-summary]
 143     # The name might include a list of options; extract the file name.
 144     set filename [lindex $testcase 0]
 145     set times [lindex $args 2]
 146     set suf [dump-suffix [lindex $args 3]]
 147     set printable_pattern [make_pattern_printable [lindex $args 1]]
 148     set testname "$testcase scan-[lindex $args 0]-dump-times $suf \"$printable_pattern\" [lindex $args 2]"
 149     set src [file tail $filename]
 150     set dumpbase [dump-base $src [lindex $args 4]]
 151
 152     set pattern "$dumpbase.[lindex $args 3]"
 153     set output_file "[glob-dump-file $testcase $pattern]"
 154     if { $output_file == "" } {
 155         unresolved "$testname"
 156         return
 157     }
 158
 159     set fd [open $output_file r]
 160     set text [read $fd]
 161     close $fd
 162
 163     set result_count [llength [regexp -inline -all -- [lindex $args 1] $text]]
 164     if {$result_count == $times} {
 165         pass "$testname"
 166     } else {
 167         verbose -log "$testcase: pattern found $result_count times"
 168         fail "$testname"
 169     }
 170 }
 171
 172 # Call pass if pattern is not present, otherwise fail.
 173 #
 174 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 175 # Argument 1 is the regexp to match.
 176 # Argument 2 is the suffix for the dump file
 177 # Argument 3 is the suffix of the dump base
 178 # Argument 4 handles expected failures and the like
 179 proc scan-dump-not { args } {
 180
 181     if { [llength $args] >= 5 } {
 182         switch [dg-process-target [lindex $args 4]] {
 183             "S" { }
 184             "N" { return }
 185             "F" { setup_xfail "*-*-*" }
 186             "P" { }
 187         }
 188     }
 189
 190     set testcase [testname-for-summary]
 191     # The name might include a list of options; extract the file name.
 192     set filename [lindex $testcase 0]
 193     set printable_pattern [make_pattern_printable [lindex $args 1]]
 194     set suf [dump-suffix [lindex $args 2]]
 195     set testname "$testcase scan-[lindex $args 0]-dump-not $suf \"$printable_pattern\""
 196     set src [file tail $filename]
 197     set dumpbase [dump-base $src [lindex $args 3]]
 198
 199     set pattern "$dumpbase.[lindex $args 2]"
 200     set output_file "[glob-dump-file $testcase $pattern]"
 201     if { $output_file == "" } {
 202         unresolved "$testname"
 203         return
 204     }
 205
 206     set fd [open $output_file r]
 207     set text [read $fd]
 208     close $fd
 209
 210     if ![regexp -- [lindex $args 1] $text] {
 211         pass "$testname"
 212     } else {
 213         fail "$testname"
 214     }
 215 }
 216
 217 # Utility for scanning demangled compiler result, invoked via dg-final.
 218 # Call pass if pattern is present, otherwise fail.
 219 #
 220 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 221 # Argument 1 is the regexp to match.
 222 # Argument 2 is the suffix for the dump file
 223 # Argument 3 is the suffix of the dump base
 224 # Argument 4 handles expected failures and the like
 225 proc scan-dump-dem { args } {
 226     global cxxfilt
 227     global base_dir
 228
 229     if { [llength $args] >= 5 } {
 230         switch [dg-process-target [lindex $args 4]] {
 231             "S" { }
 232             "N" { return }
 233             "F" { setup_xfail "*-*-*" }
 234             "P" { }
 235         }
 236     }
 237
 238     # Find c++filt like we find g++ in g++.exp.
 239     if ![info exists cxxfilt]  {
 240         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 241                      $base_dir/../../../binutils/cxxfilt \
 242                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 243                       [findfile $base_dir/c++filt $base_dir/c++filt \
 244                        [transform c++filt]]]]
 245         verbose -log "c++filt is $cxxfilt"
 246     }
 247
 248     set testcase [testname-for-summary]
 249     # The name might include a list of options; extract the file name.
 250     set filename [lindex $testcase 0]
 251     set printable_pattern [make_pattern_printable [lindex $args 1]]
 252     set suf [dump-suffix [lindex $args 2]]
 253     set testname "$testcase scan-[lindex $args 0]-dump-dem $suf \"$printable_pattern\""
 254     set src [file tail $filename]
 255     set dumpbase [dump-base $src [lindex $args 3]]
 256
 257     set pattern "$dumpbase.[lindex $args 2]"
 258     set output_file "[glob-dump-file $testcase $pattern]"
 259     if { $output_file == "" } {
 260         unresolved "$testname"
 261         return
 262     }
 263
 264     set fd [open "| $cxxfilt < $output_file" r]
 265     set text [read $fd]
 266     close $fd
 267
 268     if [regexp -- [lindex $args 1] $text] {
 269         pass "$testname"
 270     } else {
 271         fail "$testname"
 272     }
 273 }
 274
 275 # Call pass if demangled pattern is not present, otherwise fail.
 276 #
 277 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 278 # Argument 1 is the regexp to match.
 279 # Argument 2 is the suffix for the dump file
 280 # Argument 3 is the suffix of the dump base
 281 # Argument 4 handles expected failures and the like
 282 proc scan-dump-dem-not { args } {
 283     global cxxfilt
 284     global base_dir
 285
 286     if { [llength $args] >= 5 } {
 287         switch [dg-process-target [lindex $args 4]] {
 288             "S" { }
 289             "N" { return }
 290             "F" { setup_xfail "*-*-*" }
 291             "P" { }
 292         }
 293     }
 294
 295     # Find c++filt like we find g++ in g++.exp.
 296     if ![info exists cxxfilt]  {
 297         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 298                      $base_dir/../../../binutils/cxxfilt \
 299                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 300                       [findfile $base_dir/c++filt $base_dir/c++filt \
 301                        [transform c++filt]]]]
 302         verbose -log "c++filt is $cxxfilt"
 303     }
 304
 305     set testcase [testname-for-summary]
 306     # The name might include a list of options; extract the file name.
 307     set filename [lindex $testcase 0]
 308     set printable_pattern [make_pattern_printable [lindex $args 1]]
 309     set suf [dump-suffix [lindex $args 2]]
 310     set testname "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"$printable_pattern\""
 311     set src [file tail $filename]
 312     set dumpbase [dump-base $src [lindex $args 3]]
 313
 314     set pattern "$dumpbase.[lindex $args 2]"
 315     set output_file "[glob-dump-file $testcase $pattern]"
 316     if { $output_file == "" } {
 317         unresolved "$testname"
 318         return
 319     }
 320
 321     set fd [open "| $cxxfilt < $output_file" r]
 322     set text [read $fd]
 323     close $fd
 324
 325     if ![regexp -- [lindex $args 1] $text] {
 326         pass "$testname"
 327     } else {
 328         fail "$testname"
 329     }
 330 }