gcc/testsuite/lib/scanasm.exp

   1 # Copyright (C) 2000, 2002, 2003, 2007, 2008, 2010, 2011, 2012
   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     set pattern [lindex $orig_args 0]
  54     set printable_pattern [make_pattern_printable $pattern]
  55
  56     if { [is_remote host] } {
  57         remote_upload host "$output_file"
  58     }
  59     set files [glob -nocomplain $output_file]
  60     if { $files == "" } {
  61         verbose -log "$testcase: output file '$output_file' does not exist"
  62         unresolved "$testcase $name $printable_pattern"
  63         return
  64     }
  65     set fd [open $output_file r]
  66     set text [read $fd]
  67     close $fd
  68
  69     set match [regexp -- $pattern $text]
  70     if { $match == $positive } {
  71         pass "$testcase $name $printable_pattern"
  72     } else {
  73         fail "$testcase $name $printable_pattern"
  74     }
  75 }
  76
  77 # Look for a pattern in the .s file produced by the compiler.  See
  78 # dg-scan for details.
  79
  80 proc scan-assembler { args } {
  81     set testcase [testname-for-summary]
  82     set output_file "[file rootname [file tail $testcase]].s"
  83     dg-scan "scan-assembler" 1 $testcase $output_file $args
  84 }
  85
  86 proc scan-assembler_required_options { args } {
  87     global gcc_force_conventional_output
  88     return $gcc_force_conventional_output
  89 }
  90
  91 # Check that a pattern is not present in the .s file produced by the
  92 # compiler.  See dg-scan for details.
  93
  94 proc scan-assembler-not { args } {
  95     set testcase [testname-for-summary]
  96     set output_file "[file rootname [file tail $testcase]].s"
  97
  98     dg-scan "scan-assembler-not" 0 $testcase $output_file $args
  99 }
 100
 101 proc scan-assembler-not_required_options { args } {
 102     global gcc_force_conventional_output
 103     return $gcc_force_conventional_output
 104 }
 105
 106 # Return the scan for the assembly for hidden visibility.
 107
 108 proc hidden-scan-for { symbol } {
 109
 110     set objformat [gcc_target_object_format]
 111
 112     switch $objformat {
 113         elf      { return "hidden\[ \t_\]*$symbol" }
 114         mach-o   { return "private_extern\[ \t_\]*_?$symbol" }
 115         default  { return "" }
 116     }
 117
 118 }
 119
 120
 121 # Check that a symbol is defined as a hidden symbol in the .s file
 122 # produced by the compiler.
 123
 124 proc scan-hidden { args } {
 125     set testcase [testname-for-summary]
 126     set output_file "[file rootname [file tail $testcase]].s"
 127
 128     set symbol [lindex $args 0]
 129
 130     set hidden_scan [hidden-scan-for $symbol]
 131
 132     set args [lreplace $args 0 0 "$hidden_scan"]
 133
 134     dg-scan "scan-hidden" 1 $testcase $output_file $args
 135 }
 136
 137 # Check that a symbol is not defined as a hidden symbol in the .s file
 138 # produced by the compiler.
 139
 140 proc scan-not-hidden { args } {
 141     set testcase [testname-for-summary]
 142     set output_file "[file rootname [file tail $testcase]].s"
 143
 144     set symbol [lindex $args 0]
 145     set hidden_scan [hidden-scan-for $symbol]
 146
 147     set args [lreplace $args 0 0 "$hidden_scan"]
 148
 149     dg-scan "scan-not-hidden" 0 $testcase $output_file $args
 150 }
 151
 152 # Look for a pattern in OUTPUT_FILE.  See dg-scan for details.
 153
 154 proc scan-file { output_file args } {
 155     set testcase [testname-for-summary]
 156     dg-scan "scan-file" 1 $testcase $output_file $args
 157 }
 158
 159 # Check that a pattern is not present in the OUTPUT_FILE.  See dg-scan
 160 # for details.
 161
 162 proc scan-file-not { output_file args } {
 163     set testcase [testname-for-summary]
 164     dg-scan "scan-file-not" 0 $testcase $output_file $args
 165 }
 166
 167 # Look for a pattern in the .su file produced by the compiler.  See
 168 # dg-scan for details.
 169
 170 proc scan-stack-usage { args } {
 171     set testcase [testname-for-summary]
 172     set output_file "[file rootname [file tail $testcase]].su"
 173
 174     dg-scan "scan-file" 1 $testcase $output_file $args
 175 }
 176
 177 # Check that a pattern is not present in the .su file produced by the
 178 # compiler.  See dg-scan for details.
 179
 180 proc scan-stack-usage-not { args } {
 181     set testcase [testname-for-summary]
 182     set output_file "[file rootname [file tail $testcase]].su"
 183
 184     dg-scan "scan-file-not" 0 $testcase $output_file $args
 185 }
 186
 187 # Call pass if pattern is present given number of times, otherwise fail.
 188 proc scan-assembler-times { args } {
 189     if { [llength $args] < 2 } {
 190         error "scan-assembler: too few arguments"
 191         return
 192     }
 193     if { [llength $args] > 3 } {
 194         error "scan-assembler: too many arguments"
 195         return
 196     }
 197     if { [llength $args] >= 3 } {
 198         switch [dg-process-target [lindex $args 2]] {
 199             "S" { }
 200             "N" { return }
 201             "F" { setup_xfail "*-*-*" }
 202             "P" { }
 203         }
 204     }
 205
 206     set testcase [testname-for-summary]
 207     set pattern [lindex $args 0]
 208     set pp_pattern [make_pattern_printable $pattern]
 209
 210     # This must match the rule in gcc-dg.exp.
 211     set output_file "[file rootname [file tail $testcase]].s"
 212
 213     set files [glob -nocomplain $output_file]
 214     if { $files == "" } {
 215         verbose -log "$testcase: output file '$output_file' does not exist"
 216         unresolved "$testcase scan-assembler-times $pp_pattern [lindex $args 1]"
 217         return
 218     }
 219
 220     set fd [open $output_file r]
 221     set text [read $fd]
 222     close $fd
 223
 224     if { [llength [regexp -inline -all -- $pattern $text]] == [lindex $args 1]} {
 225         pass "$testcase scan-assembler-times $pp_pattern [lindex $args 1]"
 226     } else {
 227         fail "$testcase scan-assembler-times $pp_pattern [lindex $args 1]"
 228     }
 229 }
 230
 231 # Utility for scanning demangled compiler result, invoked via dg-final.
 232 # Call pass if pattern is present, otherwise fail.
 233 proc scan-assembler-dem { args } {
 234     global cxxfilt
 235     global base_dir
 236
 237     if { [llength $args] < 1 } {
 238         error "scan-assembler-dem: too few arguments"
 239         return
 240     }
 241     if { [llength $args] > 2 } {
 242         error "scan-assembler-dem: too many arguments"
 243         return
 244     }
 245     if { [llength $args] >= 2 } {
 246         switch [dg-process-target [lindex $args 1]] {
 247             "S" { }
 248             "N" { return }
 249             "F" { setup_xfail "*-*-*" }
 250             "P" { }
 251         }
 252     }
 253
 254     # Find c++filt like we find g++ in g++.exp.
 255     if ![info exists cxxfilt]  {
 256         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 257                      $base_dir/../../../binutils/cxxfilt \
 258                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 259                       [findfile $base_dir/c++filt $base_dir/c++filt \
 260                        [transform c++filt]]]]
 261         verbose -log "c++filt is $cxxfilt"
 262     }
 263
 264     set testcase [testname-for-summary]
 265     set pattern [lindex $args 0]
 266     set pp_pattern [make_pattern_printable $pattern]
 267     set output_file "[file rootname [file tail $testcase]].s"
 268
 269     set files [glob -nocomplain $output_file]
 270     if { $files == "" } {
 271         verbose -log "$testcase: output file '$output_file' does not exist"
 272         unresolved "$testcase scan-assembler-dem $pp_pattern"
 273         return
 274     }
 275
 276     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 277     set text [lindex $output 1]
 278
 279     if [regexp -- $pattern $text] {
 280         pass "$testcase scan-assembler-dem $pp_pattern"
 281     } else {
 282         fail "$testcase scan-assembler-dem $pp_pattern"
 283     }
 284 }
 285
 286 # Call pass if demangled pattern is not present, otherwise fail.
 287 proc scan-assembler-dem-not { args } {
 288     global cxxfilt
 289     global base_dir
 290
 291     if { [llength $args] < 1 } {
 292         error "scan-assembler-dem-not: too few arguments"
 293         return
 294     }
 295     if { [llength $args] > 2 } {
 296         error "scan-assembler-dem-not: too many arguments"
 297         return
 298     }
 299     if { [llength $args] >= 2 } {
 300         switch [dg-process-target [lindex $args 1]] {
 301             "S" { }
 302             "N" { return }
 303             "F" { setup_xfail "*-*-*" }
 304             "P" { }
 305         }
 306     }
 307
 308     # Find c++filt like we find g++ in g++.exp.
 309     if ![info exists cxxfilt]  {
 310         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 311                      $base_dir/../../../binutils/cxxfilt \
 312                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 313                       [findfile $base_dir/c++filt $base_dir/c++filt \
 314                        [transform c++filt]]]]
 315         verbose -log "c++filt is $cxxfilt"
 316     }
 317
 318     set testcase [testname-for-summary]
 319     set pattern [lindex $args 0]
 320     set pp_pattern [make_pattern_printable $pattern]
 321     set output_file "[file rootname [file tail $testcase]].s"
 322
 323     set files [glob -nocomplain $output_file]
 324     if { $files == "" } {
 325         verbose -log "$testcase: output file '$output_file' does not exist"
 326         unresolved "$testcase scan-assembler-dem-not $pp_pattern"
 327         return
 328     }
 329
 330     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 331     set text [lindex $output 1]
 332
 333     if ![regexp -- $pattern $text] {
 334         pass "$testcase scan-assembler-dem-not $pp_pattern"
 335     } else {
 336         fail "$testcase scan-assembler-dem-not $pp_pattern"
 337     }
 338 }
 339
 340 # Call pass if object size is ok, otherwise fail.
 341 # example: /* { dg-final { object-size text <= 54 } } */
 342 proc object-size { args } {
 343     global size
 344     global base_dir
 345
 346     if { [llength $args] < 3 } {
 347         error "object-size: too few arguments"
 348         return
 349     }
 350     if { [llength $args] > 4 } {
 351         error "object-size: too many arguments"
 352         return
 353     }
 354     if { [llength $args] >= 4 } {
 355         switch [dg-process-target [lindex $args 3]] {
 356             "S" { }
 357             "N" { return }
 358             "F" { setup_xfail "*-*-*" }
 359             "P" { }
 360         }
 361     }
 362
 363     # Find size like we find g++ in g++.exp.
 364     if ![info exists size]  {
 365         set size [findfile $base_dir/../../../binutils/size \
 366                   $base_dir/../../../binutils/size \
 367                   [findfile $base_dir/../../size $base_dir/../../size \
 368                    [findfile $base_dir/size $base_dir/size \
 369                     [transform size]]]]
 370         verbose -log "size is $size"
 371     }
 372
 373     set testcase [testname-for-summary]
 374     set what [lindex $args 0]
 375     set where [lsearch { text data bss total } $what]
 376     if { $where == -1 } {
 377         error "object-size: illegal argument: $what"
 378         return
 379     }
 380     set cmp [lindex $args 1]
 381     if { [lsearch { < > <= >= == != } $cmp] == -1 } {
 382         error "object-size: illegal argument: $cmp"
 383         return
 384     }
 385     set with [lindex $args 2]
 386     if ![string is integer $with ] {
 387         error "object-size: illegal argument: $with"
 388         return
 389     }
 390
 391     set output_file "[file rootname [file tail $testcase]].o"
 392     if ![file_on_host exists $output_file] {
 393         verbose -log "$testcase: $output_file does not exist"
 394         unresolved "$testcase object-size $what $cmp $with"
 395         return
 396     }
 397     set output [remote_exec host "$size" "$output_file"]
 398     set status [lindex $output 0]
 399     if { $status != 0 } {
 400         verbose -log "$testcase object-size: $size failed"
 401         unresolved "$testcase object-size $what $cmp $with"
 402         return
 403     }
 404
 405     set text [lindex $output 1]
 406     set lines [split $text "\n"]
 407
 408     set line0 [lindex $lines 0]
 409     if ![regexp {^\s*text\s+data\s+bss\s+dec\s+hex\s+filename\s*$} $line0] {
 410         verbose -log "$testcase object-size: $size did not produce expected first line: $line0"
 411         unresolved "$testcase object-size $what $cmp $with"
 412         return
 413     }
 414
 415     set line1 [lindex $lines 1]
 416     if ![regexp {^\s*\d+\s+\d+\s+\d+\s+\d+\s+[\da-fA-F]+\s+} $line1] {
 417         verbose -log "$testcase object-size: $size did not produce expected second line: $line1"
 418         unresolved "$testcase object-size $what $cmp $with"
 419         return
 420     }
 421
 422     set actual [lindex $line1 $where]
 423     verbose -log "$what size is $actual"
 424
 425     if [expr $actual $cmp $with] {
 426         pass "$testcase object-size $what $cmp $with"
 427     } else {
 428         fail "$testcase object-size $what $cmp $with"
 429     }
 430 }
 431
 432 # Utility for testing that a function is defined on the current line.
 433 # Call pass if so, otherwise fail.  Invoked directly; the file must
 434 # have been compiled with -g -dA.
 435 #
 436 # Argument 0 is the current line, passed implicitly by dejagnu
 437 # Argument 1 is the function to check
 438 # Argument 2 handles expected failures and the like
 439 # Argument 3 is "." to match the current line, or an integer to match
 440 # an explicit line.
 441 proc dg-function-on-line { args } {
 442     # Upvar from dg-final:
 443     upvar dg-final-code final-code
 444
 445     set line [lindex $args 0]
 446     set symbol [lindex $args 1]
 447     set failures [lindex $args 2]
 448
 449     if { [llength $args] >= 4 } {
 450         switch [lindex $args 3] {
 451             "." { }
 452             "default" { set line [lindex $args 3] }
 453         }
 454     }
 455
 456     if { [istarget hppa*-*-*] } {
 457         set pattern [format {\t;[^:]+:%d\n(\t[^\t]+\n)+%s:\n\t.PROC} \
 458                      $line $symbol]
 459     } elseif { [istarget mips*-*-*] } {
 460         set pattern [format {\t\.loc [0-9]+ %d 0( [^\n]*)?\n(\t.cfi_startproc[^\t]*\n)*\t\.set\t(no)?mips16\n\t\.ent\t%s\n\t\.type\t%s, @function\n%s:\n} \
 461                      $line $symbol $symbol $symbol]
 462     } else {
 463         set pattern [format {%s:[^\t]*(\t.(fnstart|frame|mask|file)[^\t]*)*\t[^:]+:%d\n} \
 464                      $symbol $line]
 465     }
 466
 467     # The lack of spaces around $pattern is important, since they'd
 468     # become part of the regex scan-assembler tries to match.
 469     set cmd "scan-assembler {$pattern}"
 470     if { [llength $args] >= 3 } {
 471         set cmd "$cmd {$failures}"
 472     }
 473
 474     append final-code "$cmd\n"
 475 }