gcc/testsuite/lib/scantree.exp

   1 #   Copyright (C) 2000, 2002, 2003 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 2 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 this program; if not, write to the Free Software
  15 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  16
  17 # Various utilities for scanning tree dump output, used by gcc-dg.exp and
  18 # g++-dg.exp.
  19 #
  20 # This is largely borrowed from scanasm.exp.
  21
  22 # Utility for scanning compiler result, invoked via dg-final.
  23 # Call pass if pattern is present, otherwise fail.
  24 #
  25 # Argument 0 is the regexp to match.
  26 # Argument 1 is the suffix for the tree dump file
  27 # Argument 2 handles expected failures and the like
  28 proc scan-tree-dump { args } {
  29     if { [llength $args] < 2 } {
  30         error "scan-tree-dump: too few arguments"
  31         return
  32     }
  33     if { [llength $args] > 3 } {
  34         error "scan-tree-dump: too many arguments"
  35         return
  36     }
  37     if { [llength $args] >= 3 } {
  38         switch [dg-process-target [lindex $args 2]] {
  39             "S" { }
  40             "N" { return }
  41             "F" { setup_xfail "*-*-*" }
  42             "P" { }
  43         }
  44     }
  45
  46     # This assumes that we are two frames down from dg-test, and that
  47     # it still stores the filename of the testcase in a local variable "name".
  48     # A cleaner solution would require a new dejagnu release.
  49     upvar 2 name testcase
  50
  51     # This must match the rule in gcc-dg.exp.
  52     set src [file tail [lindex $testcase 0]]
  53     set output_file "[glob $src.t??.[lindex $args 1]]"
  54
  55     set fd [open $output_file r]
  56     set text [read $fd]
  57     close $fd
  58
  59     if [regexp -- [lindex $args 0] $text] {
  60         pass "$testcase scan-tree-dump [lindex $args 0]"
  61     } else {
  62         fail "$testcase scan-tree-dump [lindex $args 0]"
  63     }
  64 }
  65
  66 # Call pass if pattern is present given number of times, otherwise fail.
  67 # Argument 0 is the regexp to match.
  68 # Argument 1 is number of times the regexp must be found
  69 # Argument 2 is the suffix for the tree dump file
  70 # Argument 3 handles expected failures and the like
  71 proc scan-tree-dump-times { args } {
  72     if { [llength $args] < 3 } {
  73         error "scan-tree-dump: too few arguments"
  74         return
  75     }
  76     if { [llength $args] > 4 } {
  77         error "scan-tree-dump: too many arguments"
  78         return
  79     }
  80     if { [llength $args] >= 4 } {
  81         switch [dg-process-target [lindex $args 3]] {
  82             "S" { }
  83             "N" { return }
  84             "F" { setup_xfail "*-*-*" }
  85             "P" { }
  86         }
  87     }
  88
  89     # This assumes that we are two frames down from dg-test, and that
  90     # it still stores the filename of the testcase in a local variable "name".
  91     # A cleaner solution would require a new dejagnu release.
  92     upvar 2 name testcase
  93
  94     # This must match the rule in gcc-dg.exp.
  95     set src [file tail [lindex $testcase 0]]
  96     set output_file "[glob $src.t??.[lindex $args 2]]"
  97
  98     set fd [open $output_file r]
  99     set text [read $fd]
 100     close $fd
 101
 102     if { [llength [regexp -inline -all -- [lindex $args 0] $text]] == [lindex $args 1]} {
 103         pass "$testcase scan-tree-dump-times [lindex $args 0] [lindex $args 1]"
 104     } else {
 105         fail "$testcase scan-tree-dump-times [lindex $args 0] [lindex $args 1]"
 106     }
 107 }
 108
 109 # Call pass if pattern is not present, otherwise fail.
 110 #
 111 # Argument 0 is the regexp to match.
 112 # Argument 1 is the suffix for the tree dump file
 113 # Argument 2 handles expected failures and the like
 114 proc scan-tree-dump-not { args } {
 115     if { [llength $args] < 2 } {
 116         error "scan-tree-dump-not: too few arguments"
 117         return
 118     }
 119     if { [llength $args] > 3 } {
 120         error "scan-tree-dump-not: too many arguments"
 121         return
 122     }
 123     if { [llength $args] >= 3 } {
 124         switch [dg-process-target [lindex $args 2]] {
 125             "S" { }
 126             "N" { return }
 127             "F" { setup_xfail "*-*-*" }
 128             "P" { }
 129         }
 130     }
 131
 132     upvar 2 name testcase
 133     set src [file tail [lindex $testcase 0]]
 134     set output_file "[glob $src.t??.[lindex $args 1]]"
 135
 136     set fd [open $output_file r]
 137     set text [read $fd]
 138     close $fd
 139
 140     if ![regexp -- [lindex $args 0] $text] {
 141         pass "$testcase scan-tree-dump-not [lindex $args 0]"
 142     } else {
 143         fail "$testcase scan-tree-dump-not [lindex $args 0]"
 144     }
 145 }
 146
 147 # Utility for scanning demangled compiler result, invoked via dg-final.
 148 # Call pass if pattern is present, otherwise fail.
 149 #
 150 # Argument 0 is the regexp to match.
 151 # Argument 1 is the suffix for the tree dump file
 152 # Argument 2 handles expected failures and the like
 153 proc scan-tree-dump-dem { args } {
 154     global cxxfilt
 155     global base_dir
 156
 157     if { [llength $args] < 2 } {
 158         error "scan-tree-dump-dem: too few arguments"
 159         return
 160     }
 161     if { [llength $args] > 3 } {
 162         error "scan-tree-dump-dem: too many arguments"
 163         return
 164     }
 165     if { [llength $args] >= 3 } {
 166         switch [dg-process-target [lindex $args 2]] {
 167             "S" { }
 168             "N" { return }
 169             "F" { setup_xfail "*-*-*" }
 170             "P" { }
 171         }
 172     }
 173
 174     # Find c++filt like we find g++ in g++.exp.
 175     if ![info exists cxxfilt]  {
 176         set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \
 177                      $base_dir/../../binutils/cxxfilt \
 178                      [findfile $base_dir/../c++filt $base_dir/../c++filt \
 179                       [findfile $base_dir/c++filt $base_dir/c++filt \
 180                        [transform c++filt]]]]
 181         verbose -log "c++filt is $cxxfilt"
 182     }
 183
 184     upvar 2 name testcase
 185     set src [file tail [lindex $testcase 0]]
 186     set output_file "[glob $src.t??.[lindex $args 1]]"
 187
 188     set fd [open "| $cxxfilt < $output_file" r]
 189     set text [read $fd]
 190     close $fd
 191
 192     if [regexp -- [lindex $args 0] $text] {
 193         pass "$testcase scan-tree-dump-dem [lindex $args 0]"
 194     } else {
 195         fail "$testcase scan-tree-dump-dem [lindex $args 0]"
 196     }
 197 }
 198
 199 # Call pass if demangled pattern is not present, otherwise fail.
 200 #
 201 # Argument 0 is the regexp to match.
 202 # Argument 1 is the suffix for the tree dump file
 203 # Argument 2 handles expected failures and the like
 204 proc scan-tree-dump-dem-not { args } {
 205     global cxxfilt
 206     global base_dir
 207
 208     if { [llength $args] < 2 } {
 209         error "scan-tree-dump-dem-not: too few arguments"
 210         return
 211     }
 212     if { [llength $args] > 3 } {
 213         error "scan-tree-dump-dem-not: too many arguments"
 214         return
 215     }
 216     if { [llength $args] >= 3 } {
 217         switch [dg-process-target [lindex $args 2]] {
 218             "S" { }
 219             "N" { return }
 220             "F" { setup_xfail "*-*-*" }
 221             "P" { }
 222         }
 223     }
 224
 225     # Find c++filt like we find g++ in g++.exp.
 226     if ![info exists cxxfilt]  {
 227         set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \
 228                      $base_dir/../../binutils/cxxfilt \
 229                      [findfile $base_dir/../c++filt $base_dir/../c++filt \
 230                       [findfile $base_dir/c++filt $base_dir/c++filt \
 231                        [transform c++filt]]]]
 232         verbose -log "c++filt is $cxxfilt"
 233     }
 234
 235     upvar 2 name testcase
 236     set src [file tail [lindex $testcase 0]]
 237     set output_file "[glob $src.t??.[lindex $args 1]]"
 238
 239     set fd [open "| $cxxfilt < $output_file" r]
 240     set text [read $fd]
 241     close $fd
 242
 243     if ![regexp -- [lindex $args 0] $text] {
 244         pass "$testcase scan-tree-dump-dem-not [lindex $args 0]"
 245     } else {
 246         fail "$testcase scan-tree-dump-dem-not [lindex $args 0]"
 247     }
 248 }