diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/mlib-utl.adb')
-rw-r--r-- | gcc-4.4.0/gcc/ada/mlib-utl.adb | 633 |
1 files changed, 0 insertions, 633 deletions
diff --git a/gcc-4.4.0/gcc/ada/mlib-utl.adb b/gcc-4.4.0/gcc/ada/mlib-utl.adb deleted file mode 100644 index 76e7db533..000000000 --- a/gcc-4.4.0/gcc/ada/mlib-utl.adb +++ /dev/null @@ -1,633 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . U T L -- --- -- --- B o d y -- --- -- --- 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 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; - -with System; - -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. - - 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; - - 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 - 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 - Write_Str (Driver.all); - - for J in 1 .. A loop - Write_Char (' '); - Write_Str (Arguments (J).all); - 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; - 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; - - 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); - - -- If target is using the GNU linker we must add a special header - -- and footer in the response file. - - -- The syntax is : INPUT (object1.o object2.o ... ) - - -- Because the GNU linker does not like name with characters such - -- as '!', we must put the object paths between double quotes. - - if Using_GNU_Linker then - declare - GNU_Header : aliased constant String := "INPUT ("; - - begin - Write_RF (GNU_Header'Address, GNU_Header'Length); - end; - end if; - - for J in Objects'Range loop - -- Opening quote for GNU linker - - if Using_GNU_Linker then - Write_RF (Opening'Address, 1); - end if; - - Write_RF - (Objects (J).all'Address, Objects (J).all'Length); - - -- Closing quote for GNU linker - - if Using_GNU_Linker then - Write_RF (Closing'Address, 2); - - else - Write_RF (ASCII.LF'Address, 1); - end if; - end loop; - - -- Handle GNU linker response file footer - - if Using_GNU_Linker then - declare - GNU_Footer : aliased constant String := ")"; - - 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; - - 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 := 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; |