gcc/testsuite/lib/scanasm.exp

   1 # Copyright (C) 2000, 2002, 2003, 2007, 2008, 2010
   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 assembler output, used by gcc-dg.exp and
  19 # g++-dg.exp.
  20
  21 # Utility for scanning compiler result, invoked via dg-final.
  22
  23 # Transform newline and similar characters into their escaped form.
  24 proc make_pattern_printable { pattern } {
  25     return [string map {\t \\t \n \\n \r \\r \\ \\\\} $pattern]
  26 }
  27
  28 # Scan the OUTPUT_FILE for a pattern.  If it is present and POSITIVE
  29 # is non-zero, or it is not present and POSITIVE is zero, the test
  30 # passes.  The ORIG_ARGS is the list of arguments provided by dg-final
  31 # to scan-assembler.  The first element in ORIG_ARGS is the regular
  32 # expression to look for in the file.  The second element, if present,
  33 # is a DejaGNU target selector.
  34
  35 proc dg-scan { name positive testcase output_file orig_args } {
  36     if { [llength $orig_args] < 1 } {
  37         error "$name: too few arguments"
  38         return
  39     }
  40     if { [llength $orig_args] > 2 } {
  41         error "$name: too many arguments"
  42         return
  43     }
  44     if { [llength $orig_args] >= 2 } {
  45         switch [dg-process-target [lindex $orig_args 1]] {
  46             "S" { }
  47             "N" { return }
  48             "F" { setup_xfail "*-*-*" }
  49             "P" { }
  50         }
  51     }
  52
  53     if { [is_remote host] } {
  54         remote_upload host "$output_file"
  55     }
  56     set fd [open $output_file r]
  57     set text [read $fd]
  58     close $fd
  59
  60     set pattern [lindex $orig_args 0]
  61     set printable_pattern [make_pattern_printable $pattern]
  62
  63     set match [regexp -- $pattern $text]
  64     if { $match == $positive } {
  65         pass "$testcase $name $printable_pattern"
  66     } else {
  67         fail "$testcase $name $printable_pattern"
  68     }
  69 }
  70
  71 # Look for a pattern in the .s file produced by the compiler.  See
  72 # dg-scan for details.
  73
  74 proc scan-assembler { args } {
  75     upvar 2 name testcase
  76     set testcase [lindex $testcase 0]
  77     set output_file "[file rootname [file tail $testcase]].s"
  78
  79     dg-scan "scan-assembler" 1 $testcase $output_file $args
  80 }
  81
  82 # Check that a pattern is not present in the .s file produced by the
  83 # compiler.  See dg-scan for details.
  84
  85 proc scan-assembler-not { args } {
  86     upvar 2 name testcase
  87     set testcase [lindex $testcase 0]
  88     set output_file "[file rootname [file tail $testcase]].s"
  89
  90     dg-scan "scan-assembler-not" 0 $testcase $output_file $args
  91 }
  92
  93 # Return the scan for the assembly for hidden visibility.
  94
  95 proc hidden-scan-for { symbol } {
  96
  97     set objformat [gcc_target_object_format]
  98
  99     switch $objformat {
 100         elf      { return "hidden\[ \t_\]*$symbol" }
 101         mach-o   { return "private_extern\[ \t_\]*_?$symbol" }
 102         default  { return "" }
 103     }
 104
 105 }
 106
 107
 108 # Check that a symbol is defined as a hidden symbol in the .s file
 109 # produced by the compiler.
 110
 111 proc scan-hidden { args } {
 112     upvar 2 name testcase
 113     set testcase [lindex $testcase 0]
 114     set output_file "[file rootname [file tail $testcase]].s"
 115
 116     set symbol [lindex $args 0]
 117
 118     set hidden_scan [hidden-scan-for $symbol]
 119
 120     set args [lreplace $args 0 0 "$hidden_scan"]
 121
 122     dg-scan "scan-hidden" 1 $testcase $output_file $args
 123 }
 124
 125 # Check that a symbol is not defined as a hidden symbol in the .s file
 126 # produced by the compiler.
 127
 128 proc scan-not-hidden { args } {
 129     upvar 2 name testcase
 130     set testcase [lindex $testcase 0]
 131     set output_file "[file rootname [file tail $testcase]].s"
 132
 133     set symbol [lindex $args 0]
 134     set hidden_scan [hidden-scan-for $symbol]
 135
 136     set args [lreplace $args 0 0 "$hidden_scan"]
 137
 138     dg-scan "scan-not-hidden" 0 $testcase $output_file $args
 139 }
 140
 141 # Look for a pattern in OUTPUT_FILE.  See dg-scan for details.
 142
 143 proc scan-file { output_file args } {
 144     upvar 2 name testcase
 145     set testcase [lindex $testcase 0]
 146     dg-scan "scan-file" 1 $testcase $output_file $args
 147 }
 148
 149 # Check that a pattern is not present in the OUTPUT_FILE.  See dg-scan
 150 # for details.
 151
 152 proc scan-file-not { output_file args } {
 153     upvar 2 name testcase
 154     set testcase [lindex $testcase 0]
 155     dg-scan "scan-file-not" 0 $testcase $output_file $args
 156 }
 157
 158 # Look for a pattern in the .su file produced by the compiler.  See
 159 # dg-scan for details.
 160
 161 proc scan-stack-usage { args } {
 162     upvar 2 name testcase
 163     set testcase [lindex $testcase 0]
 164     set output_file "[file rootname [file tail $testcase]].su"
 165
 166     dg-scan "scan-file" 1 $testcase $output_file $args
 167 }
 168
 169 # Check that a pattern is not present in the .su file produced by the
 170 # compiler.  See dg-scan for details.
 171
 172 proc scan-stack-usage-not { args } {
 173     upvar 2 name testcase
 174     set testcase [lindex $testcase 0]
 175     set output_file "[file rootname [file tail $testcase]].su"
 176
 177     dg-scan "scan-file-not" 0 $testcase $output_file $args
 178 }
 179
 180 # Call pass if pattern is present given number of times, otherwise fail.
 181 proc scan-assembler-times { args } {
 182     if { [llength $args] < 2 } {
 183         error "scan-assembler: too few arguments"
 184         return
 185     }
 186     if { [llength $args] > 3 } {
 187         error "scan-assembler: too many arguments"
 188         return
 189     }
 190     if { [llength $args] >= 3 } {
 191         switch [dg-process-target [lindex $args 2]] {
 192             "S" { }
 193             "N" { return }
 194             "F" { setup_xfail "*-*-*" }
 195             "P" { }
 196         }
 197     }
 198
 199     # This assumes that we are two frames down from dg-test, and that
 200     # it still stores the filename of the testcase in a local variable "name".
 201     # A cleaner solution would require a new dejagnu release.
 202     upvar 2 name testcase
 203     set testcase [lindex $testcase 0]
 204
 205     # This must match the rule in gcc-dg.exp.
 206     set output_file "[file rootname [file tail $testcase]].s"
 207
 208     set fd [open $output_file r]
 209     set text [read $fd]
 210     close $fd
 211
 212     set pattern [lindex $args 0]
 213     set pp_pattern [make_pattern_printable $pattern]
 214     if { [llength [regexp -inline -all -- $pattern $text]] == [lindex $args 1]} {
 215         pass "$testcase scan-assembler-times $pp_pattern [lindex $args 1]"
 216     } else {
 217         fail "$testcase scan-assembler-times $pp_pattern [lindex $args 1]"
 218     }
 219 }
 220
 221 # Utility for scanning demangled compiler result, invoked via dg-final.
 222 # Call pass if pattern is present, otherwise fail.
 223 proc scan-assembler-dem { args } {
 224     global cxxfilt
 225     global base_dir
 226
 227     if { [llength $args] < 1 } {
 228         error "scan-assembler-dem: too few arguments"
 229         return
 230     }
 231     if { [llength $args] > 2 } {
 232         error "scan-assembler-dem: too many arguments"
 233         return
 234     }
 235     if { [llength $args] >= 2 } {
 236         switch [dg-process-target [lindex $args 1]] {
 237             "S" { }
 238             "N" { return }
 239             "F" { setup_xfail "*-*-*" }
 240             "P" { }
 241         }
 242     }
 243
 244     # Find c++filt like we find g++ in g++.exp.
 245     if ![info exists cxxfilt]  {
 246         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 247                      $base_dir/../../../binutils/cxxfilt \
 248                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 249                       [findfile $base_dir/c++filt $base_dir/c++filt \
 250                        [transform c++filt]]]]
 251         verbose -log "c++filt is $cxxfilt"
 252     }
 253
 254     upvar 2 name testcase
 255     set testcase [lindex $testcase 0]
 256     set output_file "[file rootname [file tail $testcase]].s"
 257
 258     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 259     set text [lindex $output 1]
 260
 261     set pattern [lindex $args 0]
 262     set pp_pattern [make_pattern_printable $pattern]
 263     if [regexp -- $pattern $text] {
 264         pass "$testcase scan-assembler-dem $pp_pattern"
 265     } else {
 266         fail "$testcase scan-assembler-dem $pp_pattern"
 267     }
 268 }
 269
 270 # Call pass if demangled pattern is not present, otherwise fail.
 271 proc scan-assembler-dem-not { args } {
 272     global cxxfilt
 273     global base_dir
 274
 275     if { [llength $args] < 1 } {
 276         error "scan-assembler-dem-not: too few arguments"
 277         return
 278     }
 279     if { [llength $args] > 2 } {
 280         error "scan-assembler-dem-not: too many arguments"
 281         return
 282     }
 283     if { [llength $args] >= 2 } {
 284         switch [dg-process-target [lindex $args 1]] {
 285             "S" { }
 286             "N" { return }
 287             "F" { setup_xfail "*-*-*" }
 288             "P" { }
 289         }
 290     }
 291
 292     # Find c++filt like we find g++ in g++.exp.
 293     if ![info exists cxxfilt]  {
 294         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 295                      $base_dir/../../../binutils/cxxfilt \
 296                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 297                       [findfile $base_dir/c++filt $base_dir/c++filt \
 298                        [transform c++filt]]]]
 299         verbose -log "c++filt is $cxxfilt"
 300     }
 301
 302     upvar 2 name testcase
 303     set testcase [lindex $testcase 0]
 304     set output_file "[file rootname [file tail $testcase]].s"
 305
 306     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 307     set text [lindex $output 1]
 308
 309     set pattern [lindex $args 0]
 310     set pp_pattern [make_pattern_printable $pattern]
 311     if ![regexp -- $pattern $text] {
 312         pass "$testcase scan-assembler-dem-not $pp_pattern"
 313     } else {
 314         fail "$testcase scan-assembler-dem-not $pp_pattern"
 315     }
 316 }
 317
 318 # Utility for testing that a function is defined on the current line.
 319 # Call pass if so, otherwise fail.  Invoked directly; the file must
 320 # have been compiled with -g -dA.
 321 #
 322 # Argument 0 is the current line, passed implicitly by dejagnu
 323 # Argument 1 is the function to check
 324 # Argument 2 handles expected failures and the like
 325 # Argument 3 is "." to match the current line, or an integer to match
 326 # an explicit line.
 327 proc dg-function-on-line { args } {
 328     # Upvar from dg-final:
 329     upvar dg-final-code final-code
 330
 331     set line [lindex $args 0]
 332     set symbol [lindex $args 1]
 333     set failures [lindex $args 2]
 334
 335     if { [llength $args] >= 4 } {
 336         switch [lindex $args 3] {
 337             "." { }
 338             "default" { set line [lindex $args 3] }
 339         }
 340     }
 341
 342     set pattern [format {%s:[^\t]*(\t.(fnstart|frame|mask|file)[^\t]*)*\t[^:]+:%d\n} \
 343                  $symbol $line]
 344
 345     # The lack of spaces around $pattern is important, since they'd
 346     # become part of the regex scan-assembler tries to match.
 347     set cmd "scan-assembler {$pattern}"
 348     if { [llength $args] >= 3 } {
 349         set cmd "$cmd {$failures}"
 350     }
 351
 352     append final-code "$cmd\n"
 353 }