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