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 testname "$testcase scan-[lindex $args 0]-dump-times $suf \"[lindex $args 1]\" [lindex $args 2]"
  98     set src [file tail [lindex $testcase 0]]
  99     set output_file "[glob -nocomplain $src.[lindex $args 3]]"
 100     if { $output_file == "" } {
 101         verbose -log "$testcase: dump file does not exist"
 102         unresolved "$testname"
 103         return
 104     }
 105
 106     set fd [open $output_file r]
 107     set text [read $fd]
 108     close $fd
 109
 110     if { [llength [regexp -inline -all -- [lindex $args 1] $text]] == [lindex $args 2]} {
 111         pass "$testname"
 112     } else {
 113         fail "$testname"
 114     }
 115 }
 116
 117 # Call pass if pattern is not present, otherwise fail.
 118 #
 119 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 120 # Argument 1 is the regexp to match.
 121 # Argument 2 is the suffix for the dump file
 122 # Argument 3 handles expected failures and the like
 123 proc scan-dump-not { args } {
 124
 125     if { [llength $args] >= 4 } {
 126         switch [dg-process-target [lindex $args 3]] {
 127             "S" { }
 128             "N" { return }
 129             "F" { setup_xfail "*-*-*" }
 130             "P" { }
 131         }
 132     }
 133
 134     # This assumes that we are three frames down from dg-test, and that
 135     # it still stores the filename of the testcase in a local variable "name".
 136     # A cleaner solution would require a new DejaGnu release.
 137     upvar 3 name testcase
 138
 139     set suf [dump-suffix [lindex $args 2]]
 140     set testname "$testcase scan-[lindex $args 0]-dump-not $suf \"[lindex $args 1]\""
 141     set src [file tail [lindex $testcase 0]]
 142     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 143     if { $output_file == "" } {
 144         verbose -log "$testcase: dump file does not exist"
 145         unresolved "$testname"
 146         return
 147     }
 148
 149     set fd [open $output_file r]
 150     set text [read $fd]
 151     close $fd
 152
 153     if ![regexp -- [lindex $args 1] $text] {
 154         pass "$testname"
 155     } else {
 156         fail "$testname"
 157     }
 158 }
 159
 160 # Utility for scanning demangled compiler result, invoked via dg-final.
 161 # Call pass if pattern is present, otherwise fail.
 162 #
 163 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 164 # Argument 1 is the regexp to match.
 165 # Argument 2 is the suffix for the dump file
 166 # Argument 3 handles expected failures and the like
 167 proc scan-dump-dem { args } {
 168     global cxxfilt
 169     global base_dir
 170
 171     if { [llength $args] >= 4 } {
 172         switch [dg-process-target [lindex $args 3]] {
 173             "S" { }
 174             "N" { return }
 175             "F" { setup_xfail "*-*-*" }
 176             "P" { }
 177         }
 178     }
 179
 180     # Find c++filt like we find g++ in g++.exp.
 181     if ![info exists cxxfilt]  {
 182         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 183                      $base_dir/../../../binutils/cxxfilt \
 184                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 185                       [findfile $base_dir/c++filt $base_dir/c++filt \
 186                        [transform c++filt]]]]
 187         verbose -log "c++filt is $cxxfilt"
 188     }
 189
 190     upvar 3 name testcase
 191     set suf [dump-suffix [lindex $args 2]]
 192     set testname "$testcase scan-[lindex $args 0]-dump-dem $suf \"[lindex $args 1]\""
 193     set src [file tail [lindex $testcase 0]]
 194     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 195     if { $output_file == "" } {
 196         verbose -log "$testcase: dump file does not exist"
 197         unresolved "$testname"
 198         return
 199     }
 200
 201     set fd [open "| $cxxfilt < $output_file" r]
 202     set text [read $fd]
 203     close $fd
 204
 205     if [regexp -- [lindex $args 1] $text] {
 206         pass "$testname"
 207     } else {
 208         fail "$testname"
 209     }
 210 }
 211
 212 # Call pass if demangled pattern is not present, otherwise fail.
 213 #
 214 # Argument 0 is the type of dump we are searching (rtl, tree, ipa)
 215 # Argument 1 is the regexp to match.
 216 # Argument 2 is the suffix for the dump file
 217 # Argument 3 handles expected failures and the like
 218 proc scan-dump-dem-not { args } {
 219     global cxxfilt
 220     global base_dir
 221
 222     if { [llength $args] >= 4 } {
 223         switch [dg-process-target [lindex $args 3]] {
 224             "S" { }
 225             "N" { return }
 226             "F" { setup_xfail "*-*-*" }
 227             "P" { }
 228         }
 229     }
 230
 231     # Find c++filt like we find g++ in g++.exp.
 232     if ![info exists cxxfilt]  {
 233         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 234                      $base_dir/../../../binutils/cxxfilt \
 235                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 236                       [findfile $base_dir/c++filt $base_dir/c++filt \
 237                        [transform c++filt]]]]
 238         verbose -log "c++filt is $cxxfilt"
 239     }
 240
 241     upvar 3 name testcase
 242
 243     set suf [dump-suffix [lindex $args 2]]
 244     set testname "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"[lindex $args 1]\""
 245     set src [file tail [lindex $testcase 0]]
 246     set output_file "[glob -nocomplain $src.[lindex $args 2]]"
 247     if { $output_file == "" } {
 248         verbose -log "$testcase: dump file does not exist"
 249         unresolved "$testname"
 250         return
 251     }
 252
 253     set fd [open "| $cxxfilt < $output_file" r]
 254     set text [read $fd]
 255     close $fd
 256
 257     if ![regexp -- [lindex $args 1] $text] {
 258         pass "$testname"
 259     } else {
 260         fail "$testname"
 261     }
 262 }