path: root/gcc/ada/aa_util.adb

------------------------------------------------------------------------------
--                                                                          --
--                        GNAAMP COMPILER COMPONENTS                        --
--                                                                          --
--                              A A _ U T I L                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2001-2012, 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.          --
--                                                                          --
------------------------------------------------------------------------------

with Sem_Aux; use Sem_Aux;
with Sinput;  use Sinput;
with Stand;   use Stand;
with Stringt; use Stringt;

with GNAT.Case_Util;  use GNAT.Case_Util;

package body AA_Util is

   ----------------------
   -- Is_Global_Entity --
   ----------------------

   function Is_Global_Entity (E : Entity_Id) return Boolean is
   begin
      return Enclosing_Dynamic_Scope (E) = Standard_Standard;
   end Is_Global_Entity;

   -----------------
   -- New_Name_Id --
   -----------------

   function New_Name_Id (Name : String) return Name_Id is
   begin
      for J in 1 .. Name'Length loop
         Name_Buffer (J) := Name (Name'First + (J - 1));
      end loop;

      Name_Len := Name'Length;
      return Name_Find;
   end New_Name_Id;

   -----------------
   -- Name_String --
   -----------------

   function Name_String (Name : Name_Id) return String is
   begin
      pragma Assert (Name /= No_Name);
      return Get_Name_String (Name);
   end Name_String;

   -------------------
   -- New_String_Id --
   -------------------

   function New_String_Id (S : String) return String_Id is
   begin
      for J in 1 .. S'Length loop
         Name_Buffer (J) := S (S'First + (J - 1));
      end loop;

      Name_Len := S'Length;
      return String_From_Name_Buffer;
   end New_String_Id;

   ------------------
   -- String_Value --
   ------------------

   function String_Value (Str_Id : String_Id) return String is
   begin
      --  ??? pragma Assert (Str_Id /= No_String);

      if Str_Id = No_String then
         return "";
      end if;

      String_To_Name_Buffer (Str_Id);

      return Name_Buffer (1 .. Name_Len);
   end String_Value;

   ---------------
   -- Next_Name --
   ---------------

   function Next_Name
     (Name_Seq    : not null access Name_Sequencer;
      Name_Prefix : String) return Name_Id
   is
   begin
      Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1;

      declare
         Number_Image : constant String := Name_Seq.Sequence_Number'Img;
      begin
         return New_Name_Id
                  (Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last));
      end;
   end Next_Name;

   --------------------
   -- Elab_Spec_Name --
   --------------------

   function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is
   begin
      return New_Name_Id (Name_String (Module_Name) & "___elabs");
   end Elab_Spec_Name;

   --------------------
   -- Elab_Spec_Name --
   --------------------

   function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is
   begin
      return New_Name_Id (Name_String (Module_Name) & "___elabb");
   end Elab_Body_Name;

   --------------------------------
   -- Source_Name_Without_Suffix --
   --------------------------------

   function File_Name_Without_Suffix (File_Name : String) return String is
      Name_Index : Natural := File_Name'Last;

   begin
      pragma Assert (File_Name'Length > 0);

      --  We loop in reverse to ensure that file names that follow nonstandard
      --  naming conventions that include additional dots are handled properly,
      --  preserving dots in front of the main file suffix (for example,
      --  main.2.ada => main.2).

      while Name_Index >= File_Name'First
        and then File_Name (Name_Index) /= '.'
      loop
         Name_Index := Name_Index - 1;
      end loop;

      --  Return the part of the file name up to but not including the last dot
      --  in the name, or return the whole name as is if no dot character was
      --  found.

      if Name_Index >= File_Name'First then
         return File_Name (File_Name'First .. Name_Index - 1);

      else
         return File_Name;
      end if;
   end File_Name_Without_Suffix;

   -----------------
   -- Source_Name --
   -----------------

   function Source_Name (Sloc : Source_Ptr) return File_Name_Type is
   begin
      if Sloc = No_Location or Sloc = Standard_Location then
         return No_File;
      else
         return File_Name (Get_Source_File_Index (Sloc));
      end if;
   end Source_Name;

   --------------------------------
   -- Source_Name_Without_Suffix --
   --------------------------------

   function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is
      Src_Name  : constant String :=
        Name_String (Name_Id (Source_Name (Sloc)));
      Src_Index : Natural         := Src_Name'Last;

   begin
      pragma Assert (Src_Name'Length > 0);

      --  Treat the presence of a ".dg" suffix specially, stripping it off
      --  in addition to any suffix preceding it.

      if Src_Name'Length >= 4
        and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg"
      then
         Src_Index := Src_Index - 3;
      end if;

      return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index));
   end Source_Name_Without_Suffix;

   ----------------------
   -- Source_Id_String --
   ----------------------

   function Source_Id_String (Unit_Name : Name_Id) return String is
      Unit_String : String   := Name_String (Unit_Name);
      Name_Last   : Positive := Unit_String'Last;
      Name_Index  : Positive := Unit_String'First;

   begin
      To_Mixed (Unit_String);

      --  Replace any embedded sequences of two or more '_' characters
      --  with a single '.' character. Note that this will leave any
      --  leading or trailing single '_' characters untouched, but those
      --  should normally not occur in compilation unit names (and if
      --  they do then it's better to leave them as is).

      while Name_Index <= Name_Last loop
         if Unit_String (Name_Index) = '_'
           and then Name_Index /= Name_Last
           and then Unit_String (Name_Index + 1) = '_'
         then
            Unit_String (Name_Index) := '.';
            Name_Index := Name_Index + 1;

            while Unit_String (Name_Index) = '_'
              and then Name_Index <= Name_Last
            loop
               Unit_String (Name_Index .. Name_Last - 1)
                 := Unit_String (Name_Index + 1 .. Name_Last);
               Name_Last := Name_Last - 1;
            end loop;

         else
            Name_Index := Name_Index + 1;
         end if;
      end loop;

      return Unit_String (Unit_String'First .. Name_Last);
   end Source_Id_String;

   --  This version of Source_Id_String is obsolescent and is being
   --  replaced with the above function.

   function Source_Id_String (Sloc : Source_Ptr) return String is
      File_Index : Source_File_Index;

   begin
      --  Use an arbitrary artificial 22-character value for package Standard,
      --  since Standard doesn't have an associated source file.

      if Sloc <= Standard_Location then
         return "20010101010101standard";

      --  Return the concatentation of the source file's timestamp and
      --  its 8-digit hex checksum.

      else
         File_Index := Get_Source_File_Index (Sloc);

         return String (Time_Stamp (File_Index))
                  & Get_Hex_String (Source_Checksum (File_Index));
      end if;
   end Source_Id_String;

   ---------------
   -- Source_Id --
   ---------------

   function Source_Id (Unit_Name : Name_Id) return String_Id is
   begin
      return New_String_Id (Source_Id_String (Unit_Name));
   end Source_Id;

   --  This version of Source_Id is obsolescent and is being
   --  replaced with the above function.

   function Source_Id (Sloc : Source_Ptr) return String_Id is
   begin
      return New_String_Id (Source_Id_String (Sloc));
   end Source_Id;

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

   function Image (I : Int) return String is
      Image_String : constant String := Pos'Image (I);
   begin
      if Image_String (1) = ' ' then
         return Image_String (2 .. Image_String'Last);
      else
         return Image_String;
      end if;
   end Image;

   --------------
   -- UI_Image --
   --------------

   function UI_Image (I : Uint; Format : Integer_Image_Format) return String is
   begin
      if Format = Decimal then
         UI_Image (I, Format => Decimal);
         return UI_Image_Buffer (1 .. UI_Image_Length);

      elsif Format = Ada_Hex then
         UI_Image (I, Format => Hex);
         return UI_Image_Buffer (1 .. UI_Image_Length);

      else
         pragma Assert (I >= Uint_0);

         UI_Image (I, Format => Hex);

         pragma Assert (UI_Image_Buffer (1 .. 3) = "16#"
                         and then UI_Image_Buffer (UI_Image_Length) = '#');

         --  Declare a string where we will copy the digits from the UI_Image,
         --  interspersing '_' characters as 4-digit group separators. The
         --  underscores in UI_Image's result are not always at the places
         --  where we want them, which is why we do the following copy
         --  (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^").

         declare
            Hex_String     : String (1 .. UI_Image_Max);
            Last_Index     : Natural;
            Digit_Count    : Natural := 0;
            UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket
            Sep_Count      : Natural := 0;

         begin
            --  Count up the number of non-underscore characters in the
            --  literal value portion of the UI_Image string.

            while UI_Image_Buffer (UI_Image_Index) /= '#' loop
               if UI_Image_Buffer (UI_Image_Index) /= '_' then
                  Digit_Count := Digit_Count + 1;
               end if;

               UI_Image_Index := UI_Image_Index + 1;
            end loop;

            UI_Image_Index := 4; -- Reset the index past the "16#" bracket

            Last_Index := 1;

            Hex_String (Last_Index) := '^';
            Last_Index := Last_Index + 1;

            --  Copy digits from UI_Image_Buffer to Hex_String, adding
            --  underscore separators as appropriate. The initial value
            --  of Sep_Count accounts for the leading '^' and being one
            --  character ahead after inserting a digit.

            Sep_Count := 2;

            while UI_Image_Buffer (UI_Image_Index) /= '#' loop
               if UI_Image_Buffer (UI_Image_Index) /= '_' then
                  Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index);

                  Last_Index := Last_Index + 1;

                  --  Add '_' characters to separate groups of four hex
                  --  digits for readability (grouping from right to left).

                  if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then
                     Hex_String (Last_Index) := '_';
                     Last_Index := Last_Index + 1;
                     Sep_Count := Sep_Count + 1;
                  end if;
               end if;

               UI_Image_Index := UI_Image_Index + 1;
            end loop;

            --  Back up before any trailing underscore

            if Hex_String (Last_Index - 1) = '_' then
               Last_Index := Last_Index - 1;
            end if;

            Hex_String (Last_Index) := '^';

            return Hex_String (1 .. Last_Index);
         end;
      end if;
   end UI_Image;

   --------------
   -- UR_Image --
   --------------

   --  Shouldn't this be added to Urealp???

   function UR_Image (R : Ureal) return String is

      --  The algorithm used here for conversion of Ureal values
      --  is taken from the JGNAT back end.

      Num    : Long_Long_Float := 0.0;
      Den    : Long_Long_Float := 0.0;
      Sign   : Long_Long_Float := 1.0;
      Result : Long_Long_Float;
      Tmp    : Uint;
      Index  : Integer;

   begin
      if UR_Is_Negative (R) then
         Sign := -1.0;
      end if;

      --  In the following calculus, we consider numbers modulo 2 ** 31,
      --  so that we don't have problems with signed Int...

      Tmp := abs (Numerator (R));
      Index := 0;
      while Tmp > 0 loop
         Num := Num
           + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
           * (2.0 ** Index);
         Tmp := Tmp / Uint_2 ** 31;
         Index := Index + 31;
      end loop;

      Tmp := abs (Denominator (R));
      if Rbase (R) /= 0 then
         Tmp := Rbase (R) ** Tmp;
      end if;

      Index := 0;
      while Tmp > 0 loop
         Den := Den
           + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
           * (2.0 ** Index);
         Tmp := Tmp / Uint_2 ** 31;
         Index := Index + 31;
      end loop;

      --  If the denominator denotes a negative power of Rbase,
      --  then multiply by the denominator.

      if Rbase (R) /= 0 and then Denominator (R) < 0 then
         Result := Sign * Num * Den;

      --  Otherwise compute the quotient

      else
         Result := Sign * Num / Den;
      end if;

      return Long_Long_Float'Image (Result);
   end UR_Image;

end AA_Util;