libgnatprj4.6-dev 4.6.3-1ubuntu3 / usr / share / ada / adainclude / gnatprj / mlib-utl.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             M L I B . U T L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2002-2010, 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-4.6", "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);

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