gcc/testsuite/lib/gcc-defs.exp

   1 # Copyright (C) 2001-2019 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 load_lib target-libpath.exp
  18
  19 load_lib wrapper.exp
  20
  21 load_lib target-utils.exp
  22
  23 #
  24 # ${tool}_check_compile -- Reports and returns pass/fail for a compilation
  25 #
  26
  27 proc ${tool}_check_compile {testcase option objname gcc_output} {
  28     global tool
  29     set fatal_signal "*cc: Internal compiler error: program*got fatal signal"
  30
  31     if [string match "$fatal_signal 6" $gcc_output] then {
  32         ${tool}_fail $testcase "Got Signal 6, $option"
  33         return 0
  34     }
  35
  36     if [string match "$fatal_signal 11" $gcc_output] then {
  37         ${tool}_fail $testcase "Got Signal 11, $option"
  38         return 0
  39     }
  40
  41     if [string match "*internal compiler error*" $gcc_output] then {
  42         ${tool}_fail $testcase "$option (internal compiler error)"
  43         return 0
  44     }
  45
  46     # We shouldn't get these because of -w, but just in case.
  47     if [string match "*cc:*warning:*" $gcc_output] then {
  48         warning "$testcase: (with warnings) $option"
  49         send_log "$gcc_output\n"
  50         unresolved "$testcase, $option"
  51         return 0
  52     }
  53
  54     set gcc_output [prune_warnings $gcc_output]
  55
  56     if { [info proc ${tool}-dg-prune] != "" } {
  57         global target_triplet
  58         set gcc_output [${tool}-dg-prune $target_triplet $gcc_output]
  59         if [string match "*::unsupported::*" $gcc_output] then {
  60             regsub -- "::unsupported::" $gcc_output "" gcc_output
  61             unsupported "$testcase: $gcc_output"
  62             return 0
  63         }
  64     } else {
  65         set unsupported_message [${tool}_check_unsupported_p $gcc_output]
  66         if { $unsupported_message != "" } {
  67             unsupported "$testcase: $unsupported_message"
  68             return 0
  69         }
  70     }
  71
  72     # remove any leftover LF/CR to make sure any output is legit
  73     regsub -all -- "\[\r\n\]*" $gcc_output "" gcc_output
  74
  75     # If any message remains, we fail.
  76     if ![string match "" $gcc_output] then {
  77         ${tool}_fail $testcase $option
  78         return 0
  79     }
  80
  81     # fail if the desired object file doesn't exist.
  82     # FIXME: there's no way of checking for existence on a remote host.
  83     if {$objname != "" && ![is3way] && ![file exists $objname]} {
  84         ${tool}_fail $testcase $option
  85         return 0
  86     }
  87
  88     ${tool}_pass $testcase $option
  89     return 1
  90 }
  91
  92 #
  93 # ${tool}_pass -- utility to record a testcase passed
  94 #
  95
  96 proc ${tool}_pass { testcase cflags } {
  97     if { "$cflags" == "" } {
  98         pass "$testcase"
  99     } else {
 100         pass "$testcase, $cflags"
 101     }
 102 }
 103
 104 #
 105 # ${tool}_fail -- utility to record a testcase failed
 106 #
 107
 108 proc ${tool}_fail { testcase cflags } {
 109     if { "$cflags" == "" } {
 110         fail "$testcase"
 111     } else {
 112         fail "$testcase, $cflags"
 113     }
 114 }
 115
 116 #
 117 # ${tool}_finish -- called at the end of every script that calls ${tool}_init
 118 #
 119 # Hide all quirks of the testing environment from the testsuites.  Also
 120 # undo anything that ${tool}_init did that needs undoing.
 121 #
 122
 123 proc ${tool}_finish { } {
 124     # The testing harness apparently requires this.
 125     global errorInfo
 126
 127     if [info exists errorInfo] then {
 128         unset errorInfo
 129     }
 130
 131     # Might as well reset these (keeps our caller from wondering whether
 132     # s/he has to or not).
 133     global prms_id bug_id
 134     set prms_id 0
 135     set bug_id 0
 136 }
 137
 138 #
 139 # ${tool}_exit -- Does final cleanup when testing is complete
 140 #
 141
 142 proc ${tool}_exit { } {
 143     global gluefile
 144
 145     if [info exists gluefile] {
 146         file_on_build delete $gluefile
 147         unset gluefile
 148     }
 149 }
 150
 151 #
 152 # runtest_file_p -- Provide a definition for older dejagnu releases
 153 #                   and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
 154 #                   (delete after next dejagnu release).
 155 #
 156
 157 if { [info procs runtest_file_p] == "" } then {
 158     proc runtest_file_p { runtests testcase } {
 159         if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
 160             if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
 161                 return 1
 162             } else {
 163                 return 0
 164             }
 165         }
 166         return 1
 167     }
 168 }
 169
 170 if { [info exists env(GCC_RUNTEST_PARALLELIZE_DIR)] \
 171      && [info procs runtest_file_p] != [list] \
 172      && [info procs gcc_parallelize_saved_runtest_file_p] == [list] } then {
 173     global gcc_runtest_parallelize_counter
 174     global gcc_runtest_parallelize_counter_minor
 175     global gcc_runtest_parallelize_enable
 176     global gcc_runtest_parallelize_dir
 177     global gcc_runtest_parallelize_last
 178
 179     set gcc_runtest_parallelize_counter 0
 180     set gcc_runtest_parallelize_counter_minor 0
 181     set gcc_runtest_parallelize_enable 1
 182     set gcc_runtest_parallelize_dir [getenv GCC_RUNTEST_PARALLELIZE_DIR]
 183     set gcc_runtest_parallelize_last 0
 184
 185     proc gcc_parallel_test_run_p { testcase } {
 186         global gcc_runtest_parallelize_counter
 187         global gcc_runtest_parallelize_counter_minor
 188         global gcc_runtest_parallelize_enable
 189         global gcc_runtest_parallelize_dir
 190         global gcc_runtest_parallelize_last
 191
 192         if { $gcc_runtest_parallelize_enable == 0 } {
 193             return 1
 194         }
 195
 196         # Only test the filesystem every 10th iteration
 197         incr gcc_runtest_parallelize_counter_minor
 198         if { $gcc_runtest_parallelize_counter_minor == 10 } {
 199             set gcc_runtest_parallelize_counter_minor 0
 200         }
 201         if { $gcc_runtest_parallelize_counter_minor != 1 } {
 202             #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter $gcc_runtest_parallelize_last"
 203             return $gcc_runtest_parallelize_last
 204         }
 205
 206         set path $gcc_runtest_parallelize_dir/$gcc_runtest_parallelize_counter
 207
 208         if {![catch {open $path {RDWR CREAT EXCL} 0600} fd]} {
 209             close $fd
 210             set gcc_runtest_parallelize_last 1
 211             #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 1"
 212             incr gcc_runtest_parallelize_counter
 213             return 1
 214         }
 215         set gcc_runtest_parallelize_last 0
 216         #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 0"
 217         incr gcc_runtest_parallelize_counter
 218         return 0
 219     }
 220
 221     proc gcc_parallel_test_enable { val } {
 222         global gcc_runtest_parallelize_enable
 223         set gcc_runtest_parallelize_enable $val
 224     }
 225
 226     rename runtest_file_p gcc_parallelize_saved_runtest_file_p
 227     proc runtest_file_p { runtests testcase } {
 228         if ![gcc_parallelize_saved_runtest_file_p $runtests $testcase] {
 229             return 0
 230         }
 231         return [gcc_parallel_test_run_p $testcase]
 232     }
 233
 234 } else {
 235
 236     proc gcc_parallel_test_run_p { testcase } {
 237         return 1
 238     }
 239
 240     proc gcc_parallel_test_enable { val } {
 241     }
 242
 243 }
 244
 245 # Like dg-options, but adds to the default options rather than replacing them.
 246
 247 proc dg-additional-options { args } {
 248     upvar dg-extra-tool-flags extra-tool-flags
 249
 250     if { [llength $args] > 3 } {
 251         error "[lindex $args 0]: too many arguments"
 252         return
 253     }
 254
 255     if { [llength $args] >= 3 } {
 256         switch [dg-process-target [lindex $args 2]] {
 257             "S" { eval lappend extra-tool-flags [lindex $args 1] }
 258             "N" { }
 259             "F" { error "[lindex $args 0]: `xfail' not allowed here" }
 260             "P" { error "[lindex $args 0]: `xfail' not allowed here" }
 261         }
 262     } else {
 263         eval lappend extra-tool-flags [lindex $args 1]
 264     }
 265 }
 266
 267 # Record additional sources files that must be compiled along with the
 268 # main source file.
 269
 270 set additional_sources ""
 271 set additional_sources_used ""
 272
 273 proc dg-additional-sources { args } {
 274     global additional_sources
 275     set additional_sources [lindex $args 1]
 276 }
 277
 278 # Record additional files -- other than source files -- that must be
 279 # present on the system where the compiler runs.
 280
 281 set additional_files ""
 282
 283 proc dg-additional-files { args } {
 284     global additional_files
 285     set additional_files [lindex $args 1]
 286 }
 287
 288 # Return an updated version of OPTIONS that mentions any additional
 289 # source files registered with dg-additional-sources.  SOURCE is the
 290 # name of the test case.
 291
 292 proc dg-additional-files-options { options source } {
 293     global additional_sources
 294     global additional_sources_used
 295     global additional_files
 296     set to_download [list]
 297     if { $additional_sources != "" } then {
 298         if [is_remote host] {
 299             lappend options "additional_flags=$additional_sources"
 300         }
 301         regsub -all "^| " $additional_sources " [file dirname $source]/" additional_sources
 302         if ![is_remote host] {
 303             lappend options "additional_flags=$additional_sources"
 304         }
 305         set to_download [concat $to_download $additional_sources]
 306         set additional_sources_used "$additional_sources"
 307         set additional_sources ""
 308     }
 309     if { $additional_files != "" } then {
 310         regsub -all "^| " $additional_files " [file dirname $source]/" additional_files
 311         set to_download [concat $to_download $additional_files]
 312         set additional_files ""
 313     }
 314     if [is_remote host] {
 315         foreach file $to_download {
 316             remote_download host $file
 317         }
 318     }
 319
 320     return $options
 321 }
 322
 323 # Return a colon-separate list of directories to search for libraries
 324 # for COMPILER, including multilib directories.
 325
 326 proc gcc-set-multilib-library-path { compiler } {
 327     global rootme
 328
 329     # ??? rootme will not be set when testing an installed compiler.
 330     # In that case, we should perhaps use some other method to find
 331     # libraries.
 332     if {![info exists rootme]} {
 333         return ""
 334     }
 335
 336     set libpath ":${rootme}"
 337     set options [lrange $compiler 1 end]
 338     set compiler [lindex $compiler 0]
 339     if { [is_remote host] == 0 && [which $compiler] != 0 } {
 340         foreach i "[eval exec $compiler $options --print-multi-lib]" {
 341             set mldir ""
 342             regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir
 343             set mldir [string trimright $mldir "\;@"]
 344             if { "$mldir" == "." } {
 345                 continue
 346             }
 347             if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s*.so.*]] >= 1 } {
 348                 append libpath ":${rootme}/${mldir}"
 349             }
 350         }
 351     }
 352
 353     return $libpath
 354 }
 355
 356 # A list of all uses of dg-regexp, each entry of the form:
 357 #   line-number regexp
 358 # This is cleared at the end of each test by gcc-dg.exp's wrapper for dg-test.
 359 set freeform_regexps []
 360
 361 # Directive for looking for a regexp, without any line numbers or other
 362 # prefixes.
 363
 364 proc dg-regexp { args } {
 365     verbose "dg-regexp: args: $args" 2
 366
 367     global freeform_regexps
 368     lappend freeform_regexps $args
 369 }
 370
 371 # Hook to be called by prune.exp's prune_gcc_output to
 372 # look for the expected dg-regexp expressions, pruning them,
 373 # reporting PASS for those that are found, and FAIL for
 374 # those that weren't found.
 375 #
 376 # It returns a pruned version of its output.
 377
 378 proc handle-dg-regexps { text } {
 379     global freeform_regexps
 380     global testname_with_flags
 381
 382     foreach entry $freeform_regexps {
 383         verbose "  entry: $entry" 3
 384
 385         set linenum [lindex $entry 0]
 386         set rexp [lindex $entry 1]
 387
 388         # Escape newlines in $rexp so that we can print them in
 389         # pass/fail results.
 390         set escaped_regex [string map {"\n" "\\n"} $rexp]
 391         verbose "escaped_regex: ${escaped_regex}" 4
 392
 393         set title "$testname_with_flags dg-regexp $linenum"
 394
 395         # Use "regsub" to attempt to prune the pattern from $text
 396         if {[regsub -line $rexp $text "" text]} {
 397             # Success; the multiline pattern was pruned.
 398             pass "$title was found: \"$escaped_regex\""
 399         } else {
 400             fail "$title not found: \"$escaped_regex\""
 401         }
 402     }
 403
 404     return $text
 405 }