-- --
-- B o d y --
-- --
--- $Revision: 1.3 $
--- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2008, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with MLib.Fil;
-with MLib.Tgt;
-with Namet; use Namet;
+with MLib.Fil; use MLib.Fil;
+with MLib.Tgt; use MLib.Tgt;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Osint;
+with Output; use Output;
+
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+
+with System;
package body MLib.Utl is
- use GNAT;
+ Adalib_Path : String_Access := null;
+ -- Path of the GNAT adalib directory, specified in procedure
+ -- Specify_Adalib_Dir. Used in function Lib_Directory.
+
+ Gcc_Name : String_Access;
+ -- Default value of the "gcc" executable used in procedure Gcc
+
+ Gcc_Exec : String_Access;
+ -- The full path name of the "gcc" executable
- package Files renames MLib.Fil;
- package Target renames MLib.Tgt;
+ Ar_Name : String_Access;
+ -- The name of the archive builder for the platform, set when procedure Ar
+ -- is called for the first time.
- Initialized : Boolean := False;
+ Ar_Exec : String_Access;
+ -- The full path name of the archive builder
- Gcc_Name : constant String := "gcc";
- Gcc_Exec : OS_Lib.String_Access;
+ Ar_Options : String_List_Access;
+ -- The minimum options used when invoking the archive builder
- Ar_Name : constant String := "ar";
- Ar_Exec : OS_Lib.String_Access;
+ Ar_Append_Options : String_List_Access;
+ -- The options to be used when invoking the archive builder to add chunks
+ -- of object files, when building the archive in chunks.
- Ranlib_Name : constant String := "ranlib";
- Ranlib_Exec : OS_Lib.String_Access;
+ Opt_Length : Natural := 0;
+ -- The max number of options for the Archive_Builder
- procedure Initialize;
- -- Look for the tools in the path and record the full path for each one
+ Initial_Size : Natural := 0;
+ -- The minimum number of bytes for the invocation of the Archive Builder
+ -- (without name of the archive or object files).
+
+ Ranlib_Name : String_Access;
+ -- The name of the archive indexer for the platform, if there is one
+
+ Ranlib_Exec : String_Access := null;
+ -- The full path name of the archive indexer
+
+ Ranlib_Options : String_List_Access := null;
+ -- The options to be used when invoking the archive indexer, if any
--------
-- Ar --
--------
procedure Ar (Output_File : String; Objects : Argument_List) is
- Create_Add_Opt : OS_Lib.String_Access := new String' ("cr");
-
Full_Output_File : constant String :=
- Files.Ext_To (Output_File, Target.Archive_Ext);
+ Ext_To (Output_File, Archive_Ext);
+
+ Arguments : Argument_List_Access;
+ Last_Arg : Natural := 0;
+ Success : Boolean;
+ Line_Length : Natural := 0;
+
+ Maximum_Size : Integer;
+ pragma Import (C, Maximum_Size, "__gnat_link_max");
+ -- Maximum number of bytes to put in an invocation of the
+ -- Archive_Builder.
+
+ Size : Integer;
+ -- The number of bytes for the invocation of the archive builder
+
+ Current_Object : Natural;
+
+ procedure Display;
+ -- Display an invocation of the Archive Builder
+
+ -------------
+ -- Display --
+ -------------
+
+ procedure Display is
+ begin
+ if not Opt.Quiet_Output then
+ Write_Str (Ar_Name.all);
+ Line_Length := Ar_Name'Length;
+
+ for J in 1 .. Last_Arg loop
- Arguments : OS_Lib.Argument_List (1 .. 2 + Objects'Length);
- Success : Boolean;
+ -- Make sure the Output buffer does not overflow
+
+ if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
+ Write_Eol;
+ Line_Length := 0;
+ end if;
+
+ Write_Char (' ');
+
+ -- Only output the first object files when not in verbose mode
+
+ if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
+ Write_Str ("...");
+ exit;
+ end if;
+
+ Write_Str (Arguments (J).all);
+ Line_Length := Line_Length + 1 + Arguments (J)'Length;
+ end loop;
+
+ Write_Eol;
+ end if;
+
+ end Display;
begin
- Initialize;
+ if Ar_Exec = null then
+ Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake");
+ Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
- Arguments (1) := Create_Add_Opt; -- "ar cr ..."
- Arguments (2) := new String'(Full_Output_File);
- Arguments (3 .. Arguments'Last) := Objects;
+ if Ar_Exec = null then
+ Free (Ar_Name);
+ Ar_Name := new String'(Archive_Builder);
+ Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
+ end if;
- Delete_File (Full_Output_File);
+ if Ar_Exec = null then
+ Fail (Ar_Name.all & " not found in path");
- if not Opt.Quiet_Output then
- Write_Str (Ar_Name);
+ elsif Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Ar_Exec.all);
+ end if;
- for J in Arguments'Range loop
- Write_Char (' ');
- Write_Str (Arguments (J).all);
+ Ar_Options := Archive_Builder_Options;
+
+ Initial_Size := 0;
+ for J in Ar_Options'Range loop
+ Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
end loop;
- Write_Eol;
+ Ar_Append_Options := Archive_Builder_Append_Options;
+
+ Opt_Length := Ar_Options'Length;
+
+ if Ar_Append_Options /= null then
+ Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
+
+ Size := 0;
+ for J in Ar_Append_Options'Range loop
+ Size := Size + Ar_Append_Options (J)'Length + 1;
+ end loop;
+
+ Initial_Size := Integer'Max (Initial_Size, Size);
+ end if;
+
+ -- ranlib
+
+ Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake");
+
+ if Ranlib_Name'Length > 0 then
+ Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
+
+ if Ranlib_Exec = null then
+ Free (Ranlib_Name);
+ Ranlib_Name := new String'(Archive_Indexer);
+ Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
+ end if;
+
+ if Ranlib_Exec /= null and then Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Ranlib_Exec.all);
+ end if;
+ end if;
+
+ Ranlib_Options := Archive_Indexer_Options;
end if;
- OS_Lib.Spawn (Ar_Exec.all, Arguments, Success);
+ Arguments :=
+ new String_List (1 .. 1 + Opt_Length + Objects'Length);
+ Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..."
+ Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
+
+ Delete_File (Full_Output_File);
+
+ Size := Initial_Size + Full_Output_File'Length + 1;
+
+ -- Check the full size of a call of the archive builder with all the
+ -- object files.
+
+ for J in Objects'Range loop
+ Size := Size + Objects (J)'Length + 1;
+ end loop;
+
+ -- If the size is not too large or if it is not possible to build the
+ -- archive in chunks, build the archive in a single invocation.
+
+ if Size <= Maximum_Size or else Ar_Append_Options = null then
+ Last_Arg := Ar_Options'Length + 1 + Objects'Length;
+ Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
+
+ Display;
+
+ Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
+
+ else
+ -- Build the archive in several invocation, making sure to not
+ -- go over the maximum size for each invocation.
+
+ Last_Arg := Ar_Options'Length + 1;
+ Current_Object := Objects'First;
+ Size := Initial_Size + Full_Output_File'Length + 1;
+
+ -- First invocation
+
+ while Current_Object <= Objects'Last loop
+ Size := Size + Objects (Current_Object)'Length + 1;
+ exit when Size > Maximum_Size;
+ Last_Arg := Last_Arg + 1;
+ Arguments (Last_Arg) := Objects (Current_Object);
+ Current_Object := Current_Object + 1;
+ end loop;
+
+ Display;
+
+ Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
+
+ Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
+ Arguments
+ (Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
+
+ -- Appending invocation(s)
+
+ Big_Loop : while Success and then Current_Object <= Objects'Last loop
+ Last_Arg := Ar_Append_Options'Length + 1;
+ Size := Initial_Size + Full_Output_File'Length + 1;
+
+ Inner_Loop : while Current_Object <= Objects'Last loop
+ Size := Size + Objects (Current_Object)'Length + 1;
+ exit Inner_Loop when Size > Maximum_Size;
+ Last_Arg := Last_Arg + 1;
+ Arguments (Last_Arg) := Objects (Current_Object);
+ Current_Object := Current_Object + 1;
+ end loop Inner_Loop;
+
+ Display;
+
+ Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
+ end loop Big_Loop;
+ end if;
if not Success then
- Fail (Ar_Name, " execution error.");
+ Fail (Ar_Name.all & " execution error.");
end if;
-- If we have found ranlib, run it over the library
if Ranlib_Exec /= null then
if not Opt.Quiet_Output then
- Write_Str (Ranlib_Name);
+ Write_Str (Ranlib_Name.all);
Write_Char (' ');
- Write_Line (Arguments (2).all);
+ Write_Line (Arguments (Ar_Options'Length + 1).all);
end if;
- OS_Lib.Spawn (Ranlib_Exec.all, (1 => Arguments (2)), Success);
+ Spawn
+ (Ranlib_Exec.all,
+ Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
+ Success);
if not Success then
- Fail (Ranlib_Name, " execution error.");
+ Fail (Ranlib_Name.all & " execution error.");
end if;
end if;
end Ar;
-- Delete_File --
-----------------
- procedure Delete_File (Filename : in String) is
- File : constant String := Filename & ASCII.Nul;
+ procedure Delete_File (Filename : String) is
+ File : constant String := Filename & ASCII.NUL;
Success : Boolean;
begin
- OS_Lib.Delete_File (File'Address, Success);
+ Delete_File (File'Address, Success);
if Opt.Verbose_Mode then
if Success then
(Output_File : String;
Objects : Argument_List;
Options : Argument_List;
- Base_File : String := "")
+ Options_2 : Argument_List;
+ Driver_Name : Name_Id := No_Name)
is
- Arguments : OS_Lib.Argument_List
- (1 .. 7 + Objects'Length + Options'Length);
+ Link_Bytes : Integer := 0;
+ -- Projected number of bytes for the linker command line
+
+ Link_Max : Integer;
+ pragma Import (C, Link_Max, "__gnat_link_max");
+ -- Maximum number of bytes on the command line supported by the OS
+ -- linker. Passed this limit the response file mechanism must be used
+ -- if supported.
+
+ Object_List_File_Supported : Boolean;
+ for Object_List_File_Supported'Size use Character'Size;
+ pragma Import
+ (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
+ -- Predicate indicating whether the linker has an option whereby the
+ -- names of object files can be passed to the linker in a file.
+
+ Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
+ -- Pointer to a string representing the linker option which specifies
+ -- the response file.
+
+ Using_GNU_Linker : Boolean;
+ for Using_GNU_Linker'Size use Character'Size;
+ pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker");
+ -- Predicate indicating whether this target uses the GNU linker. In
+ -- this case we must output a GNU linker compatible response file.
+
+ Opening : aliased constant String := """";
+ Closing : aliased constant String := '"' & ASCII.LF;
+ -- Needed to quote object paths in object list files when GNU linker
+ -- is used.
+
+ Tname : String_Access;
+ Tname_FD : File_Descriptor := Invalid_FD;
+ -- Temporary file used by linker to pass list of object files on
+ -- certain systems with limitations on size of arguments.
+
+ Closing_Status : Boolean;
+ -- For call to Close
+
+ Arguments :
+ Argument_List
+ (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
+
+ A : Natural := 0;
+ Success : Boolean;
+
+ Out_Opt : constant String_Access := new String'("-o");
+ Out_V : constant String_Access := new String'(Output_File);
+ Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
+ Lib_Opt : constant String_Access := new String'(Dynamic_Option);
+
+ Driver : String_Access;
+
+ type Object_Position is (First, Second, Last);
+
+ Position : Object_Position;
- A : Natural := 0;
- Success : Boolean;
- Out_Opt : OS_Lib.String_Access := new String' ("-o");
- Out_V : OS_Lib.String_Access := new String' (Output_File);
- Lib_Dir : OS_Lib.String_Access := new String' ("-L" & Lib_Directory);
- Lib_Opt : OS_Lib.String_Access := new String' (Target.Dynamic_Option);
+ procedure Write_RF (A : System.Address; N : Integer);
+ -- Write a string to the response file and check if it was successful.
+ -- Fail the program if it was not successful (disk full).
+
+ --------------
+ -- Write_RF --
+ --------------
+
+ procedure Write_RF (A : System.Address; N : Integer) is
+ Status : Integer;
+ begin
+ Status := Write (Tname_FD, A, N);
+
+ if Status /= N then
+ Fail ("cannot generate response file to link library: disk full");
+ end if;
+ end Write_RF;
begin
- Initialize;
+ if Driver_Name = No_Name then
+ if Gcc_Exec = null then
+ if Gcc_Name = null then
+ Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
+ end if;
+
+ Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
+
+ if Gcc_Exec = null then
+ Fail (Gcc_Name.all & " not found in path");
+ end if;
+ end if;
+
+ Driver := Gcc_Exec;
+
+ else
+ Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
+
+ if Driver = null then
+ Fail (Get_Name_String (Driver_Name) & " not found in path");
+ end if;
+ end if;
+
+ Link_Bytes := 0;
if Lib_Opt'Length /= 0 then
A := A + 1;
Arguments (A) := Lib_Opt;
+ Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
end if;
A := A + 1;
Arguments (A) := Out_Opt;
+ Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
+
A := A + 1;
Arguments (A) := Out_V;
+ Link_Bytes := Link_Bytes + Out_V'Length + 1;
A := A + 1;
Arguments (A) := Lib_Dir;
+ Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
A := A + Options'Length;
Arguments (A - Options'Length + 1 .. A) := Options;
- A := A + Objects'Length;
- Arguments (A - Objects'Length + 1 .. A) := Objects;
+ for J in Options'Range loop
+ Link_Bytes := Link_Bytes + Options (J)'Length + 1;
+ end loop;
if not Opt.Quiet_Output then
- Write_Str (Gcc_Exec.all);
+ Write_Str (Driver.all);
for J in 1 .. A loop
Write_Char (' ');
Write_Str (Arguments (J).all);
end loop;
- Write_Eol;
- end if;
+ -- Do not display all the object files if not in verbose mode, only
+ -- the first one.
- OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
+ Position := First;
+ for J in Objects'Range loop
+ if Opt.Verbose_Mode or else Position = First then
+ Write_Char (' ');
+ Write_Str (Objects (J).all);
+ Position := Second;
- if not Success then
- Fail (Gcc_Name, " execution error");
+ elsif Position = Second then
+ Write_Str (" ...");
+ Position := Last;
+ end if;
+ end loop;
+
+ for J in Options_2'Range loop
+ Write_Char (' ');
+ Write_Str (Options_2 (J).all);
+ end loop;
+
+ Write_Eol;
end if;
- end Gcc;
- ----------------
- -- Initialize --
- ----------------
+ for J in Objects'Range loop
+ Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
+ end loop;
- procedure Initialize is
- use type OS_Lib.String_Access;
+ for J in Options_2'Range loop
+ Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
+ end loop;
- begin
- if not Initialized then
- Initialized := True;
+ if Object_List_File_Supported and then Link_Bytes > Link_Max then
+ -- Create a temporary file containing the object files, one object
+ -- file per line for maximal compatibility with linkers supporting
+ -- this option.
- -- gcc
+ Create_Temp_File (Tname_FD, Tname);
- Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
+ -- If target is using the GNU linker we must add a special header
+ -- and footer in the response file.
- if Gcc_Exec = null then
+ -- The syntax is : INPUT (object1.o object2.o ... )
- Fail (Gcc_Name, " not found in path");
+ -- Because the GNU linker does not like name with characters such
+ -- as '!', we must put the object paths between double quotes.
- elsif Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Gcc_Exec.all);
+ if Using_GNU_Linker then
+ declare
+ GNU_Header : aliased constant String := "INPUT (";
+
+ begin
+ Write_RF (GNU_Header'Address, GNU_Header'Length);
+ end;
end if;
- -- ar
+ for J in Objects'Range loop
+ -- Opening quote for GNU linker
- Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name);
+ if Using_GNU_Linker then
+ Write_RF (Opening'Address, 1);
+ end if;
- if Ar_Exec = null then
+ Write_RF
+ (Objects (J).all'Address, Objects (J).all'Length);
- Fail (Ar_Name, " not found in path");
+ -- Closing quote for GNU linker
- elsif Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Ar_Exec.all);
- end if;
+ if Using_GNU_Linker then
+ Write_RF (Closing'Address, 2);
- -- ranlib
+ else
+ Write_RF (ASCII.LF'Address, 1);
+ end if;
+ end loop;
+
+ -- Handle GNU linker response file footer
- Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name);
+ if Using_GNU_Linker then
+ declare
+ GNU_Footer : aliased constant String := ")";
- if Ranlib_Exec /= null and then Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Ranlib_Exec.all);
+ begin
+ Write_RF (GNU_Footer'Address, GNU_Footer'Length);
+ end;
end if;
+ Close (Tname_FD, Closing_Status);
+
+ if not Closing_Status then
+ Fail ("cannot generate response file to link library: disk full");
+ end if;
+
+ A := A + 1;
+ Arguments (A) :=
+ new String'(Value (Object_File_Option_Ptr) & Tname.all);
+
+ else
+ A := A + Objects'Length;
+ Arguments (A - Objects'Length + 1 .. A) := Objects;
end if;
- end Initialize;
+ A := A + Options_2'Length;
+ Arguments (A - Options_2'Length + 1 .. A) := Options_2;
+
+ Spawn (Driver.all, Arguments (1 .. A), Success);
+
+ if Tname /= null then
+ Delete_File (Tname.all, Closing_Status);
+
+ if not Closing_Status then
+ Write_Str ("warning: could not delete response file """);
+ Write_Str (Tname.all);
+ Write_Line (""" to link library");
+ end if;
+ end if;
+
+ if not Success then
+ if Driver_Name = No_Name then
+ Fail (Gcc_Name.all & " execution error");
+ else
+ Fail (Get_Name_String (Driver_Name) & " execution error");
+ end if;
+ end if;
+ end Gcc;
-------------------
-- Lib_Directory --
-------------------
function Lib_Directory return String is
- Libgnat : constant String := Target.Libgnat;
+ Libgnat : constant String := Tgt.Libgnat;
begin
+ -- If procedure Specify_Adalib_Dir has been called, used the specified
+ -- value.
+
+ if Adalib_Path /= null then
+ return Adalib_Path.all;
+ end if;
+
Name_Len := Libgnat'Length;
Name_Buffer (1 .. Name_Len) := Libgnat;
- Get_Name_String (Find_File (Name_Enter, Library));
+ Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
-- Remove libgnat.a
return Name_Buffer (1 .. Name_Len - Libgnat'Length);
end Lib_Directory;
+ ------------------------
+ -- Specify_Adalib_Dir --
+ ------------------------
+
+ procedure Specify_Adalib_Dir (Path : String) is
+ begin
+ if Path'Length = 0 then
+ Adalib_Path := null;
+ else
+ Adalib_Path := new String'(Path);
+ end if;
+ end Specify_Adalib_Dir;
+
end MLib.Utl;
OSDN Git Service
