Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                            M L I B . P R J                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--                     Copyright (C) 2001-2005, 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 2,  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 COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with ALI;      use ALI;

with Gnatvsn;  use Gnatvsn;

with Hostparm;

with MLib.Fil; use MLib.Fil;

with MLib.Tgt; use MLib.Tgt;

with MLib.Utl; use MLib.Utl;

with Namet;    use Namet;

with Opt;

with Output;   use Output;

with Prj.Com;  use Prj.Com;

with Prj.Env;  use Prj.Env;

with Prj.Util; use Prj.Util;

with Sinput.P;

with Snames;   use Snames;

with Switch;   use Switch;

with Table;

with Ada.Characters.Handling;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;

with GNAT.HTable;

with Interfaces.C_Streams;      use Interfaces.C_Streams;

with System;                    use System;

with System.Case_Util;          use System.Case_Util;

package body MLib.Prj is

   Prj_Add_Obj_Files : Types.Int;

   pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");

   Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;

   --  Indicates if object files in pragmas Linker_Options (found in the

   --  binder generated file) should be taken when linking aq stand-alone

   --  library.

   --  False for Windows, True for other platforms.

   ALI_Suffix : constant String := ".ali";

   B_Start    : String := "b~";

   S_Osinte_Ads : Name_Id := No_Name;

   --  Name_Id for "s-osinte.ads"

   S_Dec_Ads : Name_Id := No_Name;

   --  Name_Id for "dec.ads"

   G_Trasym_Ads : Name_Id := No_Name;

   --  Name_Id for "g-trasym.ads"

   No_Argument_List : aliased String_List := (1 .. 0 => null);

   No_Argument      : constant String_List_Access := No_Argument_List'Access;

   Arguments : String_List_Access := No_Argument;

   --  Used to accumulate arguments for the invocation of gnatbind and of

   --  the compiler. Also used to collect the interface ALI when copying

   --  the ALI files to the library directory.

   Argument_Number : Natural := 0;

   --  Index of the last argument in Arguments

   Initial_Argument_Max : constant := 10;

   No_Main_String : aliased String := "-n";

   No_Main : constant String_Access := No_Main_String'Access;

   Output_Switch_String : aliased String := "-o";

   Output_Switch : constant String_Access := Output_Switch_String'Access;

   Compile_Switch_String : aliased String := "-c";

   Compile_Switch : constant String_Access := Compile_Switch_String'Access;

   Auto_Initialize : constant String := "-a";

   --  List of objects to put inside the library

   Object_Files : Argument_List_Access;

   package Objects is new Table.Table

     (Table_Name           => "Mlib.Prj.Objects",

      Table_Component_Type => String_Access,

      Table_Index_Type     => Natural,

      Table_Low_Bound      => 1,

      Table_Initial        => 50,

      Table_Increment      => 100);

   package Objects_Htable is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Boolean,

      No_Element => False,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  List of non-Ada object files

   Foreign_Objects : Argument_List_Access;

   package Foreigns is new Table.Table

     (Table_Name           => "Mlib.Prj.Foreigns",

      Table_Component_Type => String_Access,

      Table_Index_Type     => Natural,

      Table_Low_Bound      => 1,

      Table_Initial        => 20,

      Table_Increment      => 100);

   --  List of ALI files

   Ali_Files : Argument_List_Access;

   package ALIs is new Table.Table

     (Table_Name           => "Mlib.Prj.Alis",

      Table_Component_Type => String_Access,

      Table_Index_Type     => Natural,

      Table_Low_Bound      => 1,

      Table_Initial        => 50,

      Table_Increment      => 100);

   --  List of options set in the command line

   Options : Argument_List_Access;

   package Opts is new Table.Table

     (Table_Name           => "Mlib.Prj.Opts",

      Table_Component_Type => String_Access,

      Table_Index_Type     => Natural,

      Table_Low_Bound      => 1,

      Table_Initial        => 5,

      Table_Increment      => 100);

   --  All the ALI file in the library

   package Library_ALIs is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Boolean,

      No_Element => False,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  The ALI files in the interface sets

   package Interface_ALIs is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Boolean,

      No_Element => False,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  The ALI files that have been processed to check if the corresponding

   --  library unit is in the interface set.

   package Processed_ALIs is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Boolean,

      No_Element => False,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  The projects imported directly or indirectly

   package Processed_Projects is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Boolean,

      No_Element => False,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  The library projects imported directly or indirectly

   package Library_Projs is new Table.Table (

     Table_Component_Type => Project_Id,

     Table_Index_Type     => Integer,

     Table_Low_Bound      => 1,

     Table_Initial        => 10,

     Table_Increment      => 10,

     Table_Name           => "Make.Library_Projs");

   type Build_Mode_State is (None, Static, Dynamic, Relocatable);

   procedure Add_Argument (S : String);

   --  Add one argument to Arguments array, if array is full, double its size

   function ALI_File_Name (Source : String) return String;

   --  Return the ALI file name corresponding to a source

   procedure Check (Filename : String);

   --  Check if filename is a regular file. Fail if it is not

   procedure Check_Context;

   --  Check each object files in table Object_Files

   --  Fail if any of them is not a regular file

   procedure Copy_Interface_Sources

     (For_Project : Project_Id;

      In_Tree     : Project_Tree_Ref;

      Interfaces  : Argument_List;

      To_Dir      : Name_Id);

   --  Copy the interface sources of a SAL to directory To_Dir

   procedure Display (Executable : String);

   --  Display invocation of gnatbind and of the compiler with the arguments

   --  in Arguments, except when Quiet_Output is True.

   procedure Process_Binder_File (Name : String);

   --  For Stand-Alone libraries, get the Linker Options in the binder

   --  generated file.

   procedure Reset_Tables;

   --  Make sure that all the above tables are empty

   --  (Objects, Foreign_Objects, Ali_Files, Options).

   function SALs_Use_Constructors return Boolean;

   --  Indicate if Stand-Alone Libraries are automatically initialized using

   --  the constructor mechanism.

   function Ultimate_Extension_Of

     (Project : Project_Id;

      In_Tree : Project_Tree_Ref) return Project_Id;

   --  Returns the Project_Id of project Project. Returns No_Project

   --  if Project is No_Project.

   ------------------

   -- Add_Argument --

   ------------------

   procedure Add_Argument (S : String) is

   begin

      if Argument_Number = Arguments'Last then

         declare

            New_Args : constant String_List_Access :=

              new String_List (1 .. 2 * Arguments'Last);

         begin

            --  Copy the String_Accesses and set them to null in Arguments

            --  so that they will not be deallocated by the call to

            --  Free (Arguments).

            New_Args (Arguments'Range) := Arguments.all;

            Arguments.all := (others => null);

            Free (Arguments);

            Arguments := New_Args;

         end;

      end if;

      Argument_Number := Argument_Number + 1;

      Arguments (Argument_Number) := new String'(S);

   end Add_Argument;

   -------------------

   -- ALI_File_Name --

   -------------------

   function ALI_File_Name (Source : String) return String is

   begin

      --  If the source name has an extension, then replace it with

      --  the ALI suffix.

      for Index in reverse Source'First + 1 .. Source'Last loop

         if Source (Index) = '.' then

            return Source (Source'First .. Index - 1) & ALI_Suffix;

         end if;

      end loop;

      --  If there is no dot, or if it is the first character, just add the

      --  ALI suffix.

      return Source & ALI_Suffix;

   end ALI_File_Name;

   -------------------

   -- Build_Library --

   -------------------

   procedure Build_Library

     (For_Project   : Project_Id;

      In_Tree       : Project_Tree_Ref;

      Gnatbind      : String;

      Gnatbind_Path : String_Access;

      Gcc           : String;

      Gcc_Path      : String_Access;

      Bind          : Boolean := True;

      Link          : Boolean := True)

   is

      Warning_For_Library : Boolean := False;

      --  Set to True for the first warning about a unit missing from the

      --  interface set.

      Libgnarl_Needed   : Boolean := False;

      --  Set to True if library needs to be linked with libgnarl

      Libdecgnat_Needed : Boolean := False;

      --  On OpenVMS, set to True if library needs to be linked with libdecgnat

      Gtrasymobj_Needed : Boolean := False;

      --  On OpenVMS, set to True if library needs to be linked with

      --  g-trasym.obj.

      Data : Project_Data := In_Tree.Projects.Table (For_Project);

      Object_Directory_Path : constant String :=

                          Get_Name_String (Data.Object_Directory);

      Standalone   : constant Boolean := Data.Standalone_Library;

      Project_Name : constant String := Get_Name_String (Data.Name);

      Current_Dir  : constant String := Get_Current_Dir;

      Lib_Filename : String_Access;

      Lib_Dirpath  : String_Access;

      Lib_Version  : String_Access := new String'("");

      The_Build_Mode : Build_Mode_State := None;

      Success : Boolean := False;

      Library_Options : Variable_Value := Nil_Variable_Value;

      Library_GCC     : Variable_Value := Nil_Variable_Value;

      Driver_Name : Name_Id := No_Name;

      In_Main_Object_Directory : Boolean := True;

      Rpath : String_Access := null;

      --  Allocated only if Path Option is supported

      Rpath_Last : Natural := 0;

      --  Index of last valid character of Rpath

      Initial_Rpath_Length : constant := 200;

      --  Initial size of Rpath, when first allocated

      Path_Option : String_Access := Linker_Library_Path_Option;

      --  If null, Path Option is not supported.

      --  Not a constant so that it can be deallocated.

      First_ALI : Name_Id := No_Name;

      --  Store the ALI file name of a source of the library (the first found)

      procedure Add_ALI_For (Source : Name_Id);

      --  Add the name of the ALI file corresponding to Source to the

      --  Arguments.

      procedure Add_Rpath (Path : String);

      --  Add a path name to Rpath

      function Check_Project (P : Project_Id) return Boolean;

      --  Returns True if P is For_Project or a project extended by For_Project

      procedure Check_Libs (ALI_File : String);

      --  Set Libgnarl_Needed if the ALI_File indicates that there is a need

      --  to link with -lgnarl (this is the case when there is a dependency

      --  on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file

      --  indicates that there is a need to link with -ldecgnat (this is the

      --  case when there is a dependency on dec.ads), and set

      --  Gtrasymobj_Needed if there is a dependency on g-trasym.ads.

      procedure Process (The_ALI : File_Name_Type);

      --  Check if the closure of a library unit which is or should be in the

      --  interface set is also in the interface set. Issue a warning for each

      --  missing library unit.

      procedure Process_Imported_Libraries;

      --  Add the -L and -l switches for the imported Library Project Files,

      --  and, if Path Option is supported, the library directory path names

      --  to Rpath.

      -----------------

      -- Add_ALI_For --

      -----------------

      procedure Add_ALI_For (Source : Name_Id) is

         ALI    : constant String := ALI_File_Name (Get_Name_String (Source));

         ALI_Id : Name_Id;

      begin

         if Bind then

            Add_Argument (ALI);

         end if;

         Name_Len := 0;

         Add_Str_To_Name_Buffer (S => ALI);

         ALI_Id := Name_Find;

         --  Add the ALI file name to the library ALIs

         if Bind then

            Library_ALIs.Set (ALI_Id, True);

         end if;

         --  Set First_ALI, if not already done

         if First_ALI = No_Name then

            First_ALI := ALI_Id;

         end if;

      end Add_ALI_For;

      ---------------

      -- Add_Rpath --

      ---------------

      procedure Add_Rpath (Path : String) is

         procedure Double;

         --  Double Rpath size

         ------------

         -- Double --

         ------------

         procedure Double is

            New_Rpath : constant String_Access :=

                          new String (1 .. 2 * Rpath'Length);

         begin

            New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);

            Free (Rpath);

            Rpath := New_Rpath;

         end Double;

      --  Start of processing for Add_Rpath

      begin

         --  If firt path, allocate initial Rpath

         if Rpath = null then

            Rpath := new String (1 .. Initial_Rpath_Length);

            Rpath_Last := 0;

         else

            --  Otherwise, add a path separator between two path names

            if Rpath_Last = Rpath'Last then

               Double;

            end if;

            Rpath_Last := Rpath_Last + 1;

            Rpath (Rpath_Last) := Path_Separator;

         end if;

         --  Increase Rpath size until it is large enough

         while Rpath_Last + Path'Length > Rpath'Last loop

            Double;

         end loop;

         --  Add the path name

         Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;

         Rpath_Last := Rpath_Last + Path'Length;

      end Add_Rpath;

      -------------------

      -- Check_Project --

      -------------------

      function Check_Project (P : Project_Id) return Boolean is

      begin

         if P = For_Project then

            return True;

         elsif P /= No_Project then

            declare

               Data : Project_Data :=

                        In_Tree.Projects.Table (For_Project);

            begin

               while Data.Extends /= No_Project loop

                  if P = Data.Extends then

                     return True;

                  end if;

                  Data := In_Tree.Projects.Table (Data.Extends);

               end loop;

            end;

         end if;

         return False;

      end Check_Project;

      ----------------

      -- Check_Libs --

      ----------------

      procedure Check_Libs (ALI_File : String) is

         Lib_File : Name_Id;

         Text     : Text_Buffer_Ptr;

         Id       : ALI.ALI_Id;

      begin

         if not Libgnarl_Needed or

           (Hostparm.OpenVMS and then

              ((not Libdecgnat_Needed) or

               (not Gtrasymobj_Needed)))

         then

            --  Scan the ALI file

            Name_Len := ALI_File'Length;

            Name_Buffer (1 .. Name_Len) := ALI_File;

            Lib_File := Name_Find;

            Text := Read_Library_Info (Lib_File, True);

            Id  := ALI.Scan_ALI

                         (F          => Lib_File,

                          T          => Text,

                          Ignore_ED  => False,

                          Err        => True,

                          Read_Lines => "D");

            Free (Text);

            --  Look for s-osinte.ads in the dependencies

            for Index in ALI.ALIs.Table (Id).First_Sdep ..

                         ALI.ALIs.Table (Id).Last_Sdep

            loop

               if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then

                  Libgnarl_Needed := True;

               elsif Hostparm.OpenVMS then

                  if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then

                     Libdecgnat_Needed := True;

                  elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then

                     Gtrasymobj_Needed := True;

                  end if;

               end if;

            end loop;

         end if;

      end Check_Libs;

      -------------

      -- Process --

      -------------

      procedure Process (The_ALI : File_Name_Type) is

         Text       : Text_Buffer_Ptr;

         Idread     : ALI_Id;

         First_Unit : ALI.Unit_Id;

         Last_Unit  : ALI.Unit_Id;

         Unit_Data  : Unit_Record;

         Afile      : File_Name_Type;

      begin

         --  Nothing to do if the ALI file has already been processed.

         --  This happens if an interface imports another interface.

         if not Processed_ALIs.Get (The_ALI) then

            Processed_ALIs.Set (The_ALI, True);

            Text := Read_Library_Info (The_ALI);

            if Text /= null then

               Idread :=

                 Scan_ALI

                   (F         => The_ALI,

                    T         => Text,

                    Ignore_ED => False,

                    Err       => True);

               Free (Text);

               if Idread /= No_ALI_Id then

                  First_Unit := ALI.ALIs.Table (Idread).First_Unit;

                  Last_Unit  := ALI.ALIs.Table (Idread).Last_Unit;

                  --  Process both unit (spec and body) if the body is needed

                  --  by the spec (inline or generic). Otherwise, just process

                  --  the spec.

                  if First_Unit /= Last_Unit and then

                    not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL

                  then

                     First_Unit := Last_Unit;

                  end if;

                  for Unit in First_Unit .. Last_Unit loop

                     Unit_Data := ALI.Units.Table (Unit);

                     --  Check if each withed unit which is in the library is

                     --  also in the interface set, if it has not yet been

                     --  processed.

                     for W in Unit_Data.First_With .. Unit_Data.Last_With loop

                        Afile := Withs.Table (W).Afile;

                        if Afile /= No_Name and then Library_ALIs.Get (Afile)

                          and then not Processed_ALIs.Get (Afile)

                        then

                           if not Interface_ALIs.Get (Afile) then

                              if not Warning_For_Library then

                                 Write_Str ("Warning: In library project """);

                                 Get_Name_String (Data.Name);

                                 To_Mixed (Name_Buffer (1 .. Name_Len));

                                 Write_Str (Name_Buffer (1 .. Name_Len));

                                 Write_Line ("""");

                                 Warning_For_Library := True;

                              end if;

                              Write_Str ("         Unit """);

                              Get_Name_String (Withs.Table (W).Uname);

                              To_Mixed (Name_Buffer (1 .. Name_Len - 2));

                              Write_Str (Name_Buffer (1 .. Name_Len - 2));

                              Write_Line (""" is not in the interface set");

                              Write_Str ("         but it is needed by ");

                              case Unit_Data.Utype is

                                 when Is_Spec =>

                                    Write_Str ("the spec of ");

                                 when Is_Body =>

                                    Write_Str ("the body of ");

                                 when others =>

                                    null;

                              end case;

                              Write_Str ("""");

                              Get_Name_String (Unit_Data.Uname);

                              To_Mixed (Name_Buffer (1 .. Name_Len - 2));

                              Write_Str (Name_Buffer (1 .. Name_Len - 2));

                              Write_Line ("""");

                           end if;

                           --  Now, process this unit

                           Process (Afile);

                        end if;

                     end loop;

                  end loop;

               end if;

            end if;

         end if;

      end Process;

      --------------------------------

      -- Process_Imported_Libraries --

      --------------------------------

      procedure Process_Imported_Libraries is

         Current : Project_Id;

         procedure Process_Project (Project : Project_Id);

         --  Process Project and its imported projects recursively.

         --  Add any library projects to table Library_Projs.

         ---------------------

         -- Process_Project --

         ---------------------

         procedure Process_Project (Project : Project_Id) is

            Data     : constant Project_Data :=

                         In_Tree.Projects.Table (Project);

            Imported : Project_List := Data.Imported_Projects;

            Element  : Project_Element;

         begin

            --  Nothing to do if process has already been processed

            if not Processed_Projects.Get (Data.Name) then

               Processed_Projects.Set (Data.Name, True);

               --  Call Process_Project recursively for any imported project.

               --  We first process the imported projects to guarantee that

               --  we have a proper reverse order for the libraries.

               while Imported /= Empty_Project_List loop

                  Element :=

                    In_Tree.Project_Lists.Table (Imported);

                  if Element.Project /= No_Project then

                     Process_Project (Element.Project);

                  end if;

                  Imported := Element.Next;

               end loop;

               --  If it is a library project, add it to Library_Projs

               if Project /= For_Project and then Data.Library then

                  Library_Projs.Increment_Last;

                  Library_Projs.Table (Library_Projs.Last) := Project;

               end if;

            end if;

         end Process_Project;

      --  Start of processing for Process_Imported_Libraries

      begin

         --  Build list of library projects imported directly or indirectly,

         --  in the reverse order.

         Process_Project (For_Project);

         --  Add the -L and -l switches and, if the Rpath option is supported,

         --  add the directory to the Rpath.

         --  As the library projects are in the wrong order, process from the

         --  last to the first.

         for Index in reverse 1 .. Library_Projs.Last loop

            Current := Library_Projs.Table (Index);

            Get_Name_String

              (In_Tree.Projects.Table (Current).Library_Dir);

            Opts.Increment_Last;

            Opts.Table (Opts.Last) :=

              new String'("-L" & Name_Buffer (1 .. Name_Len));

            if Path_Option /= null then

               Add_Rpath (Name_Buffer (1 .. Name_Len));

            end if;

            Opts.Increment_Last;

            Opts.Table (Opts.Last) :=

              new String'

                ("-l" &

                 Get_Name_String

                   (In_Tree.Projects.Table

                      (Current).Library_Name));

         end loop;

      end Process_Imported_Libraries;

   --  Start of processing for Build_Library

   begin

      Reset_Tables;

      --  Fail if project is not a library project

      if not Data.Library then

         Com.Fail ("project """, Project_Name, """ has no library");

      end if;

      --  If this is the first time Build_Library is called, get the Name_Id

      --  of "s-osinte.ads".

      if S_Osinte_Ads = No_Name then

         Name_Len := 0;

         Add_Str_To_Name_Buffer ("s-osinte.ads");

         S_Osinte_Ads := Name_Find;

      end if;

      if S_Dec_Ads = No_Name then

         Name_Len := 0;

         Add_Str_To_Name_Buffer ("dec.ads");

         S_Dec_Ads := Name_Find;

      end if;

      if G_Trasym_Ads = No_Name then

         Name_Len := 0;

         Add_Str_To_Name_Buffer ("g-trasym.ads");

         G_Trasym_Ads := Name_Find;

      end if;

      --  We work in the object directory

      Change_Dir (Object_Directory_Path);

      if Standalone then

         --  Call gnatbind only if Bind is True

         if Bind then