mirror of git://gcc.gnu.org/git/gcc.git
459 lines
14 KiB
Ada
459 lines
14 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|