| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
