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