aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/mlib-utl.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/mlib-utl.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/mlib-utl.adb633
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;