gcc/testsuite/lib/scandump.exp

   1 # Copyright (C) 2000, 2002, 2003, 2005, 2007, 2008
   2 # Free Software Foundation, Inc.
   3
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 3 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with GCC; see the file COPYING3.  If not see
  16 # <http://www.gnu.org/licenses/>.
  17
  18 # Various utilities for scanning dump output, used by gcc-dg.exp and
  19 # g++-dg.exp.
  20 #
  21 # This is largely borrowed from scanasm.exp.
  22
  23 # Extract the constant part of the dump file suffix from the regexp.
  24 # Argument 0 is the regular expression.
  25 proc dump-suffix { arg } {
  26     set idx [expr [string last "." $arg] + 1]
  27     return [string range $arg $idx end]
  28 }
  29
  30 # Utility for scanning compiler result, invoked via dg-final.
  31 # Call pass if pattern is present, otherwise fail.
  32 #
  33 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
  34 # Argument 1 is the regexp to match.
  35 # Argument 2 is the suffix for the dump file
  36 # Argument 3 handles expected failures and the like
  37 proc scan-dump { args } {
  38
  39     if { [llength $args] >= 4 } {
  40         switch [dg-process-target [lindex $args 3]] {
  41             "S" { }
  42             "N" { return }
  43             "F" { setup_xfail "*-*-*" }
  44             "P" { }
  45         }
  46     }
  47
  48     # This assumes that we are three frames down from dg-test, and that
  49     # it still stores the filename of the testcase in a local variable "name".
  50     # A cleaner solution would require a new DejaGnu release.
  51     upvar 3 name testcase
  52
  53     set suf [dump-suffix [lindex $args 2]]
  54     set testname "$testcase scan-[lindex $args 0]-dump $suf \"[lindex $args 1]\""
  55     set src [file tail [lindex $testcase 0]]
  56     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
  57     if { $output_file == "" } {
  58         verbose -log "$testcase: dump file does not exist"
  59         unresolved "$testname"
  60         return
  61     }
  62
  63     set fd [open $output_file r]
  64     set text [read $fd]
  65     close $fd
  66
  67     if [regexp -- [lindex $args 1] $text] {
  68         pass "$testname"
  69     } else {
  70         fail "$testname"
  71     }
  72 }
  73
  74 # Call pass if pattern is present given number of times, otherwise fail.
  75 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
  76 # Argument 1 is the regexp to match.
  77 # Argument 2 is number of times the regexp must be found
  78 # Argument 3 is the suffix for the dump file
  79 # Argument 4 handles expected failures and the like
  80 proc scan-dump-times { args } {
  81
  82     if { [llength $args] >= 5 } {
  83         switch [dg-process-target [lindex $args 4]] {
  84             "S" { }
  85             "N" { return }
  86             "F" { setup_xfail "*-*-*" }
  87             "P" { }
  88         }
  89     }
  90
  91     # This assumes that we are three frames down from dg-test, and that
  92     # it still stores the filename of the testcase in a local variable "name".
  93     # A cleaner solution would require a new DejaGnu release.
  94     upvar 3 name testcase
  95
  96     set suf [dump-suffix [lindex $args 3]]
  97     set printable_pattern [make_pattern_printable [lindex $args 1]]
  98     set testname "$testcase scan-[lindex $args 0]-dump-times $suf \"$printable_pattern\" [lindex $args 2]"
  99     set src [file tail [lindex $testcase 0]]
 100     set output_file "[glob -nocomplain $src.[lindex $args 3]]"
 101     if { $output_file == "" } {
 102         verbose -log "$testcase: dump file does not exist"
 103         unresolved "$testname"
 104         return
 105     }
 106
 107     set fd [open $output_file r]
 108     set text [read $fd]
 109     close $fd
 110
 111     if { [llength [regexp -inline -all -- [lindex $args 1] $text]] == [lindex $args 2]} {
 112         pass "$testname"
 113     } else {
 114         fail "$testname"
 115     }
 116 }
 117
 118 # Call pass if pattern is not present, otherwise fail.
 119 #
 120 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 121 # Argument 1 is the regexp to match.
 122 # Argument 2 is the suffix for the dump file
 123 # Argument 3 handles expected failures and the like
 124 proc scan-dump-not { args } {
 125
 126     if { [llength $args] >= 4 } {
 127         switch [dg-process-target [lindex $args 3]] {
 128             "S" { }
 129             "N" { return }
 130             "F" { setup_xfail "*-*-*" }
 131             "P" { }
 132         }
 133     }
 134
 135     # This assumes that we are three frames down from dg-test, and that
 136     # it still stores the filename of the testcase in a local variable "name".
 137     # A cleaner solution would require a new DejaGnu release.
 138     upvar 3 name testcase
 139
 140     set suf [dump-suffix [lindex $args 2]]
 141     set testname "$testcase scan-[lindex $args 0]-dump-not $suf \"[lindex $args 1]\""
 142     set src [file tail [lindex $testcase 0]]
 143     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 144     if { $output_file == "" } {
 145         verbose -log "$testcase: dump file does not exist"
 146         unresolved "$testname"
 147         return
 148     }
 149
 150     set fd [open $output_file r]
 151     set text [read $fd]
 152     close $fd
 153
 154     if ![regexp -- [lindex $args 1] $text] {
 155         pass "$testname"
 156     } else {
 157         fail "$testname"
 158     }
 159 }
 160
 161 # Utility for scanning demangled compiler result, invoked via dg-final.
 162 # Call pass if pattern is present, otherwise fail.
 163 #
 164 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 165 # Argument 1 is the regexp to match.
 166 # Argument 2 is the suffix for the dump file
 167 # Argument 3 handles expected failures and the like
 168 proc scan-dump-dem { args } {
 169     global cxxfilt
 170     global base_dir
 171
 172     if { [llength $args] >= 4 } {
 173         switch [dg-process-target [lindex $args 3]] {
 174             "S" { }
 175             "N" { return }
 176             "F" { setup_xfail "*-*-*" }
 177             "P" { }
 178         }
 179     }
 180
 181     # Find c++filt like we find g++ in g++.exp.
 182     if ![info exists cxxfilt]  {
 183         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 184                      $base_dir/../../../binutils/cxxfilt \
 185                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 186                       [findfile $base_dir/c++filt $base_dir/c++filt \
 187                        [transform c++filt]]]]
 188         verbose -log "c++filt is $cxxfilt"
 189     }
 190
 191     upvar 3 name testcase
 192     set suf [dump-suffix [lindex $args 2]]
 193     set testname "$testcase scan-[lindex $args 0]-dump-dem $suf \"[lindex $args 1]\""
 194     set src [file tail [lindex $testcase 0]]
 195     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 196     if { $output_file == "" } {
 197         verbose -log "$testcase: dump file does not exist"
 198         unresolved "$testname"
 199         return
 200     }
 201
 202     set fd [open "| $cxxfilt < $output_file" r]
 203     set text [read $fd]
 204     close $fd
 205
 206     if [regexp -- [lindex $args 1] $text] {
 207         pass "$testname"
 208     } else {
 209         fail "$testname"
 210     }
 211 }
 212
 213 # Call pass if demangled pattern is not present, otherwise fail.
 214 #
 215 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 216 # Argument 1 is the regexp to match.
 217 # Argument 2 is the suffix for the dump file
 218 # Argument 3 handles expected failures and the like
 219 proc scan-dump-dem-not { args } {
 220     global cxxfilt
 221     global base_dir
 222
 223     if { [llength $args] >= 4 } {
 224         switch [dg-process-target [lindex $args 3]] {
 225             "S" { }
 226             "N" { return }
 227             "F" { setup_xfail "*-*-*" }
 228             "P" { }
 229         }
 230     }
 231
 232     # Find c++filt like we find g++ in g++.exp.
 233     if ![info exists cxxfilt]  {
 234         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 235                      $base_dir/../../../binutils/cxxfilt \
 236                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 237                       [findfile $base_dir/c++filt $base_dir/c++filt \
 238                        [transform c++filt]]]]
 239         verbose -log "c++filt is $cxxfilt"
 240     }
 241
 242     upvar 3 name testcase
 243
 244     set suf [dump-suffix [lindex $args 2]]
 245     set testname "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"[lindex $args 1]\""
 246     set src [file tail [lindex $testcase 0]]
 247     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 248     if { $output_file == "" } {
 249         verbose -log "$testcase: dump file does not exist"
 250         unresolved "$testname"
 251         return
 252     }
 253
 254     set fd [open "| $cxxfilt < $output_file" r]
 255     set text [read $fd]
 256     close $fd
 257
 258     if ![regexp -- [lindex $args 1] $text] {
 259         pass "$testname"
 260     } else {
 261         fail "$testname"
 262     }
 263 }