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