===================================================================
@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
@@ -1753,6 +1754,62 @@ package body Exp_Util is
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
end Force_Evaluation;
+ ---------------------------------
+ -- Fully_Qualified_Name_String --
+ ---------------------------------
+
+ function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
+ procedure Internal_Full_Qualified_Name (E : Entity_Id);
+ -- Compute recursively the qualified name without NUL at the end, adding
+ -- it to the currently started string being generated
+
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
+ procedure Internal_Full_Qualified_Name (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ -- Deal properly with child units
+
+ if Nkind (E) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (E);
+ else
+ Ent := E;
+ end if;
+
+ -- Compute qualification recursively (only "Standard" has no scope)
+
+ if Present (Scope (Scope (Ent))) then
+ Internal_Full_Qualified_Name (Scope (Ent));
+ Store_String_Char (Get_Char_Code ('.'));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Decoded_Name_String (Chars (Ent));
+ Set_All_Upper_Case;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return;
+ end Internal_Full_Qualified_Name;
+
+ -- Start of processing for Full_Qualified_Name
+
+ begin
+ Start_String;
+ Internal_Full_Qualified_Name (E);
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Fully_Qualified_Name_String;
+
------------------------
-- Generate_Poll_Call --
------------------------
===================================================================
@@ -403,6 +403,10 @@ package Exp_Util is
-- Force_Evaluation further guarantees that all evaluations will yield
-- the same result.
+ function Fully_Qualified_Name_String (E : Entity_Id) return String_Id;
+ -- Generates the string literal corresponding to the fully qualified name
+ -- of entity E with an ASCII.NUL appended at the end of the name.
+
procedure Generate_Poll_Call (N : Node_Id);
-- If polling is active, then a call to the Poll routine is built,
-- and then inserted before the given node N and analyzed.
===================================================================
@@ -3468,71 +3468,6 @@ package body Sem_Util is
end if;
end First_Actual;
- -------------------------
- -- Full_Qualified_Name --
- -------------------------
-
- function Full_Qualified_Name (E : Entity_Id) return String_Id is
- Res : String_Id;
- pragma Warnings (Off, Res);
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
- -- Compute recursively the qualified name without NUL at the end
-
- ----------------------------------
- -- Internal_Full_Qualified_Name --
- ----------------------------------
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
- Ent : Entity_Id := E;
- Parent_Name : String_Id := No_String;
-
- begin
- -- Deals properly with child units
-
- if Nkind (Ent) = N_Defining_Program_Unit_Name then
- Ent := Defining_Identifier (Ent);
- end if;
-
- -- Compute qualification recursively (only "Standard" has no scope)
-
- if Present (Scope (Scope (Ent))) then
- Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
- end if;
-
- -- Every entity should have a name except some expanded blocks
- -- don't bother about those.
-
- if Chars (Ent) = No_Name then
- return Parent_Name;
- end if;
-
- -- Add a period between Name and qualification
-
- if Parent_Name /= No_String then
- Start_String (Parent_Name);
- Store_String_Char (Get_Char_Code ('.'));
-
- else
- Start_String;
- end if;
-
- -- Generates the entity name in upper case
-
- Get_Decoded_Name_String (Chars (Ent));
- Set_All_Upper_Case;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- return End_String;
- end Internal_Full_Qualified_Name;
-
- -- Start of processing for Full_Qualified_Name
-
- begin
- Res := Internal_Full_Qualified_Name (E);
- Store_String_Char (Get_Char_Code (ASCII.NUL));
- return End_String;
- end Full_Qualified_Name;
-
-----------------------
-- Gather_Components --
-----------------------
===================================================================
@@ -379,11 +379,6 @@ package Sem_Util is
-- is always the expression (not the N_Parameter_Association nodes,
-- even if named association is used).
- function Full_Qualified_Name (E : Entity_Id) return String_Id;
- -- Generates the string literal corresponding to the E's full qualified
- -- name in upper case. An ASCII.NUL is appended as the last character.
- -- The names in the string are generated by Namet.Get_Decoded_Name_String.
-
procedure Gather_Components
(Typ : Entity_Id;
Comp_List : Node_Id;
===================================================================
@@ -1265,7 +1265,7 @@ package body Exp_Ch11 is
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Strval => Full_Qualified_Name (Id))));
+ Strval => Fully_Qualified_Name_String (Id))));
Set_Is_Statically_Allocated (Exname);
===================================================================
@@ -4483,8 +4483,7 @@ package body Exp_Disp is
end loop;
end if;
- -- Get the _tag entity and the number of primitives of its dispatch
- -- table.
+ -- Get the _tag entity and number of primitives of its dispatch table
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
@@ -4654,7 +4653,7 @@ package body Exp_Disp is
Object_Definition => New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Full_Qualified_Name (First_Subtype (Typ)))));
+ Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
@@ -4768,7 +4767,7 @@ package body Exp_Disp is
New_External_Name (Tname, 'A'));
Full_Name : constant String_Id :=
- Full_Qualified_Name (First_Subtype (Typ));
+ Fully_Qualified_Name_String (First_Subtype (Typ));
Str1_Id : String_Id;
Str2_Id : String_Id;
===================================================================
@@ -5541,7 +5541,7 @@ package body Exp_Dist is
-- Name
Make_String_Literal (Loc,
- Full_Qualified_Name (Desig)),
+ Fully_Qualified_Name_String (Desig)),
-- Handler
@@ -5887,7 +5887,7 @@ package body Exp_Dist is
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (RACW_Parameter, Loc)),
Make_String_Literal (Loc,
- Strval => Full_Qualified_Name
+ Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
@@ -6083,7 +6083,7 @@ package body Exp_Dist is
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Object),
Make_String_Literal (Loc,
- Strval => Full_Qualified_Name
+ Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),