Subversion Repositories openrisc_me

------------------------------------------------------------------------------
--                                                                          --
--                         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;