aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/aa_util.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/aa_util.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/aa_util.adb458
1 files changed, 458 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/aa_util.adb b/gcc-4.8.3/gcc/ada/aa_util.adb
new file mode 100644
index 000000000..6ea4421f5
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/aa_util.adb
@@ -0,0 +1,458 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;