gcc/testsuite/lib/scanasm.exp

   1 # Copyright (C) 2000-2020 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 3 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 GCC; see the file COPYING3.  If not see
  15 # <http://www.gnu.org/licenses/>.
  16
  17 # Various utilities for scanning assembler output, used by gcc-dg.exp and
  18 # g++-dg.exp.
  19
  20 # Utility for scanning compiler result, invoked via dg-final.
  21
  22 # Transform newline and similar characters into their escaped form.
  23 proc make_pattern_printable { pattern } {
  24     return [string map {\t \\t \n \\n \r \\r \\ \\\\} $pattern]
  25 }
  26
  27 # Scan the OUTPUT_FILE for a pattern.  If it is present and POSITIVE
  28 # is non-zero, or it is not present and POSITIVE is zero, the test
  29 # passes.  The ORIG_ARGS is the list of arguments provided by dg-final
  30 # to scan-assembler.  The first element in ORIG_ARGS is the regular
  31 # expression to look for in the file.  The second element, if present,
  32 # is a DejaGNU target selector.
  33
  34 proc dg-scan { name positive testcase output_file orig_args } {
  35     if { [llength $orig_args] < 1 } {
  36         error "$name: too few arguments"
  37         return
  38     }
  39     if { [llength $orig_args] > 2 } {
  40         error "$name: too many arguments"
  41         return
  42     }
  43     if { [llength $orig_args] >= 2 } {
  44         switch [dg-process-target [lindex $orig_args 1]] {
  45             "S" { }
  46             "N" { return }
  47             "F" { setup_xfail "*-*-*" }
  48             "P" { }
  49         }
  50     }
  51
  52     set pattern [lindex $orig_args 0]
  53     set printable_pattern [make_pattern_printable $pattern]
  54
  55     set files [dg_glob_remote $output_file]
  56     if { $files == "" } {
  57         verbose -log "$testcase: output file does not exist"
  58         unresolved "$testcase $name $printable_pattern"
  59         return
  60     }
  61     set fd [open $output_file r]
  62     set text [read $fd]
  63     close $fd
  64
  65     set match [regexp -- $pattern $text]
  66     if { $match == $positive } {
  67         pass "$testcase $name $printable_pattern"
  68     } else {
  69         fail "$testcase $name $printable_pattern"
  70     }
  71 }
  72
  73 proc dg_glob_remote { file_pattern } {
  74     if { [is_remote host] } {
  75     remote_upload host $file_pattern
  76     }
  77     return [glob -nocomplain $file_pattern]
  78 }
  79
  80 # Look for a pattern in the .s file produced by the compiler.  See
  81 # dg-scan for details.
  82
  83 proc scan-assembler { args } {
  84     set testcase [testname-for-summary]
  85     # The name might include a list of options; extract the file name.
  86     set filename [lindex $testcase 0]
  87     set output_file "[file rootname [file tail $filename]].s"
  88     dg-scan "scan-assembler" 1 $testcase $output_file $args
  89 }
  90
  91 force_conventional_output_for scan-assembler
  92
  93 # Check that a pattern is not present in the .s file produced by the
  94 # compiler.  See dg-scan for details.
  95
  96 proc scan-assembler-not { args } {
  97     set testcase [testname-for-summary]
  98     # The name might include a list of options; extract the file name.
  99     set filename [lindex $testcase 0]
 100     set output_file "[file rootname [file tail $filename]].s"
 101
 102     dg-scan "scan-assembler-not" 0 $testcase $output_file $args
 103 }
 104
 105 force_conventional_output_for scan-assembler-not
 106
 107 # Return the scan for the assembly for hidden visibility.
 108
 109 proc hidden-scan-for { symbol } {
 110
 111     set objformat [gcc_target_object_format]
 112
 113     switch $objformat {
 114         coff     { return "$symbol\[,\d\]*hidden" }
 115         elf      { return "hidden\[ \t_\]*$symbol" }
 116         mach-o   { return "private_extern\[ \t_\]*_?$symbol" }
 117         default  { return "" }
 118     }
 119
 120 }
 121
 122
 123 # Check that a symbol is defined as a hidden symbol in the .s file
 124 # produced by the compiler.
 125
 126 proc scan-hidden { args } {
 127     set testcase [testname-for-summary]
 128     # The name might include a list of options; extract the file name.
 129     set filename [lindex $testcase 0]
 130     set output_file "[file rootname [file tail $filename]].s"
 131
 132     if { [llength $args] > 0 } {
 133         set symbol [lindex $args 0]
 134
 135         set hidden_scan [hidden-scan-for $symbol]
 136
 137         set args [lreplace $args 0 0 "$hidden_scan"]
 138     }
 139
 140     dg-scan "scan-hidden" 1 $testcase $output_file $args
 141 }
 142
 143 # Check that a symbol is not defined as a hidden symbol in the .s file
 144 # produced by the compiler.
 145
 146 proc scan-not-hidden { args } {
 147     set testcase [testname-for-summary]
 148     # The name might include a list of options; extract the file name.
 149     set filename [lindex $testcase 0]
 150     set output_file "[file rootname [file tail $filename]].s"
 151
 152     if { [llength $args] > 0 } {
 153         set symbol [lindex $args 0]
 154         set hidden_scan [hidden-scan-for $symbol]
 155
 156         set args [lreplace $args 0 0 "$hidden_scan"]
 157     }
 158
 159     dg-scan "scan-not-hidden" 0 $testcase $output_file $args
 160 }
 161
 162 # Check that symbols are emitted in the desired section.
 163 # Like scan-symbol-section, but using the assembly output generated by
 164 # the compiler.
 165 #
 166 # Example:
 167 #
 168 # // All numbered functions (func1, func2, etc.) must be in the .text section or
 169 # // in a .text sub-section (like .text._func1).
 170 # { dg-final { scan-assembler-symbol-section {^_func[1-5]$} {^\.text($|\.)} } }
 171
 172 proc scan-assembler-symbol-section { args } {
 173     set testcase [testname-for-summary]
 174     set filename [lindex $testcase 0]
 175     set output_file "[file rootname [file tail $filename]].s"
 176     set symbol_pattern [lindex $args 0]
 177     set expected_section_pattern [lindex $args 1]
 178     dg-scan-symbol-section \
 179     "scan-assembler-symbol-section" \
 180     $testcase \
 181     $output_file \
 182     $symbol_pattern \
 183     $expected_section_pattern
 184 }
 185
 186 # Check that symbols are emitted in the desired section.
 187 #
 188 # Symbols and sections are interpreted as regexp patterns.
 189 #
 190 # If no matching symbol is found, scan-symbol-section reports a FAILure.
 191 #
 192 # Usage:
 193 #
 194 # { dg-final { scan-symbol-section FILENAME SYMBOL SECTION } }
 195 #
 196 # Examples:
 197 #
 198 # // The my_var C symbol must be in the .data section (or in a .data._my_var section
 199 # // if -ffunction-sections is in use).
 200 # { dg-final { scan-symbol-section "my-test.s" {^_my_var$} {^\.data(\._my_var)?$} } }
 201 #
 202 # // All numbered functions (func1, func2, etc.) must be in the .text section
 203 # // (and not in any other section like .text._func1).
 204 # { dg-final { scan-symbol-section "my-test.s" {^_func[1-5]$} {^\.text$} } }
 205 #
 206 # Caveats:
 207 #
 208 # * Only ELF and Mach-O targets are supported. Other
 209 #   targets, like PE/COFF, might appear to work.
 210 # * For Mach-O targets, the section name matched by scan-symbol-section has one
 211 #   of two forms:
 212 #   * The Mach-O segment name followed by a comma (',') followed by the Mach-O
 213 #     section name. For example, "__TEXT,__text". (There is no whitespace
 214 #     between the Mach-O segment name and the Mach-O section name.)
 215 #   * ".const", ".data", or ".text". For example, the .text assembler directive
 216 #     causes the section name to be ".text" (not "__TEXT,__text"). (However, a
 217 #     directive such as .section __TEXT,__text will cause the section name to be
 218 #     "__TEXT,__text".)
 219 # * Because scan-symbol-section parses assembly code, scan-symbol-section is
 220 #   unaware of section rewriting performed by the linker. For example, the
 221 #   sections .text._f1 and .text._f2 would normally be merged by binutils'
 222 #   linker into one section called .text, but scan-symbol-section reports the
 223 #   sections as .text._f1 and .text._f2 (and not .text).
 224 # * The symbol pattern matches any assembly label, including local labels which
 225 #   begin with `.L`.
 226
 227 proc scan-symbol-section { args } {
 228     set testcase [testname-for-summary]
 229     set output_file [lindex $args 0]
 230     set symbol_pattern [lindex $args 1]
 231     set expected_section_pattern [lindex $args 2]
 232     dg-scan-symbol-section \
 233     "scan-symbol-section" \
 234     $testcase \
 235     $output_file \
 236     $symbol_pattern \
 237     $expected_section_pattern
 238 }
 239
 240 # Check that symbols are emitted in the desired section.
 241 #
 242 # Avoid calling this function directly. In tests, use scan-symbol-section,
 243 # scan-assembler-symbol-section, or scan-lto-assembler-symbol-section instead.
 244
 245 proc dg-scan-symbol-section { name testcase output_file symbol_pattern expected_section_pattern } {
 246     set printable_symbol_pattern [make_pattern_printable $symbol_pattern]
 247     set printable_expected_section_pattern [make_pattern_printable $expected_section_pattern]
 248
 249     set files [dg_glob_remote $output_file]
 250     if { $files == "" } {
 251     verbose -log "$testcase: output file does not exist"
 252     unresolved "$testcase $name symbol $printable_symbol_pattern has section $printable_expected_section_pattern"
 253     return
 254     }
 255
 256     parse_section_of_symbols $output_file section_by_symbol
 257
 258     set found_symbol 0
 259     foreach symbol_name [lsort [array names section_by_symbol]] {
 260         if { [regexp -- $symbol_pattern $symbol_name] } {
 261             set section $section_by_symbol($symbol_name)
 262             set description "$testcase $name symbol $printable_symbol_pattern (found $symbol_name) has section $printable_expected_section_pattern"
 263             if { $section == "" } {
 264                 fail "$description (no section detected)"
 265             } else {
 266                 set description "$description (found $section)"
 267                 if { [regexp -- $expected_section_pattern $section] } {
 268                     pass $description
 269                 } else {
 270                     fail $description
 271                 }
 272             }
 273             set found_symbol 1
 274         }
 275     }
 276     if { ! $found_symbol } {
 277         fail "$testcase $name symbol $printable_symbol_pattern (symbol not found) has section $printable_expected_section_pattern"
 278     }
 279 }
 280
 281 # Extract a symbol and section names from pre-processed assembly source code.
 282 #
 283 # This function adds entries in the RESULT array where the key is the symbol's
 284 # name (including any leading underscores) and the value is the section's name
 285 # (including any leading periods).
 286 #
 287 # For example, given the following assembly source code in file.s:
 288 #
 289 #         .text
 290 #         .function _my_function
 291 # _my_function:
 292 #         nop
 293 #         .data
 294 # _my_data:
 295 #         .long 42
 296 #
 297 # Executing 'parse_section_of_symbols "file.s" symbols' would have the same
 298 # effect as the following code:
 299 #
 300 # set $result(_my_function) .text
 301 # set $result(_my_data) .data
 302
 303 proc parse_section_of_symbols { filename result } {
 304     upvar $result up_result
 305
 306     set section_pattern {^\s*(?:(\.section|\.csect)\s+(.*)|(\.const|\.data|\.text)\s*)$}
 307     set label_pattern {^(\S+):$}
 308
 309     set fd [open $filename r]
 310     set current_section ""
 311     while { [gets $fd line] >= 0 } {
 312         if { [regexp -- $label_pattern $line dummy symbol_name] } {
 313             set up_result($symbol_name) $current_section
 314         } elseif { [regexp -- $section_pattern $line dummy section_directive_arguments full_section_directive] } {
 315             if { $full_section_directive eq "" } {
 316                 # Example: .section .text,"ax",progbits
 317                 # Example: .section __TEXT,__text
 318                 set arguments [split $section_directive_arguments ","]
 319                 set current_section [string trim [lindex $arguments 0]]
 320                 set arg_1 [string trim [lindex $arguments 1]]
 321                 if { [regexp {^_} $arg_1] } {
 322                     # The second argument looks like a Mach-O section name.
 323                     set current_section "$current_section,$arg_1"
 324                 }
 325             } else {
 326                 # Example: .text
 327                 set current_section "$full_section_directive"
 328             }
 329         }
 330     }
 331     close $fd
 332 }
 333
 334 # Look for a pattern in OUTPUT_FILE.  See dg-scan for details.
 335
 336 proc scan-file { output_file args } {
 337     set testcase [testname-for-summary]
 338     dg-scan "scan-file" 1 $testcase $output_file $args
 339 }
 340
 341 # Check that a pattern is not present in the OUTPUT_FILE.  See dg-scan
 342 # for details.
 343
 344 proc scan-file-not { output_file args } {
 345     set testcase [testname-for-summary]
 346     dg-scan "scan-file-not" 0 $testcase $output_file $args
 347 }
 348
 349 # Look for a pattern in the .su file produced by the compiler.  See
 350 # dg-scan for details.
 351
 352 proc scan-stack-usage { args } {
 353     set testcase [testname-for-summary]
 354     # The name might include a list of options; extract the file name.
 355     set filename [lindex $testcase 0]
 356     set output_file "[file rootname [file tail $filename]].su"
 357
 358     dg-scan "scan-stack-usage" 1 $testcase $output_file $args
 359 }
 360
 361 # Check that a pattern is not present in the .su file produced by the
 362 # compiler.  See dg-scan for details.
 363
 364 proc scan-stack-usage-not { args } {
 365     set testcase [testname-for-summary]
 366     # The name might include a list of options; extract the file name.
 367     set filename [lindex $testcase 0]
 368     set output_file "[file rootname [file tail $filename]].su"
 369
 370     dg-scan "scan-stack-usage-not" 0 $testcase $output_file $args
 371 }
 372
 373 # Return the filename of the Ada spec corresponding to the argument.
 374
 375 proc get_ada_spec_filename { testcase } {
 376     # The name might include a list of options; extract the file name.
 377     set filename  [lindex $testcase 0]
 378     set tailname  [file tail $filename]
 379     set extension [string trimleft [file extension $tailname] {.}]
 380     regsub -all {\-} [file rootname $tailname] {_} rootname
 381
 382     return [string tolower "${rootname}_${extension}.ads"]
 383 }
 384
 385 # Look for a pattern in the .ads file produced by the compiler.  See
 386 # dg-scan for details.
 387
 388 proc scan-ada-spec { args } {
 389     set testcase  [testname-for-summary]
 390     set output_file "[get_ada_spec_filename $testcase]"
 391
 392     dg-scan "scan-ada-spec" 1 $testcase $output_file $args
 393 }
 394
 395 # Check that a pattern is not present in the .ads file produced by the
 396 # compiler.  See dg-scan for details.
 397
 398 proc scan-ada-spec-not { args } {
 399     set testcase  [testname-for-summary]
 400     set output_file "[get_ada_spec_filename $testcase]"
 401
 402     dg-scan "scan-ada-spec-not" 0 $testcase $output_file $args
 403 }
 404
 405 # Call pass if pattern is present given number of times, otherwise fail.
 406 proc scan-assembler-times { args } {
 407     if { [llength $args] < 2 } {
 408         error "scan-assembler-times: too few arguments"
 409         return
 410     }
 411     if { [llength $args] > 3 } {
 412         error "scan-assembler-times: too many arguments"
 413         return
 414     }
 415     if { [llength $args] >= 3 } {
 416         switch [dg-process-target [lindex $args 2]] {
 417             "S" { }
 418             "N" { return }
 419             "F" { setup_xfail "*-*-*" }
 420             "P" { }
 421         }
 422     }
 423
 424     set testcase [testname-for-summary]
 425     # The name might include a list of options; extract the file name.
 426     set filename [lindex $testcase 0]
 427     set pattern [lindex $args 0]
 428     set times [lindex $args 1]
 429     set pp_pattern [make_pattern_printable $pattern]
 430
 431     # This must match the rule in gcc-dg.exp.
 432     set output_file "[file rootname [file tail $filename]].s"
 433
 434     set files [glob -nocomplain $output_file]
 435     if { $files == "" } {
 436         verbose -log "$testcase: output file does not exist"
 437         unresolved "$testcase scan-assembler-times $pp_pattern $times"
 438         return
 439     }
 440
 441     set fd [open $output_file r]
 442     set text [read $fd]
 443     close $fd
 444
 445     set result_count [llength [regexp -inline -all -- $pattern $text]]
 446     if {$result_count == $times} {
 447         pass "$testcase scan-assembler-times $pp_pattern $times"
 448     } else {
 449         verbose -log "$testcase: $pp_pattern found $result_count times"
 450         fail "$testcase scan-assembler-times $pp_pattern $times"
 451     }
 452 }
 453
 454 force_conventional_output_for scan-assembler-times
 455
 456 # Utility for scanning demangled compiler result, invoked via dg-final.
 457 # Call pass if pattern is present, otherwise fail.
 458 proc scan-assembler-dem { args } {
 459     global cxxfilt
 460     global base_dir
 461
 462     if { [llength $args] < 1 } {
 463         error "scan-assembler-dem: too few arguments"
 464         return
 465     }
 466     if { [llength $args] > 2 } {
 467         error "scan-assembler-dem: too many arguments"
 468         return
 469     }
 470     if { [llength $args] >= 2 } {
 471         switch [dg-process-target [lindex $args 1]] {
 472             "S" { }
 473             "N" { return }
 474             "F" { setup_xfail "*-*-*" }
 475             "P" { }
 476         }
 477     }
 478
 479     # Find c++filt like we find g++ in g++.exp.
 480     if ![info exists cxxfilt]  {
 481         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 482                      $base_dir/../../../binutils/cxxfilt \
 483                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 484                       [findfile $base_dir/c++filt $base_dir/c++filt \
 485                        [transform c++filt]]]]
 486         verbose -log "c++filt is $cxxfilt"
 487     }
 488
 489     set testcase [testname-for-summary]
 490     # The name might include a list of options; extract the file name.
 491     set filename [lindex $testcase 0]
 492     set pattern [lindex $args 0]
 493     set pp_pattern [make_pattern_printable $pattern]
 494     set output_file "[file rootname [file tail $filename]].s"
 495
 496     set files [glob -nocomplain $output_file]
 497     if { $files == "" } {
 498         verbose -log "$testcase: output file does not exist"
 499         unresolved "$testcase scan-assembler-dem $pp_pattern"
 500         return
 501     }
 502
 503     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 504     set text [lindex $output 1]
 505
 506     if [regexp -- $pattern $text] {
 507         pass "$testcase scan-assembler-dem $pp_pattern"
 508     } else {
 509         fail "$testcase scan-assembler-dem $pp_pattern"
 510     }
 511 }
 512
 513 # Call pass if demangled pattern is not present, otherwise fail.
 514 proc scan-assembler-dem-not { args } {
 515     global cxxfilt
 516     global base_dir
 517
 518     if { [llength $args] < 1 } {
 519         error "scan-assembler-dem-not: too few arguments"
 520         return
 521     }
 522     if { [llength $args] > 2 } {
 523         error "scan-assembler-dem-not: too many arguments"
 524         return
 525     }
 526     if { [llength $args] >= 2 } {
 527         switch [dg-process-target [lindex $args 1]] {
 528             "S" { }
 529             "N" { return }
 530             "F" { setup_xfail "*-*-*" }
 531             "P" { }
 532         }
 533     }
 534
 535     # Find c++filt like we find g++ in g++.exp.
 536     if ![info exists cxxfilt]  {
 537         set cxxfilt [findfile $base_dir/../../../binutils/cxxfilt \
 538                      $base_dir/../../../binutils/cxxfilt \
 539                      [findfile $base_dir/../../c++filt $base_dir/../../c++filt \
 540                       [findfile $base_dir/c++filt $base_dir/c++filt \
 541                        [transform c++filt]]]]
 542         verbose -log "c++filt is $cxxfilt"
 543     }
 544
 545     set testcase [testname-for-summary]
 546     # The name might include a list of options; extract the file name.
 547     set filename [lindex $testcase 0]
 548     set pattern [lindex $args 0]
 549     set pp_pattern [make_pattern_printable $pattern]
 550     set output_file "[file rootname [file tail $filename]].s"
 551
 552     set files [glob -nocomplain $output_file]
 553     if { $files == "" } {
 554         verbose -log "$testcase: output file does not exist"
 555         unresolved "$testcase scan-assembler-dem-not $pp_pattern"
 556         return
 557     }
 558
 559     set output [remote_exec host "$cxxfilt" "" "$output_file"]
 560     set text [lindex $output 1]
 561
 562     if ![regexp -- $pattern $text] {
 563         pass "$testcase scan-assembler-dem-not $pp_pattern"
 564     } else {
 565         fail "$testcase scan-assembler-dem-not $pp_pattern"
 566     }
 567 }
 568
 569 # Call pass if object size is ok, otherwise fail.
 570 # example: /* { dg-final { object-size text <= 54 } } */
 571 proc object-size { args } {
 572     global size
 573     global base_dir
 574
 575     if { [llength $args] < 3 } {
 576         error "object-size: too few arguments"
 577         return
 578     }
 579     if { [llength $args] > 4 } {
 580         error "object-size: too many arguments"
 581         return
 582     }
 583     if { [llength $args] >= 4 } {
 584         switch [dg-process-target [lindex $args 3]] {
 585             "S" { }
 586             "N" { return }
 587             "F" { setup_xfail "*-*-*" }
 588             "P" { }
 589         }
 590     }
 591
 592     # Find size like we find g++ in g++.exp.
 593     if ![info exists size]  {
 594         set size [findfile $base_dir/../../../binutils/size \
 595                   $base_dir/../../../binutils/size \
 596                   [findfile $base_dir/../../size $base_dir/../../size \
 597                    [findfile $base_dir/size $base_dir/size \
 598                     [transform size]]]]
 599         verbose -log "size is $size"
 600     }
 601
 602     set testcase [testname-for-summary]
 603     # The name might include a list of options; extract the file name.
 604     set filename [lindex $testcase 0]
 605     set what [lindex $args 0]
 606     set where [lsearch { text data bss total } $what]
 607     if { $where == -1 } {
 608         error "object-size: illegal argument: $what"
 609         return
 610     }
 611     set cmp [lindex $args 1]
 612     if { [lsearch { < > <= >= == != } $cmp] == -1 } {
 613         error "object-size: illegal argument: $cmp"
 614         return
 615     }
 616     set with [lindex $args 2]
 617     if ![string is integer $with ] {
 618         error "object-size: illegal argument: $with"
 619         return
 620     }
 621
 622     set output_file "[file rootname [file tail $filename]].o"
 623     if ![file_on_host exists $output_file] {
 624         verbose -log "$testcase: $output_file does not exist"
 625         unresolved "$testcase object-size $what $cmp $with"
 626         return
 627     }
 628     set output [remote_exec host "$size" "$output_file"]
 629     set status [lindex $output 0]
 630     if { $status != 0 } {
 631         verbose -log "$testcase object-size: $size failed"
 632         unresolved "$testcase object-size $what $cmp $with"
 633         return
 634     }
 635
 636     set text [lindex $output 1]
 637     set lines [split $text "\n"]
 638
 639     set l0match {^\s*text\s+data\s+bss\s+dec\s+hex\s+filename\s*$}
 640     set l1match {^\s*\d+\s+\d+\s+\d+\s+\d+\s+[\da-fA-F]+\s+}
 641
 642     if { [istarget *-*-darwin*] } {
 643       set l0match {^\s*__TEXT\s+__DATA\s+__OBJC\s+others\s+dec\s+hex\s*$}
 644       set l1match {^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+[\da-fA-F]+\s+}
 645     }
 646
 647     set line0 [lindex $lines 0]
 648     if ![regexp $l0match $line0] {
 649         verbose -log "$testcase object-size: $size did not produce expected first line: $line0"
 650         unresolved "$testcase object-size $what $cmp $with"
 651         return
 652     }
 653
 654     set line1 [lindex $lines 1]
 655     if ![regexp $l1match $line1] {
 656         verbose -log "$testcase object-size: $size did not produce expected second line: $line1"
 657         unresolved "$testcase object-size $what $cmp $with"
 658         return
 659     }
 660
 661     set actual [lindex $line1 $where]
 662     verbose -log "$what size is $actual"
 663
 664     if [expr $actual $cmp $with] {
 665         pass "$testcase object-size $what $cmp $with"
 666     } else {
 667         fail "$testcase object-size $what $cmp $with"
 668     }
 669 }
 670
 671 # Utility for testing that a function is defined on the current line.
 672 # Call pass if so, otherwise fail.  Invoked directly; the file must
 673 # have been compiled with -g -dA.
 674 #
 675 # Argument 0 is the current line, passed implicitly by dejagnu
 676 # Argument 1 is the function to check
 677 # Argument 2 handles expected failures and the like
 678 # Argument 3 is "." to match the current line, or an integer to match
 679 # an explicit line.
 680 proc dg-function-on-line { args } {
 681     # Upvar from dg-final:
 682     upvar dg-final-code final-code
 683
 684     set line [lindex $args 0]
 685     set symbol [lindex $args 1]
 686     set failures [lindex $args 2]
 687
 688     if { [llength $args] >= 4 } {
 689         switch [lindex $args 3] {
 690             "." { }
 691             "default" { set line [lindex $args 3] }
 692         }
 693     }
 694
 695     if { [istarget hppa*-*-linux*] } {
 696         set pattern [format {%s:\n\t.PROC\n\t.CALLINFO.*\n\t.ENTRY\n.L.*:\n(\t.file[^\t]*)*\t[^:]+:%d(:[0-9]+)?\n} \
 697                      $symbol $line]
 698     } elseif { [istarget hppa*-*-*] } {
 699         set pattern [format {\t;[^:]+:%d(:[0-9]+)?\n(\t[^\t]+\n)+%s:\n\t.PROC} \
 700                      $line $symbol]
 701     } elseif { [istarget mips*-*-*] } {
 702         set pattern [format {\t\.loc [0-9]+ %d [0-9]+( [^\n]*)?\n(\t.cfi_startproc[^\t]*\n)*\t\.set\t(no)?mips16\n\t(\.set\t(no)?micromips\n\t)?\.ent\t%s\n\t\.type\t%s, @function\n%s:\n} \
 703                      $line $symbol $symbol $symbol]
 704     } elseif { [istarget microblaze*-*-*] } {
 705         set pattern [format {:%d(:[0-9]+)?\n\$.*:\n\t\.ent\t%s\n\t\.type\t%s, @function\n%s:\n} \
 706                      $line $symbol $symbol $symbol]
 707     } else {
 708         set pattern [format {%s:[^\t]*(\t.(fnstart|frame|mask|file)[^\t]*)*\t[^:]+:%d(:[0-9]+)?\n} \
 709                      $symbol $line]
 710     }
 711
 712     # The lack of spaces around $pattern is important, since they'd
 713     # become part of the regex scan-assembler tries to match.
 714     set cmd "scan-assembler {$pattern}"
 715     if { [llength $args] >= 3 } {
 716         set cmd "$cmd {$failures}"
 717     }
 718
 719     append final-code "$cmd\n"
 720 }
 721
 722 # Look for a pattern in the .exe.ltrans0.s file produced by the
 723 # compiler.  See dg-scan for details.
 724
 725 proc scan-lto-assembler { args } {
 726     set testcase [testname-for-summary]
 727     # The name might include a list of options; extract the file name.
 728     set filename [lindex $testcase 0]
 729     set output_file "[file rootname [file tail $filename]].exe.ltrans0.s"
 730     verbose "output_file: $output_file"
 731     dg-scan "scan-lto-assembler" 1 $testcase $output_file $args
 732 }
 733
 734 # Read assembly file FILENAME and store a mapping from function names
 735 # to function bodies in array RESULT.  FILENAME has already been uploaded
 736 # locally where necessary and is known to exist.
 737
 738 proc parse_function_bodies { filename result } {
 739     upvar $result up_result
 740
 741     # Regexp for the start of a function definition (name in \1).
 742     set label {^([a-zA-Z_]\S+):$}
 743
 744     # Regexp for the end of a function definition.
 745     set terminator {^\s*\.size}
 746
 747     # Regexp for lines that aren't interesting.
 748     set fluff {^\s*(?:\.|//|@)}
 749
 750     set fd [open $filename r]
 751     set in_function 0
 752     while { [gets $fd line] >= 0 } {
 753         if { [regexp $label $line dummy function_name] } {
 754             set in_function 1
 755             set function_body ""
 756         } elseif { $in_function } {
 757             if { [regexp $terminator $line] } {
 758                 set up_result($function_name) $function_body
 759                 set in_function 0
 760             } elseif { ![regexp $fluff $line] } {
 761                 append function_body $line "\n"
 762             }
 763         }
 764     }
 765     close $fd
 766 }
 767
 768 # FUNCTIONS is an array that maps function names to function bodies.
 769 # Return true if it contains a definition of function NAME and if
 770 # that definition matches BODY_REGEXP.
 771
 772 proc check_function_body { functions name body_regexp } {
 773     upvar $functions up_functions
 774
 775     if { ![info exists up_functions($name)] } {
 776         return 0
 777     }
 778     return [regexp "^$body_regexp\$" $up_functions($name)]
 779 }
 780
 781 # Check the implementations of functions against expected output.  Used as:
 782 #
 783 # { dg-do { check-function-bodies PREFIX TERMINATOR[ OPTION[ SELECTOR]] } }
 784 #
 785 # See sourcebuild.texi for details.
 786
 787 proc check-function-bodies { args } {
 788     if { [llength $args] < 2 } {
 789         error "too few arguments to check-function-bodies"
 790     }
 791     if { [llength $args] > 4 } {
 792         error "too many arguments to check-function-bodies"
 793     }
 794
 795     if { [llength $args] >= 3 } {
 796         set required_flags [lindex $args 2]
 797
 798         upvar 2 dg-extra-tool-flags extra_tool_flags
 799         set flags $extra_tool_flags
 800
 801         global torture_current_flags
 802         if { [info exists torture_current_flags] } {
 803             append flags " " $torture_current_flags
 804         }
 805         foreach required_flag $required_flags {
 806             switch -- $required_flag {
 807                 target -
 808                 xfail {
 809                     error "misplaced $required_flag in check-function-bodies"
 810                 }
 811             }
 812         }
 813         foreach required_flag $required_flags {
 814             if { ![regexp " $required_flag " $flags] } {
 815                 return
 816             }
 817         }
 818     }
 819
 820     set xfail_all 0
 821     if { [llength $args] >= 4 } {
 822         switch [dg-process-target [lindex $args 3]] {
 823             "S" { }
 824             "N" { return }
 825             "F" { set xfail_all 1 }
 826             "P" { }
 827         }
 828     }
 829
 830     set testcase [testname-for-summary]
 831     # The name might include a list of options; extract the file name.
 832     set filename [lindex $testcase 0]
 833
 834     global srcdir
 835     set input_filename "$srcdir/$filename"
 836     set output_filename "[file rootname [file tail $filename]].s"
 837
 838     set prefix [lindex $args 0]
 839     set prefix_len [string length $prefix]
 840     set terminator [lindex $args 1]
 841     if { [string equal $terminator ""] } {
 842         set terminator "*/"
 843     }
 844     set terminator_len [string length $terminator]
 845
 846     set have_bodies 0
 847     if { [is_remote host] } {
 848         remote_upload host "$filename"
 849     }
 850     if { [file exists $output_filename] } {
 851         parse_function_bodies $output_filename functions
 852         set have_bodies 1
 853     } else {
 854         verbose -log "$testcase: output file does not exist"
 855     }
 856
 857     set count 0
 858     set function_regexp ""
 859     set label {^(\S+):$}
 860
 861     set lineno 1
 862     set fd [open $input_filename r]
 863     set in_function 0
 864     while { [gets $fd line] >= 0 } {
 865         if { [string equal -length $prefix_len $line $prefix] } {
 866             set line [string trim [string range $line $prefix_len end]]
 867             if { !$in_function } {
 868                 if { [regexp "^(.*?\\S)\\s+{(.*)}\$" $line dummy \
 869                           line selector] } {
 870                     set selector [dg-process-target $selector]
 871                 } else {
 872                     set selector "P"
 873                 }
 874                 if { ![regexp $label $line dummy function_name] } {
 875                     close $fd
 876                     error "check-function-bodies: line $lineno does not have a function label"
 877                 }
 878                 set in_function 1
 879                 set function_regexp ""
 880             } elseif { [string equal $line "("] } {
 881                 append function_regexp "(?:"
 882             } elseif { [string equal $line "|"] } {
 883                 append function_regexp "|"
 884             } elseif { [string equal $line ")"] } {
 885                 append function_regexp ")"
 886             } elseif { [string equal $line "..."] } {
 887                 append function_regexp ".*"
 888             } else {
 889                 append function_regexp "\t" $line "\n"
 890             }
 891         } elseif { [string equal -length $terminator_len $line $terminator] } {
 892             if { ![string equal $selector "N"] } {
 893                 if { $xfail_all || [string equal $selector "F"] } {
 894                     setup_xfail "*-*-*"
 895                 }
 896                 set testname "$testcase check-function-bodies $function_name"
 897                 if { !$have_bodies } {
 898                     unresolved $testname
 899                 } elseif { [check_function_body functions $function_name \
 900                                 $function_regexp] } {
 901                     pass $testname
 902                 } else {
 903                     fail $testname
 904                 }
 905             }
 906             set in_function 0
 907             incr count
 908         }
 909         incr lineno
 910     }
 911     close $fd
 912     if { $in_function } {
 913         error "check-function-bodies: missing \"$terminator\""
 914     }
 915     if { $count == 0 } {
 916         error "check-function-bodies: no matches found"
 917     }
 918 }