diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-10-29 09:50:53 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-10-29 09:50:53 +0000 |
commit | ea36a184660c673801812aff695dd9bb88a40a32 (patch) | |
tree | d9304b5967c4c289db26282bf7af9d38f8b3c69d /gcc/ada/aa_util.adb | |
parent | 358805cc7a1f6666523a06a593b75e2524c96830 (diff) | |
download | ppe42-gcc-ea36a184660c673801812aff695dd9bb88a40a32.tar.gz ppe42-gcc-ea36a184660c673801812aff695dd9bb88a40a32.zip |
* adabkend.ads, adabkend.adb, aa_util.ads, aa_util.adb: New.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@192913 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/aa_util.adb')
-rw-r--r-- | gcc/ada/aa_util.adb | 458 |
1 files changed, 458 insertions, 0 deletions
diff --git a/gcc/ada/aa_util.adb b/gcc/ada/aa_util.adb new file mode 100644 index 00000000000..6ea4421f570 --- /dev/null +++ b/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; |