diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/mlib-utl.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/mlib-utl.adb | 638 |
1 files changed, 638 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/mlib-utl.adb b/gcc-4.8.3/gcc/ada/mlib-utl.adb new file mode 100644 index 000000000..756add1d4 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/mlib-utl.adb @@ -0,0 +1,638 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . U T L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2013, 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 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 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. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with MLib.Fil; use MLib.Fil; +with MLib.Tgt; use MLib.Tgt; +with Opt; +with Osint; +with Output; use Output; + +with Interfaces.C.Strings; use Interfaces.C.Strings; + +package body MLib.Utl is + + 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 + + Ar_Name : String_Access; + -- The name of the archive builder for the platform, set when procedure Ar + -- is called for the first time. + + Ar_Exec : String_Access; + -- The full path name of the archive builder + + Ar_Options : String_List_Access; + -- The minimum options used when invoking the archive builder + + 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. + + Opt_Length : Natural := 0; + -- The max number of options for the Archive_Builder + + 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 + Full_Output_File : constant String := + 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 + + -- 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 + if Ar_Exec = null then + Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake"); + Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); + + 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; + + if Ar_Exec = null then + Fail (Ar_Name.all & " not found in path"); + + elsif Opt.Verbose_Mode then + Write_Str ("found "); + Write_Line (Ar_Exec.all); + end if; + + 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; + + 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; + + 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.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.all); + Write_Char (' '); + Write_Line (Arguments (Ar_Options'Length + 1).all); + end if; + + Spawn + (Ranlib_Exec.all, + Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)), + Success); + + if not Success then + Fail (Ranlib_Name.all & " execution error."); + end if; + end if; + end Ar; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Filename : String) is + File : constant String := Filename & ASCII.NUL; + Success : Boolean; + + begin + Delete_File (File'Address, Success); + + if Opt.Verbose_Mode then + if Success then + Write_Str ("deleted "); + + else + Write_Str ("could not delete "); + end if; + + Write_Line (Filename); + end if; + end Delete_File; + + --------- + -- Gcc -- + --------- + + procedure Gcc + (Output_File : String; + Objects : Argument_List; + Options : Argument_List; + Options_2 : Argument_List; + Driver_Name : Name_Id := No_Name) + is + 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. + + Object_File_Option : constant String := Value (Object_File_Option_Ptr); + -- The linker option which specifies the response file as a string + + Using_GNU_response_file : constant Boolean := + Object_File_Option'Length > 0 + and then + Object_File_Option + (Object_File_Option'Last) = '@'; + -- Whether a GNU response file 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; + + procedure Write_RF (S : String); + -- 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 (S : String) is + Success : Boolean := True; + Back_Slash : constant Character := '\'; + + begin + -- If a GNU response file is used, space and backslash need to be + -- escaped because they are interpreted as a string separator and + -- an escape character respectively by the underlying mechanism. + -- On the other hand, quote and double-quote are not escaped since + -- they are interpreted as string delimiters on both sides. + + if Using_GNU_response_file then + for J in S'Range loop + if S (J) = ' ' or else S (J) = '\' then + if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then + Success := False; + end if; + end if; + + if Write (Tname_FD, S (J)'Address, 1) /= 1 then + Success := False; + end if; + end loop; + + else + if Write (Tname_FD, S'Address, S'Length) /= S'Length then + Success := False; + end if; + end if; + + if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then + Success := False; + end if; + + if not Success then + Fail ("cannot generate response file to link library: disk full"); + end if; + end Write_RF; + + -- Start of processing for Gcc + + begin + 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; + + for J in Options'Range loop + Link_Bytes := Link_Bytes + Options (J)'Length + 1; + end loop; + + if not Opt.Quiet_Output then + if Opt.Verbose_Mode then + Write_Str (Driver.all); + + elsif Driver_Name /= No_Name then + Write_Str (Get_Name_String (Driver_Name)); + + else + Write_Str (Gcc_Name.all); + end if; + + for J in 1 .. A loop + if Opt.Verbose_Mode or else J < 4 then + Write_Char (' '); + Write_Str (Arguments (J).all); + + else + Write_Str (" ..."); + exit; + end if; + end loop; + + -- Do not display all the object files if not in verbose mode, only + -- the first one. + + 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; + + elsif Position = Second then + Write_Str (" ..."); + Position := Last; + exit; + end if; + end loop; + + for J in Options_2'Range loop + if not Opt.Verbose_Mode then + if Position = Second then + Write_Str (" ..."); + end if; + + exit; + end if; + + Write_Char (' '); + Write_Str (Options_2 (J).all); + end loop; + + Write_Eol; + end if; + + for J in Objects'Range loop + Link_Bytes := Link_Bytes + Objects (J)'Length + 1; + end loop; + + for J in Options_2'Range loop + Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1; + end loop; + + 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. + + Create_Temp_File (Tname_FD, Tname); + + for J in Objects'Range loop + Write_RF (Objects (J).all); + end loop; + + 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'(Object_File_Option & Tname.all); + + else + A := A + Objects'Length; + Arguments (A - Objects'Length + 1 .. A) := Objects; + end if; + + A := A + Options_2'Length; + Arguments (A - Options_2'Length + 1 .. A) := Options_2; + + Spawn (Driver.all, Arguments (1 .. A), Success); + + if Success then + -- Delete the temporary file used in conjunction with linking + -- if one was created. + + if Tname_FD /= Invalid_FD then + Delete_File (Tname.all); + end if; + + else + 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 := 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 (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; |