File : mlib-utl.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M L I B . U T L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2002-2014, AdaCore --
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 with MLib.Fil; use MLib.Fil;
27 with MLib.Tgt; use MLib.Tgt;
28 with Opt;
29 with Osint;
30 with Output; use Output;
31
32 with Interfaces.C.Strings; use Interfaces.C.Strings;
33
34 package body MLib.Utl is
35
36 Adalib_Path : String_Access := null;
37 -- Path of the GNAT adalib directory, specified in procedure
38 -- Specify_Adalib_Dir. Used in function Lib_Directory.
39
40 Gcc_Name : String_Access;
41 -- Default value of the "gcc" executable used in procedure Gcc
42
43 Gcc_Exec : String_Access;
44 -- The full path name of the "gcc" executable
45
46 Ar_Name : String_Access;
47 -- The name of the archive builder for the platform, set when procedure Ar
48 -- is called for the first time.
49
50 Ar_Exec : String_Access;
51 -- The full path name of the archive builder
52
53 Ar_Options : String_List_Access;
54 -- The minimum options used when invoking the archive builder
55
56 Ar_Append_Options : String_List_Access;
57 -- The options to be used when invoking the archive builder to add chunks
58 -- of object files, when building the archive in chunks.
59
60 Opt_Length : Natural := 0;
61 -- The max number of options for the Archive_Builder
62
63 Initial_Size : Natural := 0;
64 -- The minimum number of bytes for the invocation of the Archive Builder
65 -- (without name of the archive or object files).
66
67 Ranlib_Name : String_Access;
68 -- The name of the archive indexer for the platform, if there is one
69
70 Ranlib_Exec : String_Access := null;
71 -- The full path name of the archive indexer
72
73 Ranlib_Options : String_List_Access := null;
74 -- The options to be used when invoking the archive indexer, if any
75
76 --------
77 -- Ar --
78 --------
79
80 procedure Ar (Output_File : String; Objects : Argument_List) is
81 Full_Output_File : constant String :=
82 Ext_To (Output_File, Archive_Ext);
83
84 Arguments : Argument_List_Access;
85 Last_Arg : Natural := 0;
86 Success : Boolean;
87 Line_Length : Natural := 0;
88
89 Maximum_Size : Integer;
90 pragma Import (C, Maximum_Size, "__gnat_link_max");
91 -- Maximum number of bytes to put in an invocation of the
92 -- Archive_Builder.
93
94 Size : Integer;
95 -- The number of bytes for the invocation of the archive builder
96
97 Current_Object : Natural;
98
99 procedure Display;
100 -- Display an invocation of the Archive Builder
101
102 -------------
103 -- Display --
104 -------------
105
106 procedure Display is
107 begin
108 if not Opt.Quiet_Output then
109 Write_Str (Ar_Name.all);
110 Line_Length := Ar_Name'Length;
111
112 for J in 1 .. Last_Arg loop
113
114 -- Make sure the Output buffer does not overflow
115
116 if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
117 Write_Eol;
118 Line_Length := 0;
119 end if;
120
121 Write_Char (' ');
122
123 -- Only output the first object files when not in verbose mode
124
125 if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
126 Write_Str ("...");
127 exit;
128 end if;
129
130 Write_Str (Arguments (J).all);
131 Line_Length := Line_Length + 1 + Arguments (J)'Length;
132 end loop;
133
134 Write_Eol;
135 end if;
136
137 end Display;
138
139 begin
140 if Ar_Exec = null then
141 Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake");
142 Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
143
144 if Ar_Exec = null then
145 Free (Ar_Name);
146 Ar_Name := new String'(Archive_Builder);
147 Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
148 end if;
149
150 if Ar_Exec = null then
151 Fail (Ar_Name.all & " not found in path");
152
153 elsif Opt.Verbose_Mode then
154 Write_Str ("found ");
155 Write_Line (Ar_Exec.all);
156 end if;
157
158 Ar_Options := Archive_Builder_Options;
159
160 Initial_Size := 0;
161 for J in Ar_Options'Range loop
162 Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
163 end loop;
164
165 Ar_Append_Options := Archive_Builder_Append_Options;
166
167 Opt_Length := Ar_Options'Length;
168
169 if Ar_Append_Options /= null then
170 Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
171
172 Size := 0;
173 for J in Ar_Append_Options'Range loop
174 Size := Size + Ar_Append_Options (J)'Length + 1;
175 end loop;
176
177 Initial_Size := Integer'Max (Initial_Size, Size);
178 end if;
179
180 -- ranlib
181
182 Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake");
183
184 if Ranlib_Name'Length > 0 then
185 Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
186
187 if Ranlib_Exec = null then
188 Free (Ranlib_Name);
189 Ranlib_Name := new String'(Archive_Indexer);
190 Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
191 end if;
192
193 if Ranlib_Exec /= null and then Opt.Verbose_Mode then
194 Write_Str ("found ");
195 Write_Line (Ranlib_Exec.all);
196 end if;
197 end if;
198
199 Ranlib_Options := Archive_Indexer_Options;
200 end if;
201
202 Arguments :=
203 new String_List (1 .. 1 + Opt_Length + Objects'Length);
204 Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..."
205 Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
206
207 Delete_File (Full_Output_File);
208
209 Size := Initial_Size + Full_Output_File'Length + 1;
210
211 -- Check the full size of a call of the archive builder with all the
212 -- object files.
213
214 for J in Objects'Range loop
215 Size := Size + Objects (J)'Length + 1;
216 end loop;
217
218 -- If the size is not too large or if it is not possible to build the
219 -- archive in chunks, build the archive in a single invocation.
220
221 if Size <= Maximum_Size or else Ar_Append_Options = null then
222 Last_Arg := Ar_Options'Length + 1 + Objects'Length;
223 Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
224
225 Display;
226
227 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
228
229 else
230 -- Build the archive in several invocation, making sure to not
231 -- go over the maximum size for each invocation.
232
233 Last_Arg := Ar_Options'Length + 1;
234 Current_Object := Objects'First;
235 Size := Initial_Size + Full_Output_File'Length + 1;
236
237 -- First invocation
238
239 while Current_Object <= Objects'Last loop
240 Size := Size + Objects (Current_Object)'Length + 1;
241 exit when Size > Maximum_Size;
242 Last_Arg := Last_Arg + 1;
243 Arguments (Last_Arg) := Objects (Current_Object);
244 Current_Object := Current_Object + 1;
245 end loop;
246
247 Display;
248
249 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
250
251 Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
252 Arguments
253 (Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
254
255 -- Appending invocation(s)
256
257 Big_Loop : while Success and then Current_Object <= Objects'Last loop
258 Last_Arg := Ar_Append_Options'Length + 1;
259 Size := Initial_Size + Full_Output_File'Length + 1;
260
261 Inner_Loop : while Current_Object <= Objects'Last loop
262 Size := Size + Objects (Current_Object)'Length + 1;
263 exit Inner_Loop when Size > Maximum_Size;
264 Last_Arg := Last_Arg + 1;
265 Arguments (Last_Arg) := Objects (Current_Object);
266 Current_Object := Current_Object + 1;
267 end loop Inner_Loop;
268
269 Display;
270
271 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
272 end loop Big_Loop;
273 end if;
274
275 if not Success then
276 Fail (Ar_Name.all & " execution error.");
277 end if;
278
279 -- If we have found ranlib, run it over the library
280
281 if Ranlib_Exec /= null then
282 if not Opt.Quiet_Output then
283 Write_Str (Ranlib_Name.all);
284 Write_Char (' ');
285
286 for J in Ranlib_Options'Range loop
287 Write_Str (Ranlib_Options (J).all);
288 Write_Char (' ');
289 end loop;
290
291 Write_Line (Arguments (Ar_Options'Length + 1).all);
292 end if;
293
294 Spawn
295 (Ranlib_Exec.all,
296 Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
297 Success);
298
299 if not Success then
300 Fail (Ranlib_Name.all & " execution error.");
301 end if;
302 end if;
303 end Ar;
304
305 -----------------
306 -- Delete_File --
307 -----------------
308
309 procedure Delete_File (Filename : String) is
310 File : constant String := Filename & ASCII.NUL;
311 Success : Boolean;
312
313 begin
314 Delete_File (File'Address, Success);
315
316 if Opt.Verbose_Mode then
317 if Success then
318 Write_Str ("deleted ");
319
320 else
321 Write_Str ("could not delete ");
322 end if;
323
324 Write_Line (Filename);
325 end if;
326 end Delete_File;
327
328 ---------
329 -- Gcc --
330 ---------
331
332 procedure Gcc
333 (Output_File : String;
334 Objects : Argument_List;
335 Options : Argument_List;
336 Options_2 : Argument_List;
337 Driver_Name : Name_Id := No_Name)
338 is
339 Link_Bytes : Integer := 0;
340 -- Projected number of bytes for the linker command line
341
342 Link_Max : Integer;
343 pragma Import (C, Link_Max, "__gnat_link_max");
344 -- Maximum number of bytes on the command line supported by the OS
345 -- linker. Passed this limit the response file mechanism must be used
346 -- if supported.
347
348 Object_List_File_Supported : Boolean;
349 for Object_List_File_Supported'Size use Character'Size;
350 pragma Import
351 (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
352 -- Predicate indicating whether the linker has an option whereby the
353 -- names of object files can be passed to the linker in a file.
354
355 Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
356 pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
357 -- Pointer to a string representing the linker option which specifies
358 -- the response file.
359
360 Object_File_Option : constant String := Value (Object_File_Option_Ptr);
361 -- The linker option which specifies the response file as a string
362
363 Using_GNU_response_file : constant Boolean :=
364 Object_File_Option'Length > 0
365 and then
366 Object_File_Option
367 (Object_File_Option'Last) = '@';
368 -- Whether a GNU response file is used
369
370 Tname : String_Access;
371 Tname_FD : File_Descriptor := Invalid_FD;
372 -- Temporary file used by linker to pass list of object files on
373 -- certain systems with limitations on size of arguments.
374
375 Closing_Status : Boolean;
376 -- For call to Close
377
378 Arguments :
379 Argument_List
380 (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
381
382 A : Natural := 0;
383 Success : Boolean;
384
385 Out_Opt : constant String_Access := new String'("-o");
386 Out_V : constant String_Access := new String'(Output_File);
387 Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
388 Lib_Opt : constant String_Access := new String'(Dynamic_Option);
389
390 Driver : String_Access;
391
392 type Object_Position is (First, Second, Last);
393
394 Position : Object_Position;
395
396 procedure Write_RF (S : String);
397 -- Write a string to the response file and check if it was successful.
398 -- Fail the program if it was not successful (disk full).
399
400 --------------
401 -- Write_RF --
402 --------------
403
404 procedure Write_RF (S : String) is
405 Success : Boolean := True;
406 Back_Slash : constant Character := '\';
407
408 begin
409 -- If a GNU response file is used, space and backslash need to be
410 -- escaped because they are interpreted as a string separator and
411 -- an escape character respectively by the underlying mechanism.
412 -- On the other hand, quote and double-quote are not escaped since
413 -- they are interpreted as string delimiters on both sides.
414
415 if Using_GNU_response_file then
416 for J in S'Range loop
417 if S (J) = ' ' or else S (J) = '\' then
418 if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then
419 Success := False;
420 end if;
421 end if;
422
423 if Write (Tname_FD, S (J)'Address, 1) /= 1 then
424 Success := False;
425 end if;
426 end loop;
427
428 else
429 if Write (Tname_FD, S'Address, S'Length) /= S'Length then
430 Success := False;
431 end if;
432 end if;
433
434 if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then
435 Success := False;
436 end if;
437
438 if not Success then
439 Fail ("cannot generate response file to link library: disk full");
440 end if;
441 end Write_RF;
442
443 -- Start of processing for Gcc
444
445 begin
446 if Driver_Name = No_Name then
447 if Gcc_Exec = null then
448 if Gcc_Name = null then
449 Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
450 end if;
451
452 Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
453
454 if Gcc_Exec = null then
455 Fail (Gcc_Name.all & " not found in path");
456 end if;
457 end if;
458
459 Driver := Gcc_Exec;
460
461 else
462 Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
463
464 if Driver = null then
465 Fail (Get_Name_String (Driver_Name) & " not found in path");
466 end if;
467 end if;
468
469 Link_Bytes := 0;
470
471 if Lib_Opt'Length /= 0 then
472 A := A + 1;
473 Arguments (A) := Lib_Opt;
474 Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
475 end if;
476
477 A := A + 1;
478 Arguments (A) := Out_Opt;
479 Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
480
481 A := A + 1;
482 Arguments (A) := Out_V;
483 Link_Bytes := Link_Bytes + Out_V'Length + 1;
484
485 A := A + 1;
486 Arguments (A) := Lib_Dir;
487 Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
488
489 A := A + Options'Length;
490 Arguments (A - Options'Length + 1 .. A) := Options;
491
492 for J in Options'Range loop
493 Link_Bytes := Link_Bytes + Options (J)'Length + 1;
494 end loop;
495
496 if not Opt.Quiet_Output then
497 if Opt.Verbose_Mode then
498 Write_Str (Driver.all);
499
500 elsif Driver_Name /= No_Name then
501 Write_Str (Get_Name_String (Driver_Name));
502
503 else
504 Write_Str (Gcc_Name.all);
505 end if;
506
507 for J in 1 .. A loop
508 if Opt.Verbose_Mode or else J < 4 then
509 Write_Char (' ');
510 Write_Str (Arguments (J).all);
511
512 else
513 Write_Str (" ...");
514 exit;
515 end if;
516 end loop;
517
518 -- Do not display all the object files if not in verbose mode, only
519 -- the first one.
520
521 Position := First;
522 for J in Objects'Range loop
523 if Opt.Verbose_Mode or else Position = First then
524 Write_Char (' ');
525 Write_Str (Objects (J).all);
526 Position := Second;
527
528 elsif Position = Second then
529 Write_Str (" ...");
530 Position := Last;
531 exit;
532 end if;
533 end loop;
534
535 for J in Options_2'Range loop
536 if not Opt.Verbose_Mode then
537 if Position = Second then
538 Write_Str (" ...");
539 end if;
540
541 exit;
542 end if;
543
544 Write_Char (' ');
545 Write_Str (Options_2 (J).all);
546 end loop;
547
548 Write_Eol;
549 end if;
550
551 for J in Objects'Range loop
552 Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
553 end loop;
554
555 for J in Options_2'Range loop
556 Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
557 end loop;
558
559 if Object_List_File_Supported and then Link_Bytes > Link_Max then
560
561 -- Create a temporary file containing the object files, one object
562 -- file per line for maximal compatibility with linkers supporting
563 -- this option.
564
565 Create_Temp_File (Tname_FD, Tname);
566
567 for J in Objects'Range loop
568 Write_RF (Objects (J).all);
569 end loop;
570
571 Close (Tname_FD, Closing_Status);
572
573 if not Closing_Status then
574 Fail ("cannot generate response file to link library: disk full");
575 end if;
576
577 A := A + 1;
578 Arguments (A) := new String'(Object_File_Option & Tname.all);
579
580 else
581 A := A + Objects'Length;
582 Arguments (A - Objects'Length + 1 .. A) := Objects;
583 end if;
584
585 A := A + Options_2'Length;
586 Arguments (A - Options_2'Length + 1 .. A) := Options_2;
587
588 Spawn (Driver.all, Arguments (1 .. A), Success);
589
590 if Success then
591 -- Delete the temporary file used in conjunction with linking
592 -- if one was created.
593
594 if Tname_FD /= Invalid_FD then
595 Delete_File (Tname.all);
596 end if;
597
598 else
599 if Driver_Name = No_Name then
600 Fail (Gcc_Name.all & " execution error");
601 else
602 Fail (Get_Name_String (Driver_Name) & " execution error");
603 end if;
604 end if;
605 end Gcc;
606
607 -------------------
608 -- Lib_Directory --
609 -------------------
610
611 function Lib_Directory return String is
612 Libgnat : constant String := Tgt.Libgnat;
613
614 begin
615 -- If procedure Specify_Adalib_Dir has been called, used the specified
616 -- value.
617
618 if Adalib_Path /= null then
619 return Adalib_Path.all;
620 end if;
621
622 Name_Len := Libgnat'Length;
623 Name_Buffer (1 .. Name_Len) := Libgnat;
624 Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
625
626 -- Remove libgnat.a
627
628 return Name_Buffer (1 .. Name_Len - Libgnat'Length);
629 end Lib_Directory;
630
631 ------------------------
632 -- Specify_Adalib_Dir --
633 ------------------------
634
635 procedure Specify_Adalib_Dir (Path : String) is
636 begin
637 if Path'Length = 0 then
638 Adalib_Path := null;
639 else
640 Adalib_Path := new String'(Path);
641 end if;
642 end Specify_Adalib_Dir;
643
644 end MLib.Utl;