gcc/testsuite/lib/gcc-defs.exp

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