8sa1-gcc/gcc/ada/make_util.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                            M A K E _ U T I L                             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2004-2020, Free Software Foundation, Inc.         --
--                                                                          --
-- 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 Atree;    use Atree;
with Debug;
with Errutil;
with Osint;    use Osint;
with Output;   use Output;
with Opt;      use Opt;
with Table;

with Ada.Command_Line;           use Ada.Command_Line;

with GNAT.Case_Util;             use GNAT.Case_Util;
with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
with GNAT.HTable;

package body Make_Util is

   ---------
   -- Add --
   ---------

   procedure Add
     (Option : String_Access;
      To     : in out String_List_Access;
      Last   : in out Natural)
   is
   begin
      if Last = To'Last then
         declare
            New_Options : constant String_List_Access :=
                            new String_List (1 .. To'Last * 2);

         begin
            New_Options (To'Range) := To.all;

            --  Set all elements of the original options to null to avoid
            --  deallocation of copies.

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

            Free (To);
            To := New_Options;
         end;
      end if;

      Last := Last + 1;
      To (Last) := Option;
   end Add;

   procedure Add
     (Option : String;
      To     : in out String_List_Access;
      Last   : in out Natural)
   is
   begin
      Add (Option => new String'(Option), To => To, Last => Last);
   end Add;

   -------------------------
   -- Base_Name_Index_For --
   -------------------------

   function Base_Name_Index_For
     (Main            : String;
      Main_Index      : Int;
      Index_Separator : Character) return File_Name_Type
   is
      Result : File_Name_Type;

   begin
      Name_Len := 0;
      Add_Str_To_Name_Buffer (Base_Name (Main));

      --  Remove the extension, if any, that is the last part of the base name
      --  starting with a dot and following some characters.

      for J in reverse 2 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Name_Len := J - 1;
            exit;
         end if;
      end loop;

      --  Add the index info, if index is different from 0

      if Main_Index > 0 then
         Add_Char_To_Name_Buffer (Index_Separator);

         declare
            Img : constant String := Main_Index'Img;
         begin
            Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
         end;
      end if;

      Result := Name_Find;
      return Result;
   end Base_Name_Index_For;

   -----------------
   -- Create_Name --
   -----------------

   function Create_Name (Name : String) return File_Name_Type is
   begin
      Name_Len := 0;
      Add_Str_To_Name_Buffer (Name);
      return Name_Find;
   end Create_Name;

   function Create_Name (Name : String) return Name_Id is
   begin
      Name_Len := 0;
      Add_Str_To_Name_Buffer (Name);
      return Name_Find;
   end Create_Name;

   function Create_Name (Name : String) return Path_Name_Type is
   begin
      Name_Len := 0;
      Add_Str_To_Name_Buffer (Name);
      return Name_Find;
   end Create_Name;

   ---------------------------
   -- Ensure_Absolute_Path --
   ---------------------------

   procedure Ensure_Absolute_Path
     (Switch               : in out String_Access;
      Parent               : String;
      Do_Fail              : Fail_Proc;
      For_Gnatbind         : Boolean := False;
      Including_Non_Switch : Boolean := True;
      Including_RTS        : Boolean := False)
   is
   begin
      if Switch /= null then
         declare
            Sw    : String (1 .. Switch'Length);
            Start : Positive;

         begin
            Sw := Switch.all;

            if Sw (1) = '-' then
               if Sw'Length >= 3
                 and then (Sw (2) = 'I'
                            or else (not For_Gnatbind
                                      and then (Sw (2) = 'L'
                                                 or else
                                                Sw (2) = 'A')))
               then
                  Start := 3;

                  if Sw = "-I-" then
                     return;
                  end if;

               elsif Sw'Length >= 4
                 and then
                   (Sw (2 .. 3) = "aL" or else
                    Sw (2 .. 3) = "aO" or else
                    Sw (2 .. 3) = "aI"
                      or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
               then
                  Start := 4;

               elsif Including_RTS
                 and then Sw'Length >= 7
                 and then Sw (2 .. 6) = "-RTS="
               then
                  Start := 7;

               else
                  return;
               end if;

               --  Because relative path arguments to --RTS= may be relative to
               --  the search directory prefix, those relative path arguments
               --  are converted only when they include directory information.

               if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
                  if Parent'Length = 0 then
                     Do_Fail
                       ("relative search path switches ("""
                        & Sw
                        & """) are not allowed");

                  elsif Including_RTS then
                     for J in Start .. Sw'Last loop
                        if Sw (J) = Directory_Separator then
                           Switch :=
                             new String'
                               (Sw (1 .. Start - 1)
                                & Parent
                                & Directory_Separator
                                & Sw (Start .. Sw'Last));
                           return;
                        end if;
                     end loop;

                  else
                     Switch :=
                       new String'
                         (Sw (1 .. Start - 1)
                          & Parent
                          & Directory_Separator
                          & Sw (Start .. Sw'Last));
                  end if;
               end if;

            elsif Including_Non_Switch then
               if not Is_Absolute_Path (Sw) then
                  if Parent'Length = 0 then
                     Do_Fail
                       ("relative paths (""" & Sw & """) are not allowed");
                  else
                     Switch := new String'(Parent & Directory_Separator & Sw);
                  end if;
               end if;
            end if;
         end;
      end if;
   end Ensure_Absolute_Path;

   ----------------------------
   -- Executable_Prefix_Path --
   ----------------------------

   function Executable_Prefix_Path return String is
      Exec_Name : constant String := Command_Name;

      function Get_Install_Dir (S : String) return String;
      --  S is the executable name preceded by the absolute or relative path,
      --  e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
      --  lies (in the example "C:\usr"). If the executable is not in a "bin"
      --  directory, return "".

      ---------------------
      -- Get_Install_Dir --
      ---------------------

      function Get_Install_Dir (S : String) return String is
         Exec      : String  := S;
         Path_Last : Integer := 0;

      begin
         for J in reverse Exec'Range loop
            if Exec (J) = Directory_Separator then
               Path_Last := J - 1;
               exit;
            end if;
         end loop;

         if Path_Last >= Exec'First + 2 then
            To_Lower (Exec (Path_Last - 2 .. Path_Last));
         end if;

         if Path_Last < Exec'First + 2
           or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
           or else (Path_Last - 3 >= Exec'First
                     and then Exec (Path_Last - 3) /= Directory_Separator)
         then
            return "";
         end if;

         return Normalize_Pathname
                  (Exec (Exec'First .. Path_Last - 4),
                   Resolve_Links => Opt.Follow_Links_For_Dirs)
           & Directory_Separator;
      end Get_Install_Dir;

   --  Beginning of Executable_Prefix_Path

   begin
      --  First determine if a path prefix was placed in front of the
      --  executable name.

      for J in reverse Exec_Name'Range loop
         if Exec_Name (J) = Directory_Separator then
            return Get_Install_Dir (Exec_Name);
         end if;
      end loop;

      --  If we get here, the user has typed the executable name with no
      --  directory prefix.

      declare
         Path : String_Access := Locate_Exec_On_Path (Exec_Name);
      begin
         if Path = null then
            return "";
         else
            declare
               Dir : constant String := Get_Install_Dir (Path.all);
            begin
               Free (Path);
               return Dir;
            end;
         end if;
      end;
   end Executable_Prefix_Path;

   ------------------
   -- Fail_Program --
   ------------------

   procedure Fail_Program
     (S              : String;
      Flush_Messages : Boolean := True)
   is
   begin
      if Flush_Messages and not No_Exit_Message then
         if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
            Errutil.Finalize;
         end if;
      end if;

      Finish_Program (E_Fatal, S => S);
   end Fail_Program;

   --------------------
   -- Finish_Program --
   --------------------

   procedure Finish_Program
     (Exit_Code    : Osint.Exit_Code_Type := Osint.E_Success;
      S            : String := "")
   is
   begin
      if S'Length > 0 then
         if Exit_Code /= E_Success then
            if No_Exit_Message then
               Osint.Exit_Program (E_Fatal);
            else
               Osint.Fail (S);
            end if;

         elsif not No_Exit_Message then
            Write_Str (S);
         end if;
      end if;

      --  Output Namet statistics

      Namet.Finalize;

      Exit_Program (Exit_Code);
   end Finish_Program;

   ----------
   -- Hash --
   ----------

   function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
   --  Used in implementation of other functions Hash below

   ----------
   -- Hash --
   ----------

   function Hash (Name : File_Name_Type) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;

   function Hash (Name : Name_Id) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;

   function Hash (Name : Path_Name_Type) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;

   ------------
   -- Inform --
   ------------

   procedure Inform (N : File_Name_Type; Msg : String) is
   begin
      Inform (Name_Id (N), Msg);
   end Inform;

   procedure Inform (N : Name_Id := No_Name; Msg : String) is
   begin
      Osint.Write_Program_Name;

      Write_Str (": ");

      if N /= No_Name then
         Write_Str ("""");

         declare
            Name : constant String := Get_Name_String (N);
         begin
            if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
               Write_Str (File_Name (Name));
            else
               Write_Str (Name);
            end if;
         end;

         Write_Str (""" ");
      end if;

      Write_Str (Msg);
      Write_Eol;
   end Inform;

   -----------
   -- Mains --
   -----------

   package body Mains is

      package Names is new Table.Table
        (Table_Component_Type => Main_Info,
         Table_Index_Type     => Integer,
         Table_Low_Bound      => 1,
         Table_Initial        => 10,
         Table_Increment      => 100,
         Table_Name           => "Makeutl.Mains.Names");
      --  The table that stores the mains

      Current : Natural := 0;
      --  The index of the last main retrieved from the table

      Count_Of_Mains_With_No_Tree : Natural := 0;
      --  Number of main units for which we do not know the project tree

      --------------
      -- Add_Main --
      --------------

      procedure Add_Main (Name : String; Index : Int := 0) is
      begin
         Name_Len := 0;
         Add_Str_To_Name_Buffer (Name);
         Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));

         Names.Increment_Last;
         Names.Table (Names.Last) := (Name_Find, Index);

         Mains.Count_Of_Mains_With_No_Tree :=
           Mains.Count_Of_Mains_With_No_Tree + 1;
      end Add_Main;

      ------------
      -- Delete --
      ------------

      procedure Delete is
      begin
         Names.Set_Last (0);
         Mains.Reset;
      end Delete;

      ---------------
      -- Next_Main --
      ---------------

      function Next_Main return String is
         Info : constant Main_Info := Next_Main;
      begin
         if Info = No_Main_Info then
            return "";
         else
            return Get_Name_String (Info.File);
         end if;
      end Next_Main;

      function Next_Main return Main_Info is
      begin
         if Current >= Names.Last then
            return No_Main_Info;
         else
            Current := Current + 1;

            declare
               Orig_Main : constant File_Name_Type :=
                 Names.Table (Current).File;
               Current_Main : File_Name_Type;

            begin
               if Strip_Suffix (Orig_Main) = Orig_Main then
                  Get_Name_String (Orig_Main);
                  Add_Str_To_Name_Buffer (".adb");
                  Current_Main := Name_Find;

                  if Full_Source_Name (Current_Main) = No_File then
                     Get_Name_String (Orig_Main);
                     Add_Str_To_Name_Buffer (".ads");
                     Current_Main := Name_Find;

                     if Full_Source_Name (Current_Main) /= No_File then
                        Names.Table (Current).File := Current_Main;
                     end if;

                  else
                     Names.Table (Current).File := Current_Main;
                  end if;
               end if;
            end;

            return Names.Table (Current);
         end if;
      end Next_Main;

      ---------------------
      -- Number_Of_Mains --
      ---------------------

      function Number_Of_Mains return Natural is
      begin
         return Names.Last;
      end Number_Of_Mains;

      -----------
      -- Reset --
      -----------

      procedure Reset is
      begin
         Current := 0;
      end Reset;

      --------------------------
      -- Set_Multi_Unit_Index --
      --------------------------

      procedure Set_Multi_Unit_Index
        (Index        : Int := 0)
      is
      begin
         if Index /= 0 then
            if Names.Last = 0 then
               Fail_Program
                 ("cannot specify a multi-unit index but no main "
                  & "on the command line");

            elsif Names.Last > 1 then
               Fail_Program
                 ("cannot specify several mains with a multi-unit index");

            else
               Names.Table (Names.Last).Index := Index;
            end if;
         end if;
      end Set_Multi_Unit_Index;

   end Mains;

   -----------------------
   -- Path_Or_File_Name --
   -----------------------

   function Path_Or_File_Name (Path : Path_Name_Type) return String is
      Path_Name : constant String := Get_Name_String (Path);
   begin
      if Debug.Debug_Flag_F then
         return File_Name (Path_Name);
      else
         return Path_Name;
      end if;
   end Path_Or_File_Name;

   -------------------
   -- Unit_Index_Of --
   -------------------

   function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
      Start  : Natural;
      Finish : Natural;
      Result : Int := 0;

   begin
      Get_Name_String (ALI_File);

      --  First, find the last dot

      Finish := Name_Len;

      while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
         Finish := Finish - 1;
      end loop;

      if Finish = 1 then
         return 0;
      end if;

      --  Now check that the dot is preceded by digits

      Start := Finish;
      Finish := Finish - 1;
      while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
         Start := Start - 1;
      end loop;

      --  If there are no digits, or if the digits are not preceded by the
      --  character that precedes a unit index, this is not the ALI file of
      --  a unit in a multi-unit source.

      if Start > Finish
        or else Start = 1
        or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
      then
         return 0;
      end if;

      --  Build the index from the digit(s)

      while Start <= Finish loop
         Result := Result * 10 +
                     Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
         Start := Start + 1;
      end loop;

      return Result;
   end Unit_Index_Of;

   -----------------
   -- Verbose_Msg --
   -----------------

   procedure Verbose_Msg
     (N1                : Name_Id;
      S1                : String;
      N2                : Name_Id := No_Name;
      S2                : String  := "";
      Prefix            : String := "  -> ";
      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
   is
   begin
      if not Opt.Verbose_Mode
        or else Minimum_Verbosity > Opt.Verbosity_Level
      then
         return;
      end if;

      Write_Str (Prefix);
      Write_Str ("""");
      Write_Name (N1);
      Write_Str (""" ");
      Write_Str (S1);

      if N2 /= No_Name then
         Write_Str (" """);
         Write_Name (N2);
         Write_Str (""" ");
      end if;

      Write_Str (S2);
      Write_Eol;
   end Verbose_Msg;

   procedure Verbose_Msg
     (N1                : File_Name_Type;
      S1                : String;
      N2                : File_Name_Type := No_File;
      S2                : String  := "";
      Prefix            : String := "  -> ";
      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
   is
   begin
      Verbose_Msg
        (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
   end Verbose_Msg;

   -----------
   -- Queue --
   -----------

   package body Queue is

      type Q_Record is record
         Info      : Source_Info;
         Processed : Boolean;
      end record;

      package Q is new Table.Table
        (Table_Component_Type => Q_Record,
         Table_Index_Type     => Natural,
         Table_Low_Bound      => 1,
         Table_Initial        => 1000,
         Table_Increment      => 100,
         Table_Name           => "Makeutl.Queue.Q");
      --  This is the actual Queue

      type Mark_Key is record
         File  : File_Name_Type;
         Index : Int;
      end record;
      --  Identify either a mono-unit source (when Index = 0) or a specific
      --  unit (index = 1's origin index of unit) in a multi-unit source.

      Max_Mask_Num : constant := 2048;
      subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;

      function Hash (Key : Mark_Key) return Mark_Num;

      package Marks is new GNAT.HTable.Simple_HTable
        (Header_Num => Mark_Num,
         Element    => Boolean,
         No_Element => False,
         Key        => Mark_Key,
         Hash       => Hash,
         Equal      => "=");
      --  A hash table to keep tracks of the marked units.
      --  These are the units that have already been processed, when using the
      --  gnatmake format. When using the gprbuild format, we can directly
      --  store in the source_id whether the file has already been processed.

      procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
      --  Mark a unit, identified by its source file and, when Index is not 0,
      --  the index of the unit in the source file. Marking is used to signal
      --  that the unit has already been inserted in the Q.

      function Is_Marked
        (Source_File : File_Name_Type;
         Index       : Int := 0) return Boolean;
      --  Returns True if the unit was previously marked

      Q_Processed   : Natural := 0;
      Q_Initialized : Boolean := False;

      Q_First : Natural := 1;
      --  Points to the first valid element in the queue

      procedure Debug_Display (S : Source_Info);
      --  A debug display for S

      function Was_Processed (S : Source_Info) return Boolean;
      --  Whether S has already been processed. This marks the source as
      --  processed, if it hasn't already been processed.

      -------------------
      -- Was_Processed --
      -------------------

      function Was_Processed (S : Source_Info) return Boolean is
      begin
         if Is_Marked (S.File, S.Index) then
            return True;
         end if;

         Mark (S.File, Index => S.Index);

         return False;
      end Was_Processed;

      -------------------
      -- Debug_Display --
      -------------------

      procedure Debug_Display (S : Source_Info) is
      begin
         Write_Name (S.File);

         if S.Index /= 0 then
            Write_Str (", ");
            Write_Int (S.Index);
         end if;
      end Debug_Display;

      ----------
      -- Hash --
      ----------

      function Hash (Key : Mark_Key) return Mark_Num is
      begin
         return Union_Id (Key.File) mod Max_Mask_Num;
      end Hash;

      ---------------
      -- Is_Marked --
      ---------------

      function Is_Marked
        (Source_File : File_Name_Type;
         Index       : Int := 0) return Boolean
      is
      begin
         return Marks.Get (K => (File => Source_File, Index => Index));
      end Is_Marked;

      ----------
      -- Mark --
      ----------

      procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
      begin
         Marks.Set (K => (File => Source_File, Index => Index), E => True);
      end Mark;

      -------------
      -- Extract --
      -------------

      procedure Extract
        (Found  : out Boolean;
         Source : out Source_Info)
      is
      begin
         Found := False;

         if Q_First <= Q.Last then
            Source := Q.Table (Q_First).Info;
            Q.Table (Q_First).Processed := True;
            Q_First := Q_First + 1;
            Found := True;
         end if;

         if Found then
            Q_Processed := Q_Processed + 1;
         end if;

         if Found and then Debug.Debug_Flag_Q then
            Write_Str ("   Q := Q - [ ");
            Debug_Display (Source);
            Write_Str (" ]");
            Write_Eol;

            Write_Str ("   Q_First =");
            Write_Int (Int (Q_First));
            Write_Eol;

            Write_Str ("   Q.Last =");
            Write_Int (Int (Q.Last));
            Write_Eol;
         end if;
      end Extract;

      ---------------
      -- Processed --
      ---------------

      function Processed return Natural is
      begin
         return Q_Processed;
      end Processed;

      ----------------
      -- Initialize --
      ----------------

      procedure Initialize (Force : Boolean := False) is
      begin
         if Force or else not Q_Initialized then
            Q_Initialized := True;
            Q.Init;
            Q_Processed := 0;
            Q_First     := 1;
         end if;
      end Initialize;

      ------------
      -- Insert --
      ------------

      function Insert (Source  : Source_Info) return Boolean is
      begin
         --  Only insert in the Q if it is not already done, to avoid
         --  simultaneous compilations if -jnnn is used.

         if Was_Processed (Source) then
            return False;
         end if;

         Q.Append (New_Val => (Info => Source, Processed => False));

         if Debug.Debug_Flag_Q then
            Write_Str ("   Q := Q + [ ");
            Debug_Display (Source);
            Write_Str (" ] ");
            Write_Eol;

            Write_Str ("   Q_First =");
            Write_Int (Int (Q_First));
            Write_Eol;

            Write_Str ("   Q.Last =");
            Write_Int (Int (Q.Last));
            Write_Eol;
         end if;

         return True;
      end Insert;

      procedure Insert (Source : Source_Info) is
         Discard : Boolean;
      begin
         Discard := Insert (Source);
      end Insert;

      --------------
      -- Is_Empty --
      --------------

      function Is_Empty return Boolean is
      begin
         return Q_Processed >= Q.Last;
      end Is_Empty;

      ----------
      -- Size --
      ----------

      function Size return Natural is
      begin
         return Q.Last;
      end Size;

      -------------
      -- Element --
      -------------

      function Element (Rank : Positive) return File_Name_Type is
      begin
         if Rank <= Q.Last then
            return Q.Table (Rank).Info.File;
         else
            return No_File;
         end if;
      end Element;

      ------------------
      -- Remove_Marks --
      ------------------

      procedure Remove_Marks is
      begin
         Marks.Reset;
      end Remove_Marks;

   end Queue;

end Make_Util;