libgpr2_24.0.0_eda3c693/src/lib/gpr2.adb

--
--  Copyright (C) 2019-2023, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception
--

with Ada.Directories;
with Ada.Strings.Less_Case_Insensitive;

pragma Warnings (Off, "* is an internal GNAT unit");
with System.Soft_Links;               use System.Soft_Links;
pragma Warnings (On, "* is an internal GNAT unit");

with GNAT.OS_Lib;

package body GPR2 is

   Is_Multitasking : constant Boolean :=
      System.Soft_Links.Lock_Task /= System.Soft_Links.Task_Lock_NT'Access;

   ---------
   -- "<" --
   ---------

   overriding function "<" (Left, Right : Optional_Name_Type) return Boolean is
      use Ada.Strings;
   begin
      return Less_Case_Insensitive (String (Left), String (Right));
   end "<";

   overriding function "<" (Left, Right : Filename_Optional) return Boolean is
   begin
      return (if File_Names_Case_Sensitive
              then String (Left) < String (Right)
              else Ada.Strings.Less_Case_Insensitive
                     (String (Left), String (Right)));
   end "<";

   ---------
   -- "=" --
   ---------

   overriding function "=" (Left, Right : Optional_Name_Type) return Boolean is
      use Ada.Strings;
   begin
      return Equal_Case_Insensitive (String (Left), String (Right));
   end "=";

   overriding function "=" (Left, Right : Filename_Optional) return Boolean is
   begin
      return (if File_Names_Case_Sensitive
              then String (Left) = String (Right)
              else Ada.Strings.Equal_Case_Insensitive
                     (String (Left), String (Right)));
   end "=";

   ---------------------------
   -- Get_Executable_Suffix --
   ---------------------------

   function Get_Executable_Suffix return String is
      Exec_Suffix : GNAT.OS_Lib.String_Access
                      := GNAT.OS_Lib.Get_Executable_Suffix;
   begin
      return Result : constant String := Exec_Suffix.all
      do
         GNAT.OS_Lib.Free (Exec_Suffix);
      end return;
   end Get_Executable_Suffix;

   -------------------------
   -- Get_Tools_Directory --
   -------------------------

   function Get_Tools_Directory return String is
      GPRls : constant String := Locate_Exec_On_Path ("gprls");
      --  Check for GPRls executable
   begin
      return (if GPRls = ""
              then ""
              else Directories.Containing_Directory
                     (Directories.Containing_Directory
                        (GNAT.OS_Lib.Normalize_Pathname
                            (GPRls, Resolve_Links => True))));
   end Get_Tools_Directory;

   --------
   -- Id --
   --------

   function Id (List : in out Name_List;
                Name : Optional_Name_Type) return Natural
   is
      C          : Name_Maps.Cursor;
      Result     : Natural;
      Value      : constant String :=
                     Ada.Characters.Handling.To_Lower (String (Name));
   begin
      if Name'Length = 0 then
         return 0;
      end if;

      --  Note: if we just read the value, the operation is thread-safe.
      --  So let's not add a penalty for the read operation, that should be
      --  the most common operation.
      C := List.Name_To_Id.Find (Value);

      if Name_Maps.Has_Element (C) then
         return Name_Maps.Element (C);
      end if;

      --  We need to add the value: as this operation is not atomic
      --  and the tables are global, we need to ensure the operation
      --  cannot be interrupted.
      begin
         System.Soft_Links.Lock_Task.all;

         if Is_Multitasking then
            --  In a multitasking environment, the value could have been
            --  inserted by someone else since we've checked it above.
            --  So let's retry:
            C := List.Name_To_Id.Find (Value);

            if Name_Maps.Has_Element (C) then
               --  return with the value
               System.Soft_Links.Unlock_Task.all;
               return Name_Maps.Element (C);
            end if;
         end if;

         --  Still not in there, so let's add the value to the list
         List.Id_To_Name.Append (Value);
         Result := Natural (List.Id_To_Name.Last_Index);
         List.Name_To_Id.Insert (Value, Result);

      exception
         when others =>
            System.Soft_Links.Unlock_Task.all;
            raise;
      end;

      --  Don't need the lock anymore
      System.Soft_Links.Unlock_Task.all;

      return Result;
   end Id;

   -----------
   -- Image --
   -----------

   function Image (List : Name_List;
                   Id   : Natural) return String is
   begin
      return To_Mixed (String (Name (List, Id)));
   end Image;

   --------------------------
   -- Is_Runtime_Unit_Name --
   --------------------------

   function Is_Runtime_Unit_Name (Name : Name_Type) return Boolean is

      LN : constant String := To_Lower (Name);

      function Is_It (Root : String) return Boolean is
        (GNATCOLL.Utils.Starts_With (LN, Root)
         and then (LN'Length = Root'Length
                   or else (LN'Length > Root'Length + 1
                            and then LN (LN'First + Root'Length) = '.')));
      --  Returns True if LN equal to Root or starts with Root & '.' and has
      --  length more than Root'Length + 2.

   begin
      return Is_It ("ada")
        or else Is_It ("system")
        or else Is_It ("interfaces")
        or else Is_It ("gnat")
        or else LN in "direct_io"
                    | "calendar"
                    | "io_exceptions"
                    | "machine_code"
                    | "unchecked_conversion"
                    | "unchecked_deallocation";
   end Is_Runtime_Unit_Name;

   -------------------------
   -- Locate_Exec_On_Path --
   -------------------------

   function Locate_Exec_On_Path (Exec_Name : String) return String is
      use type GNAT.OS_Lib.String_Access;

      Path     : GNAT.OS_Lib.String_Access
                   := GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name);
      Path_Str : constant String := (if Path = null then "" else Path.all);
   begin
      GNAT.OS_Lib.Free (Path);
      return Path_Str;
   end Locate_Exec_On_Path;

   ----------
   -- Name --
   ----------

   function Name (List : Name_List;
                  Id   : Natural) return Optional_Name_Type is
   begin
      if Id = 0 then
         return "";
      end if;

      return Optional_Name_Type (List.Id_To_Name.Element (Id));
   end Name;

   -----------------
   -- Parent_Name --
   -----------------

   function Parent_Name (Name : Name_Type) return Optional_Name_Type is
   begin
      for J in reverse Name'Range loop
         if Name (J) = '.'  then
            return Name (Name'First .. J - 1);
         end if;
      end loop;

      return No_Name;
   end Parent_Name;

   -----------
   -- Quote --
   -----------

   function Quote
     (Str        : Value_Type;
      Quote_With : Character := '"') return Value_Type is
   begin
      return Quote_With &
        GNATCOLL.Utils.Replace (Str, "" & Quote_With,
                                Quote_With & Quote_With) &
        Quote_With;
   end Quote;

   ---------------
   -- Set_Debug --
   ---------------

   procedure Set_Debug (Mode : Character; Enable : Boolean := True) is
   begin
      if Mode = '*' then
         Debug := (others => Enable);
      else
         Debug (Mode) := Enable;
      end if;
   end Set_Debug;

   -------------------
   -- To_Hex_String --
   -------------------

   function To_Hex_String (Num : Word) return String is
      Hex_Digit : constant array (Word range 0 .. 15) of Character :=
                    "0123456789abcdef";
      Result : String (1 .. 8);
      Value  : Word := Num;
   begin
      for J in reverse Result'Range loop
         Result (J) := Hex_Digit (Value mod 16);
         Value := Value / 16;
      end loop;

      return Result;
   end To_Hex_String;

   --------------
   -- To_Mixed --
   --------------

   function To_Mixed (A : String) return String is
      use Ada.Characters.Handling;
      Ucase  : Boolean := True;
      Result : String (A'Range);
   begin
      for J in A'Range loop
         if Ucase then
            Result (J) := To_Upper (A (J));
         else
            Result (J) := To_Lower (A (J));
         end if;

         Ucase := A (J) in '_' | '.' | ' ';
      end loop;

      return Result;
   end To_Mixed;

   -------------
   -- Unquote --
   -------------

   function Unquote (Str : Value_Type) return Value_Type is
   begin
      if Str'Length >= 2
        and then
          ((Str (Str'First) = ''' and then Str (Str'Last) = ''')
           or else (Str (Str'First) = '"' and then Str (Str'Last) = '"'))
      then
         if Str (Str'First) = ''' then
            return GNATCOLL.Utils.Replace
              (S           => Str (Str'First + 1 .. Str'Last - 1),
               Pattern     => "''",
               Replacement => "'");
         else
            return GNATCOLL.Utils.Replace
              (S           => Str (Str'First + 1 .. Str'Last - 1),
               Pattern     => """""",
               Replacement => """");
         end if;
      else
         return Str;
      end if;
   end Unquote;

begin
   Language_List.Id_To_Name.Append ("ada");
   Language_List.Id_To_Name.Append ("c");
   Language_List.Id_To_Name.Append ("c++");
   Language_List.Name_To_Id.Insert ("ada", 1);
   Language_List.Name_To_Id.Insert ("c",   2);
   Language_List.Name_To_Id.Insert ("c++", 3);
end GPR2;