gcc/testsuite/lib/gcc-defs.exp

   1 # Copyright (C) 2001, 2003, 2004 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 2 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 this program; if not, write to the Free Software
  15 # Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  16
  17 load_lib wrapper.exp
  18
  19 #
  20 # ${tool}_check_compile -- Reports and returns pass/fail for a compilation
  21 #
  22
  23 proc ${tool}_check_compile {testcase option objname gcc_output} {
  24     global tool
  25     set fatal_signal "*cc: Internal compiler error: program*got fatal signal"
  26
  27     if [string match "$fatal_signal 6" $gcc_output] then {
  28         ${tool}_fail $testcase "Got Signal 6, $option"
  29         return 0
  30     }
  31
  32     if [string match "$fatal_signal 11" $gcc_output] then {
  33         ${tool}_fail $testcase "Got Signal 11, $option"
  34         return 0
  35     }
  36
  37     # We shouldn't get these because of -w, but just in case.
  38     if [string match "*cc:*warning:*" $gcc_output] then {
  39         warning "$testcase: (with warnings) $option"
  40         send_log "$gcc_output\n"
  41         unresolved "$testcase, $option"
  42         return 0
  43     }
  44
  45     set gcc_output [prune_warnings $gcc_output]
  46
  47     set unsupported_message [${tool}_check_unsupported_p $gcc_output]
  48     if { $unsupported_message != "" } {
  49         unsupported "$testcase: $unsupported_message"
  50         return 0
  51     }
  52
  53     # remove any leftover LF/CR to make sure any output is legit
  54     regsub -all -- "\[\r\n\]*" $gcc_output "" gcc_output
  55
  56     # If any message remains, we fail.
  57     if ![string match "" $gcc_output] then {
  58         ${tool}_fail $testcase $option
  59         return 0
  60     }
  61
  62     # fail if the desired object file doesn't exist.
  63     # FIXME: there's no way of checking for existence on a remote host.
  64     if {$objname != "" && ![is3way] && ![file exists $objname]} {
  65         ${tool}_fail $testcase $option
  66         return 0
  67     }
  68
  69     ${tool}_pass $testcase $option
  70     return 1
  71 }
  72
  73 #
  74 # ${tool}_pass -- utility to record a testcase passed
  75 #
  76
  77 proc ${tool}_pass { testcase cflags } {
  78     if { "$cflags" == "" } {
  79         pass "$testcase"
  80     } else {
  81         pass "$testcase, $cflags"
  82     }
  83 }
  84
  85 #
  86 # ${tool}_fail -- utility to record a testcase failed
  87 #
  88
  89 proc ${tool}_fail { testcase cflags } {
  90     if { "$cflags" == "" } {
  91         fail "$testcase"
  92     } else {
  93         fail "$testcase, $cflags"
  94     }
  95 }
  96
  97 #
  98 # ${tool}_finish -- called at the end of every script that calls ${tool}_init
  99 #
 100 # Hide all quirks of the testing environment from the testsuites.  Also
 101 # undo anything that ${tool}_init did that needs undoing.
 102 #
 103
 104 proc ${tool}_finish { } {
 105     # The testing harness apparently requires this.
 106     global errorInfo;
 107
 108     if [info exists errorInfo] then {
 109         unset errorInfo
 110     }
 111
 112     # Might as well reset these (keeps our caller from wondering whether
 113     # s/he has to or not).
 114     global prms_id bug_id
 115     set prms_id 0
 116     set bug_id 0
 117 }
 118
 119 #
 120 # ${tool}_exit -- Does final cleanup when testing is complete
 121 #
 122
 123 proc ${tool}_exit { } {
 124     global gluefile;
 125
 126     if [info exists gluefile] {
 127         file_on_build delete $gluefile;
 128         unset gluefile;
 129     }
 130 }
 131
 132 #
 133 # ${tool}_check_unsupported_p -- Check the compiler(/assembler/linker) output
 134 #       for text indicating that the testcase should be marked as "unsupported"
 135 #
 136 # Utility used by mike-gcc.exp and c-torture.exp.
 137 # When dealing with a large number of tests, it's difficult to weed out the
 138 # ones that are too big for a particular cpu (eg: 16 bit with a small amount
 139 # of memory).  There are various ways to deal with this.  Here's one.
 140 # Fortunately, all of the cases where this is likely to happen will be using
 141 # gld so we can tell what the error text will look like.
 142 #
 143
 144 proc ${tool}_check_unsupported_p { output } {
 145     if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $output] {
 146         return "memory full"
 147     }
 148     return ""
 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 # Record additional sources files that must be compiled along with the
 171 # main source file.
 172
 173 set additional_sources ""
 174
 175 proc dg-additional-sources { args } {
 176     global additional_sources
 177     set additional_sources [lindex $args 1]
 178 }
 179
 180 # Record additional files -- other than source files -- that must be
 181 # present on the system where the compiler runs.
 182
 183 set additional_files ""
 184
 185 proc dg-additional-files { args } {
 186     global additional_files
 187     set additional_files [lindex $args 1]
 188 }
 189
 190 # Return an updated version of OPTIONS that mentions any additional
 191 # source files registered with dg-additional-sources.  SOURCE is the
 192 # name of the test case.
 193
 194 proc dg-additional-files-options { options source } {
 195     global additional_sources
 196     global additional_files
 197     set to_download [list]
 198     if { $additional_sources != "" } then {
 199         if [is_remote host] {
 200             lappend options "additional_flags=$additional_sources"
 201         }
 202         regsub -all "^| " $additional_sources " [file dirname $source]/" additional_sources
 203         if ![is_remote host] {
 204             lappend options "additional_flags=$additional_sources"
 205         }
 206         set to_download [concat $to_download $additional_sources]
 207         set additional_sources ""
 208     }
 209     if { $additional_files != "" } then {
 210         regsub -all " " $additional_files " [file dirname $source]/" additional_files
 211         set to_download [concat $to_download $additional_files]
 212         set additional_files ""
 213     }
 214     if [is_remote host] {
 215         foreach file $to_download {
 216             remote_download host $file
 217         }
 218     }
 219
 220     return $options
 221 }