File : mdll-utl.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M D L L . T O O L S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 -- Interface to externals tools used to build DLL and import libraries
27
28 with Ada.Text_IO;
29 with Ada.Exceptions;
30
31 with GNAT.Directory_Operations;
32 with Osint;
33
34 package body MDLL.Utl is
35
36 use Ada;
37 use GNAT;
38
39 Dlltool_Name : constant String := "dlltool";
40 Dlltool_Exec : OS_Lib.String_Access;
41
42 Gcc_Name : constant String := "gcc";
43 Gcc_Exec : OS_Lib.String_Access;
44
45 Gnatbind_Name : constant String := "gnatbind";
46 Gnatbind_Exec : OS_Lib.String_Access;
47
48 Gnatlink_Name : constant String := "gnatlink";
49 Gnatlink_Exec : OS_Lib.String_Access;
50
51 procedure Print_Command
52 (Tool_Name : String;
53 Arguments : OS_Lib.Argument_List);
54 -- display the command run when in Verbose mode
55
56 -------------------
57 -- Print_Command --
58 -------------------
59
60 procedure Print_Command
61 (Tool_Name : String;
62 Arguments : OS_Lib.Argument_List)
63 is
64 begin
65 if Verbose then
66 Text_IO.Put (Tool_Name);
67 for K in Arguments'Range loop
68 Text_IO.Put (" " & Arguments (K).all);
69 end loop;
70 Text_IO.New_Line;
71 end if;
72 end Print_Command;
73
74 -------------
75 -- Dlltool --
76 -------------
77
78 procedure Dlltool
79 (Def_Filename : String;
80 DLL_Name : String;
81 Library : String;
82 Exp_Table : String := "";
83 Base_File : String := "";
84 Build_Import : Boolean)
85 is
86 Arguments : OS_Lib.Argument_List (1 .. 11);
87 A : Positive;
88
89 Success : Boolean;
90
91 Def_Opt : aliased String := "--def";
92 Def_V : aliased String := Def_Filename;
93 Dll_Opt : aliased String := "--dllname";
94 Dll_V : aliased String := DLL_Name;
95 Lib_Opt : aliased String := "--output-lib";
96 Lib_V : aliased String := Library;
97 Exp_Opt : aliased String := "--output-exp";
98 Exp_V : aliased String := Exp_Table;
99 Bas_Opt : aliased String := "--base-file";
100 Bas_V : aliased String := Base_File;
101 No_Suf_Opt : aliased String := "-k";
102
103 begin
104 Arguments (1 .. 4) := (1 => Def_Opt'Unchecked_Access,
105 2 => Def_V'Unchecked_Access,
106 3 => Dll_Opt'Unchecked_Access,
107 4 => Dll_V'Unchecked_Access);
108 A := 4;
109
110 if Kill_Suffix then
111 A := A + 1;
112 Arguments (A) := No_Suf_Opt'Unchecked_Access;
113 end if;
114
115 if Library /= "" and then Build_Import then
116 A := A + 1;
117 Arguments (A) := Lib_Opt'Unchecked_Access;
118 A := A + 1;
119 Arguments (A) := Lib_V'Unchecked_Access;
120 end if;
121
122 if Exp_Table /= "" then
123 A := A + 1;
124 Arguments (A) := Exp_Opt'Unchecked_Access;
125 A := A + 1;
126 Arguments (A) := Exp_V'Unchecked_Access;
127 end if;
128
129 if Base_File /= "" then
130 A := A + 1;
131 Arguments (A) := Bas_Opt'Unchecked_Access;
132 A := A + 1;
133 Arguments (A) := Bas_V'Unchecked_Access;
134 end if;
135
136 Print_Command ("dlltool", Arguments (1 .. A));
137
138 OS_Lib.Spawn (Dlltool_Exec.all, Arguments (1 .. A), Success);
139
140 if not Success then
141 Exceptions.Raise_Exception
142 (Tools_Error'Identity, Dlltool_Name & " execution error.");
143 end if;
144 end Dlltool;
145
146 ---------
147 -- Gcc --
148 ---------
149
150 procedure Gcc
151 (Output_File : String;
152 Files : Argument_List;
153 Options : Argument_List;
154 Base_File : String := "";
155 Build_Lib : Boolean := False)
156 is
157 use Osint;
158
159 Arguments : OS_Lib.Argument_List
160 (1 .. 5 + Files'Length + Options'Length);
161 A : Natural := 0;
162
163 Success : Boolean;
164 C_Opt : aliased String := "-c";
165 Out_Opt : aliased String := "-o";
166 Out_V : aliased String := Output_File;
167 Bas_Opt : aliased String := "-Wl,--base-file," & Base_File;
168 Lib_Opt : aliased String := "-mdll";
169 Lib_Dir : aliased String := "-L" & Object_Dir_Default_Prefix;
170
171 begin
172 A := A + 1;
173 if Build_Lib then
174 Arguments (A) := Lib_Opt'Unchecked_Access;
175 else
176 Arguments (A) := C_Opt'Unchecked_Access;
177 end if;
178
179 A := A + 1;
180 Arguments (A .. A + 2) := (Out_Opt'Unchecked_Access,
181 Out_V'Unchecked_Access,
182 Lib_Dir'Unchecked_Access);
183 A := A + 2;
184
185 if Base_File /= "" then
186 A := A + 1;
187 Arguments (A) := Bas_Opt'Unchecked_Access;
188 end if;
189
190 A := A + 1;
191 Arguments (A .. A + Files'Length - 1) := Files;
192 A := A + Files'Length - 1;
193
194 if Build_Lib then
195 A := A + 1;
196 Arguments (A .. A + Options'Length - 1) := Options;
197 A := A + Options'Length - 1;
198 else
199 declare
200 Largs : Argument_List (Options'Range);
201 L : Natural := Largs'First - 1;
202 begin
203 for K in Options'Range loop
204 if Options (K) (1 .. 2) /= "-l" then
205 L := L + 1;
206 Largs (L) := Options (K);
207 end if;
208 end loop;
209 A := A + 1;
210 Arguments (A .. A + L - 1) := Largs (1 .. L);
211 A := A + L - 1;
212 end;
213 end if;
214
215 Print_Command ("gcc", Arguments (1 .. A));
216
217 OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
218
219 if not Success then
220 Exceptions.Raise_Exception
221 (Tools_Error'Identity, Gcc_Name & " execution error.");
222 end if;
223 end Gcc;
224
225 --------------
226 -- Gnatbind --
227 --------------
228
229 procedure Gnatbind
230 (Alis : Argument_List;
231 Args : Argument_List := Null_Argument_List)
232 is
233 Arguments : OS_Lib.Argument_List (1 .. 1 + Alis'Length + Args'Length);
234 Success : Boolean;
235
236 No_Main_Opt : aliased String := "-n";
237
238 begin
239 Arguments (1) := No_Main_Opt'Unchecked_Access;
240 Arguments (2 .. 1 + Alis'Length) := Alis;
241 Arguments (2 + Alis'Length .. Arguments'Last) := Args;
242
243 Print_Command ("gnatbind", Arguments);
244
245 OS_Lib.Spawn (Gnatbind_Exec.all, Arguments, Success);
246
247 -- Delete binder files on failure
248
249 if not Success then
250 declare
251 Base_Name : constant String :=
252 Directory_Operations.Base_Name (Alis (Alis'First).all, ".ali");
253 begin
254 OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
255 OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);
256 end;
257
258 Exceptions.Raise_Exception
259 (Tools_Error'Identity, Gnatbind_Name & " execution error.");
260 end if;
261 end Gnatbind;
262
263 --------------
264 -- Gnatlink --
265 --------------
266
267 procedure Gnatlink
268 (Ali : String;
269 Args : Argument_List := Null_Argument_List)
270 is
271 Arguments : OS_Lib.Argument_List (1 .. 1 + Args'Length);
272 Success : Boolean;
273
274 Ali_Name : aliased String := Ali;
275
276 begin
277 Arguments (1) := Ali_Name'Unchecked_Access;
278 Arguments (2 .. Arguments'Last) := Args;
279
280 Print_Command ("gnatlink", Arguments);
281
282 OS_Lib.Spawn (Gnatlink_Exec.all, Arguments, Success);
283
284 if not Success then
285 -- Delete binder files
286 declare
287 Base_Name : constant String :=
288 Directory_Operations.Base_Name (Ali, ".ali");
289 begin
290 OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
291 OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);
292 OS_Lib.Delete_File ("b~" & Base_Name & ".ali", Success);
293 OS_Lib.Delete_File ("b~" & Base_Name & ".o", Success);
294 end;
295
296 Exceptions.Raise_Exception
297 (Tools_Error'Identity, Gnatlink_Name & " execution error.");
298 end if;
299 end Gnatlink;
300
301 ------------
302 -- Locate --
303 ------------
304
305 procedure Locate is
306 use type OS_Lib.String_Access;
307 begin
308 -- dlltool
309
310 if Dlltool_Exec = null then
311 Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name);
312
313 if Dlltool_Exec = null then
314 Exceptions.Raise_Exception
315 (Tools_Error'Identity, Dlltool_Name & " not found in path");
316
317 elsif Verbose then
318 Text_IO.Put_Line ("using " & Dlltool_Exec.all);
319 end if;
320 end if;
321
322 -- gcc
323
324 if Gcc_Exec = null then
325 Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
326
327 if Gcc_Exec = null then
328 Exceptions.Raise_Exception
329 (Tools_Error'Identity, Gcc_Name & " not found in path");
330
331 elsif Verbose then
332 Text_IO.Put_Line ("using " & Gcc_Exec.all);
333 end if;
334 end if;
335
336 -- gnatbind
337
338 if Gnatbind_Exec = null then
339 Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name);
340
341 if Gnatbind_Exec = null then
342 Exceptions.Raise_Exception
343 (Tools_Error'Identity, Gnatbind_Name & " not found in path");
344
345 elsif Verbose then
346 Text_IO.Put_Line ("using " & Gnatbind_Exec.all);
347 end if;
348 end if;
349
350 -- gnatlink
351
352 if Gnatlink_Exec = null then
353 Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name);
354
355 if Gnatlink_Exec = null then
356 Exceptions.Raise_Exception
357 (Tools_Error'Identity, Gnatlink_Name & " not found in path");
358
359 elsif Verbose then
360 Text_IO.Put_Line ("using " & Gnatlink_Exec.all);
361 Text_IO.New_Line;
362 end if;
363 end if;
364 end Locate;
365
366 end MDLL.Utl;