]>
Commit | Line | Data |
---|---|---|
cd976c16 | 1 | # Copyright (C) 2006, 2007 Free Software Foundation, Inc. |
663230c4 JM |
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 | |
cd976c16 | 5 | # the Free Software Foundation; either version 3 of the License, or |
663230c4 JM |
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 | |
cd976c16 NC |
14 | # along with GCC; see the file COPYING3. If not see |
15 | # <http://www.gnu.org/licenses/>. | |
663230c4 JM |
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 | |
d4038ca2 | 30 | load_lib timeout.exp |
663230c4 JM |
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}" | |
0028647e | 133 | lappend options "compiler=$GNAT_UNDER_TEST -q -f" |
663230c4 | 134 | lappend options "incdir=${rootme}/ada/rts" |
d4038ca2 | 135 | lappend options "timeout=[timeout_value] |
663230c4 JM |
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 | } |