OSDN Git Service

d37a4aa1e06f55305fd965a1da3c244bdbd4bd93
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / lib / gnat.exp
1 # Copyright (C) 2006, 2007, 2008 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 # This file was written by James A. Morrison (ja2morri@uwaterloo.ca)
18 # based on gcc.exp written by Rob Savoye (rob@cygnus.com).
19
20 # This file is loaded by the tool init file (eg: unix.exp).  It provides
21 # default definitions for gnat_start, etc. and other supporting cast members.
22
23 # These globals are used 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 load_lib libgloss.exp
28 load_lib prune.exp
29 load_lib gcc-defs.exp
30 load_lib timeout.exp
31
32 #
33 # GNAT_UNDER_TEST is the compiler under test.
34 #
35
36 #
37 # default_gnat_version -- extract and print the version number of the compiler
38 #
39
40 proc default_gnat_version { } {
41     global GNAT_UNDER_TEST
42
43     gnat_init
44
45     # ignore any arguments after the command
46     set compiler [lindex $GNAT_UNDER_TEST 0]
47
48     if ![is_remote host] {
49         set compiler_name [which $compiler]
50     } else {
51         set compiler_name $compiler
52     }
53
54     # verify that the compiler exists
55     if { $compiler_name != 0 } then {
56         set tmp [remote_exec host "$compiler -v"]
57         set status [lindex $tmp 0]
58         set output [lindex $tmp 1]
59         regexp " version \[^\n\r\]*" $output version
60         if { $status == 0 && [info exists version] } then {
61             clone_output "$compiler_name $version\n"
62         } else {
63             clone_output "Couldn't determine version of $compiler_name: $output\n"
64         }
65     } else {
66         # compiler does not exist (this should have already been detected)
67         warning "$compiler does not exist"
68     }
69 }
70
71 # gnat_init -- called at the start of each .exp script.
72 #
73 # There currently isn't much to do, but always using it allows us to
74 # make some enhancements without having to go back and rewrite the scripts.
75 #
76
77 set gnat_initialized 0
78
79 proc gnat_init { args } {
80     global rootme
81     global tmpdir
82     global libdir
83     global gluefile wrap_flags
84     global gnat_initialized
85     global GNAT_UNDER_TEST
86     global TOOL_EXECUTABLE
87     global gnat_libgcc_s_path
88
89     if { $gnat_initialized == 1 } { return }
90
91     if ![info exists GNAT_UNDER_TEST] then {
92         if [info exists TOOL_EXECUTABLE] {
93             set GNAT_UNDER_TEST $TOOL_EXECUTABLE
94         } else {
95             set GNAT_UNDER_TEST [find_gnatmake]
96         }
97     }
98
99     if ![info exists tmpdir] then {
100         set tmpdir /tmp
101     }
102
103     set gnat_libgcc_s_path "${rootme}"
104     # Leave this here since Ada should support multilibs at some point.
105     set compiler [lindex $GNAT_UNDER_TEST 0]
106 #    if { [is_remote host] == 0 && [which $compiler] != 0 } {
107 #       foreach i "[exec $compiler --print-multi-lib]" {
108 #           set mldir ""
109 #           regexp -- "\[a-z0-9=/\.-\]*;" $i mldir
110 #           set mldir [string trimright $mldir "\;@"]
111 #           if { "$mldir" == "." } {
112 #               continue
113 #           }
114 #           if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s*.so.*]] >= 1 } {
115 #               append gnat_libgcc_s_path ":${rootme}/${mldir}"
116 #           }
117 #       }
118 #    }
119 }
120
121 proc gnat_target_compile { source dest type options } {
122     global rootme
123     global tmpdir
124     global gluefile wrap_flags
125     global srcdir
126     global GNAT_UNDER_TEST
127     global TOOL_OPTIONS
128     global ld_library_path
129     global gnat_libgcc_s_path
130
131     setenv ADA_INCLUDE_PATH "${rootme}/ada/rts"
132     set ld_library_path ".:${gnat_libgcc_s_path}"
133     lappend options "compiler=$GNAT_UNDER_TEST -q -f"
134     lappend options "incdir=${rootme}/ada/rts"
135     lappend options "timeout=[timeout_value]"
136
137     if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } {
138         lappend options "libs=${gluefile}"
139         lappend options "ldflags=$wrap_flags"
140     }
141
142     # TOOL_OPTIONS must come first, so that it doesn't override testcase
143     # specific options.
144     if [info exists TOOL_OPTIONS] {
145         set options [concat "additional_flags=$TOOL_OPTIONS" $options]
146     }
147
148     # If we have built libada along with the compiler, point the test harness
149     # at it (and associated headers).
150
151 #    set sourcename [string range $source 0 [expr [string length $source] - 5]]
152 #    set dest ""
153     return [target_compile $source $dest $type $options]
154 }
155
156 #
157 # gnat_pass -- utility to record a testcase passed
158 #
159
160 proc gnat_pass { testcase cflags } {
161     if { "$cflags" == "" } {
162         pass "$testcase"
163     } else {
164         pass "$testcase, $cflags"
165     }
166 }
167
168 #
169 # gnat_fail -- utility to record a testcase failed
170 #
171
172 proc gnat_fail { testcase cflags } {
173     if { "$cflags" == "" } {
174         fail "$testcase"
175     } else {
176         fail "$testcase, $cflags"
177     }
178 }
179
180 #
181 # gnat_finish -- called at the end of every .exp script that calls gnat_init
182 #
183 # The purpose of this proc is to hide all quirks of the testing environment
184 # from the testsuites.  It also exists to undo anything that gnat_init did
185 # (that needs undoing).
186 #
187
188 proc gnat_finish { } {
189     # The testing harness apparently requires this.
190     global errorInfo
191
192     if [info exists errorInfo] then {
193         unset errorInfo
194     }
195
196     # Might as well reset these (keeps our caller from wondering whether
197     # s/he has to or not).
198     global prms_id bug_id
199     set prms_id 0
200     set bug_id 0
201 }
202
203 proc gnat_exit { } {
204     global gluefile
205
206     if [info exists gluefile] {
207         file_on_build delete $gluefile
208         unset gluefile
209     }
210 }
211
212 # Prune messages from GNAT that aren't useful.
213
214 proc prune_gnat_output { text } {
215     #send_user "Before:$text\n"
216     regsub -all "(^|\n)\[^\n\]*: In (function|method) \[^\n\]*" $text "" text
217     regsub -all "(^|\n)\[^\n\]*: At top level:\[^\n\]*" $text "" text
218
219     # prune the output from gnatmake.
220     regsub -all "(^|\n)\[^\n\]*gnatmake: [^\n\]*" $text "" text
221
222     # It would be nice to avoid passing anything to gnat that would cause it to
223     # issue these messages (since ignoring them seems like a hack on our part),
224     # but that's too difficult in the general case.  For example, sometimes
225     # you need to use -B to point gnat at crt0.o, but there are some targets
226     # that don't have crt0.o.
227     regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text
228     regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text
229
230     #send_user "After:$text\n"
231
232     return $text
233 }
234
235 # If this is an older version of DejaGnu (without find_gnatmake), provide one.
236 # This can be deleted after next DejaGnu release.
237
238 if { [info procs find_gnatmake] == "" } {
239     proc find_gnatmake {} {
240         global tool_root_dir
241
242         if ![is_remote host] {
243             set file [lookfor_file $tool_root_dir gnatmake]
244             if { $file == "" } {
245                 set file [lookfor_file $tool_root_dir gcc/gnatmake]
246             }
247             if { $file != "" } {
248                 set root [file dirname $file]
249                 set CC "$file -I$root/ada/rts --GCC=$root/xgcc --GNATBIND=$root/gnatbind --GNATLINK=$root/gnatlink -cargs -B$root -largs --GCC=$root/xgcc -B$root -margs";
250             } else {
251                 set CC [transform gnatmake]
252             }
253         } else {
254             set CC [transform gnatmake]
255         }
256         return $CC
257     }
258 }
259
260 # If this is an older version of DejaGnu (without runtest_file_p),
261 # provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
262 # This can be deleted after next DejaGnu release.
263
264 if { [info procs runtest_file_p] == "" } then {
265     proc runtest_file_p { runtests testcase } {
266         if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
267             if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
268                 return 1
269             } else {
270                 return 0
271             }
272         }
273         return 1
274     }
275 }
276
277 # Provide a definition of this if missing (delete after next DejaGnu release).
278
279 if { [info procs prune_warnings] == "" } then {
280     proc prune_warnings { text } {
281         return $text
282     }
283 }