gcc/testsuite/lib/g77.exp

   1 # Copyright (C) 1992, 1993, 1994, 1996, 1997 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 # This file was written by Rob Savoye (rob@cygnus.com)
  18 # Currently maintained by Doug Evans (dje@cygnus.com)
  19
  20 # This file is loaded by the tool init file (eg: unix.exp).  It provides
  21 # default definitions for g77_start, etc. and other supporting cast members.
  22
  23 # These globals are used by g77_start if no compiler arguments are provided.
  24 # They are also used by the various testsuites to define the environment:
  25 # where to find stdio.h, libc.a, etc.
  26
  27 #
  28 # G77_UNDER_TEST is the compiler under test.
  29 #
  30
  31 #
  32 # default_g77_version -- extract and print the version number of the compiler
  33 #
  34
  35 proc default_g77_version { } {
  36     global G77_UNDER_TEST
  37
  38     g77_init;
  39
  40     # ignore any arguments after the command
  41     set compiler [lindex $G77_UNDER_TEST 0]
  42
  43     if ![is_remote host] {
  44         set compiler_name [which $compiler];
  45     } else {
  46         set compiler_name $compiler;
  47     }
  48
  49     # verify that the compiler exists
  50     if { $compiler_name != 0 } then {
  51         set options ""
  52
  53         lappend options "additional_flags=-v"
  54         set tmp [g77_target_compile "" "" "none" $options]
  55         regexp "g77 version\[^\n\]*" $tmp version
  56         if { [info exists version] } then {
  57             clone_output "$compiler_name $version\n"
  58         } else {
  59             clone_output "Couldn't determine version of $compiler_name: $tmp\n"
  60         }
  61     } else {
  62         # compiler does not exist (this should have already been detected)
  63         warning "$compiler does not exist"
  64     }
  65 }
  66
  67 #
  68 # Call g77_version. We do it this way so we can override it if needed.
  69 #
  70 proc g77_version { } {
  71     default_g77_version;
  72 }
  73
  74 #
  75 # g77_init -- called at the start of each .exp script.
  76 #
  77 # There currently isn't much to do, but always using it allows us to
  78 # make some enhancements without having to go back and rewrite the scripts.
  79 #
  80
  81 set g77_initialized 0
  82
  83 proc g77_init { args } {
  84     global tmpdir
  85     global libdir
  86     global gluefile wrap_flags
  87     global g77_initialized
  88     global G77_UNDER_TEST
  89     global TOOL_EXECUTABLE
  90
  91     if { $g77_initialized == 1 } { return; }
  92
  93     if ![info exists G77_UNDER_TEST] then {
  94         if [info exists TOOL_EXECUTABLE] {
  95             set G77_UNDER_TEST $TOOL_EXECUTABLE;
  96         } else {
  97             set G77_UNDER_TEST [find_g77]
  98         }
  99     }
 100
 101     if ![info exists tmpdir] then {
 102         set tmpdir /tmp
 103     }
 104     if { [target_info needs_status_wrapper]!="" && ![info exists gluefile] } {
 105         set gluefile ${tmpdir}/testglue.o;
 106         set result [build_wrapper $gluefile];
 107         if { $result != "" } {
 108             set gluefile [lindex $result 0];
 109             set wrap_flags [lindex $result 1];
 110         } else {
 111             unset gluefile
 112         }
 113     }
 114 }
 115
 116 proc g77_target_compile { source dest type options } {
 117     global tmpdir;
 118     global gluefile wrap_flags;
 119     global G77_UNDER_TEST
 120     global TOOL_OPTIONS
 121
 122     if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } {
 123         lappend options "libs=${gluefile}"
 124         lappend options "ldflags=$wrap_flags"
 125     }
 126
 127     if [target_info exists g77,stack_size] {
 128         lappend options "additional_flags=-DSTACK_SIZE=[target_info g77,stack_size]"
 129     }
 130     if [target_info exists g77,no_trampolines] {
 131         lappend options "additional_flags=-DNO_TRAMPOLINES"
 132     }
 133     if [target_info exists g77,no_label_values] {
 134         lappend options "additional_flags=-DNO_LABEL_VALUES"
 135     }
 136     if [info exists TOOL_OPTIONS] {
 137         lappend options "additional_flags=$TOOL_OPTIONS"
 138     }
 139     if [target_info exists g77,no_varargs] {
 140         lappend options "additional_flags=-DNO_VARARGS"
 141     }
 142     if ![is_remote host] {
 143       set gccpath "[get_multilibs]"
 144       set libg2c_dir [lookfor_file ${gccpath} libf2c/libg2c.a]
 145       if { $libg2c_dir != "" } {
 146         set libg2c_link_flags "-L[file dirname ${libg2c_dir}]"
 147         lappend options "additional_flags=${libg2c_link_flags}"
 148       }
 149     }
 150     lappend options "compiler=$G77_UNDER_TEST"
 151     return [target_compile $source $dest $type $options]
 152 }
 153
 154 #
 155 # g77_pass -- utility to record a testcase passed
 156 #
 157
 158 proc g77_pass { testcase cflags } {
 159     if { "$cflags" == "" } {
 160         pass "$testcase"
 161     } else {
 162         pass "$testcase, $cflags"
 163     }
 164 }
 165
 166 #
 167 # g77_fail -- utility to record a testcase failed
 168 #
 169
 170 proc g77_fail { testcase cflags } {
 171     if { "$cflags" == "" } {
 172         fail "$testcase"
 173     } else {
 174         fail "$testcase, $cflags"
 175     }
 176 }
 177
 178 #
 179 # g77_finish -- called at the end of every .exp script that calls g77_init
 180 #
 181 # The purpose of this proc is to hide all quirks of the testing environment
 182 # from the testsuites.  It also exists to undo anything that g77_init did
 183 # (that needs undoing).
 184 #
 185
 186 proc g77_finish { } {
 187     # The testing harness apparently requires this.
 188     global errorInfo;
 189
 190     if [info exists errorInfo] then {
 191         unset errorInfo
 192     }
 193
 194     # Might as well reset these (keeps our caller from wondering whether
 195     # s/he has to or not).
 196     global prms_id bug_id
 197     set prms_id 0
 198     set bug_id 0
 199 }
 200
 201 proc g77_exit { } {
 202     global gluefile;
 203
 204     if [info exists gluefile] {
 205         file_on_build delete $gluefile;
 206         unset gluefile;
 207     }
 208 }
 209
 210 # If this is an older version of dejagnu (without runtest_file_p),
 211 # provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
 212 # This can be deleted after next dejagnu release.
 213
 214 if { [info procs runtest_file_p] == "" } then {
 215     proc runtest_file_p { runtests testcase } {
 216         if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
 217             if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
 218                 return 1
 219             } else {
 220                 return 0
 221             }
 222         }
 223         return 1
 224     }
 225 }
 226
 227 # Provide a definition of this if missing (delete after next dejagnu release).
 228
 229 if { [info procs prune_warnings] == "" } then {
 230     proc prune_warnings { text } {
 231         return $text
 232     }
 233 }
 234
 235 # Utility used by mike-gcc.exp and c-torture.exp.
 236 # Check the compiler(/assembler/linker) output for text indicating that
 237 # the testcase should be marked as "unsupported".
 238 #
 239 # When dealing with a large number of tests, it's difficult to weed out the
 240 # ones that are too big for a particular cpu (eg: 16 bit with a small amount
 241 # of memory).  There are various ways to deal with this.  Here's one.
 242 # Fortunately, all of the cases where this is likely to happen will be using
 243 # gld so we can tell what the error text will look like.
 244
 245 proc ${tool}_check_unsupported_p { output } {
 246     if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $output] {
 247         return "memory full"
 248     }
 249     return ""
 250 }
 251
 252 # Prune messages from g77 that aren't useful.
 253
 254 proc prune_g77_output { text } {
 255     #send_user "Before:$text\n"
 256     regsub -all "(^|\n)\[^\n\]*: In (function|method) \[^\n\]*" $text "" text
 257     regsub -all "(^|\n)\[^\n\]*: At top level:\[^\n\]*" $text "" text
 258
 259     # It would be nice to avoid passing anything to g77 that would cause it to
 260     # issue these messages (since ignoring them seems like a hack on our part),
 261     # but that's too difficult in the general case.  For example, sometimes
 262     # you need to use -B to point g77 at crt0.o, but there are some targets
 263     # that don't have crt0.o.
 264     regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text
 265     regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text
 266
 267     #send_user "After:$text\n"
 268
 269     return $text
 270 }
 271