------------------------------------------------------------------------------
with Atree; use Atree;
-with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Disp; use Exp_Disp;
+with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
+with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
begin
-- No output if the "ci" output file has not been previously opened
- -- by toplev.c. Temporarily the output is also disabled with -gnatd.Z
+ -- by toplev.c
- if Callgraph_Info_File = Null_Address
- or else not Debug_Flag_Dot_ZZ
- then
+ if Callgraph_Info_File = Null_Address then
return;
end if;
Write_Call_Info (N);
else pragma Assert (Nkind (N) = N_Defining_Identifier);
+
+ -- The type may be a private untagged type whose completion is
+ -- tagged, in which case we must use the full tagged view.
+
+ if not Is_Tagged_Type (N) and then Is_Private_Type (N) then
+ N := Full_View (N);
+ end if;
+
pragma Assert (Is_Tagged_Type (N));
Write_Type_Info (N);
---------------------------
function Homonym_Suffix_Length (E : Entity_Id) return Natural is
- Prefix_Length : constant := 2; -- Length of prefix "__"
+ Prefix_Length : constant := 2;
+ -- Length of prefix "__"
H : Entity_Id;
Nr : Nat := 1;
else
declare
Result : Natural := Prefix_Length + 1;
+
begin
- while Nr > 10 loop
+ while Nr >= 10 loop
Result := Result + 1;
Nr := Nr / 10;
end loop;
+
return Result;
end;
end if;
-- Local variables
- Full_Name : constant String := Get_Name_String (Chars (E));
- TSS_Name : TSS_Name_Type;
+ Full_Name : constant String := Get_Name_String (Chars (E));
+ Suffix_Length : Natural;
+ TSS_Name : TSS_Name_Type;
-- Start of processing for Is_Predefined_Dispatching_Operation
return False;
end if;
+ -- Search for and strip suffix for body-nested package entities
+
+ Suffix_Length := Homonym_Suffix_Length (E);
+ for J in reverse Full_Name'First + 2 .. Full_Name'Last loop
+ if Full_Name (J) = 'X' then
+
+ -- Include the "X", "Xb", "Xn", ... in the part of the
+ -- suffix to be removed.
+
+ Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
+ exit;
+ end if;
+
+ exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
+ end loop;
+
-- Most predefined primitives have internally generated names. Equality
-- must be treated differently; the predefined operation is recognized
-- as a homogeneous binary operator that returns Boolean.
if Full_Name'Length > TSS_Name_Type'Length then
TSS_Name :=
- TSS_Name_Type (Full_Name (Full_Name'Last - TSS_Name'Length + 1
- .. Full_Name'Last));
+ TSS_Name_Type
+ (Full_Name
+ (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1
+ .. Full_Name'Last - Suffix_Length));
if TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else Is_Predefined_Interface_Primitive (E)
then
Name_uDisp_Requeue,
Name_uDisp_Timed_Select);
- Suffix_Length : constant Natural := Homonym_Suffix_Length (E);
-
begin
for J in Predef_Names_95'Range loop
Get_Name_String (Predef_Names_95 (J));
- if Full_Name'Last - Suffix_Length > Name_Len
+ -- The predefined primitive operations are identified by the
+ -- names "_size", "_alignment", etc. If we try a pattern
+ -- matching against this string, we can wrongly match other
+ -- primitive operations like "get_size". To avoid this, we
+ -- add the "__" scope separator, which can only prepend
+ -- predefined primitive operations because other primitive
+ -- operations can neither start with an underline nor
+ -- contain two consecutive underlines in its name.
+
+ if Full_Name'Last - Suffix_Length > Name_Len + 2
and then
Full_Name
- (Full_Name'Last - Name_Len - Suffix_Length + 1
+ (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
.. Full_Name'Last - Suffix_Length) =
- Name_Buffer (1 .. Name_Len)
+ "__" & Name_Buffer (1 .. Name_Len)
then
-- For the equality operator the type of the two operands
-- must also match.
return Predef_Names_95 (J) /= Name_Op_Eq
or else
- Etype (First_Entity (E)) = Etype (Last_Entity (E));
+ Etype (First_Formal (E)) = Etype (Last_Formal (E));
end if;
end loop;
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
for J in Predef_Names_05'Range loop
Get_Name_String (Predef_Names_05 (J));
- if Full_Name'Last - Suffix_Length > Name_Len
+ if Full_Name'Last - Suffix_Length > Name_Len + 2
and then
Full_Name
- (Full_Name'Last - Name_Len - Suffix_Length + 1
+ (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
.. Full_Name'Last - Suffix_Length) =
- Name_Buffer (1 .. Name_Len)
+ "__" & Name_Buffer (1 .. Name_Len)
then
return True;
end if;
or else Entity_Is_In_Main_Unit (Current_Scope)
then
-- Register a copy of the dispatching call node. Needed since the
- -- node containing a dispatching call is rewriten by the expander.
+ -- node containing a dispatching call is rewritten by the
+ -- expander.
declare
Copy : constant Node_Id := New_Copy (N);
+ Par : Node_Id;
begin
- -- Copy the link to the parent to allow climbing up the tree
- -- when the call-graph information is generated
+ -- Determine the enclosing scope to use when generating the
+ -- call graph. This must be done now to avoid problems with
+ -- control structures that may be rewritten during expansion.
+
+ Par := Parent (N);
+ while Nkind (Par) /= N_Subprogram_Body
+ and then Nkind (Parent (Par)) /= N_Compilation_Unit
+ loop
+ Par := Parent (Par);
+ pragma Assert (Present (Par));
+ end loop;
- Set_Parent (Copy, Parent (N));
+ Set_Parent (Copy, Par);
Call_Graph_Nodes.Append (Copy);
end;
end if;
-----------------
function Slot_Number (Prim : Entity_Id) return Uint is
+ E : constant Entity_Id := Ultimate_Alias (Prim);
begin
- if Is_Predefined_Dispatching_Operation (Prim) then
- return -DT_Position (Prim);
+ if Is_Predefined_Dispatching_Operation (E) then
+ return -DT_Position (E);
else
- return DT_Position (Prim);
+ return DT_Position (E);
end if;
end Slot_Number;
Nul : constant Character := Character'First;
Line : String (Str'First .. Str'Last + 1);
Errno : Integer;
+
begin
-- Add the null character to the string as required by fputs
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call);
Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
Prim : constant Entity_Id := Entity (Sinfo.Name (Call));
- P : Node_Id;
+ P : constant Node_Id := Parent (Call);
begin
- -- Locate the enclosing context: a subprogram (if available) or the
- -- enclosing library-level package
-
- P := Parent (Call);
- while Nkind (P) /= N_Subprogram_Body
- and then Nkind (Parent (P)) /= N_Compilation_Unit
- loop
- P := Parent (P);
- pragma Assert (Present (P));
- end loop;
-
Write_Str ("edge: { sourcename: ");
Write_Char ('"');
- Write_Name (Chars (Defining_Entity (P)));
+
+ -- The parent node is the construct that contains the call: subprogram
+ -- body or library-level package. Display the qualified name of the
+ -- entity of the construct. For a subprogram, it is the entity of the
+ -- spec, which carries a homonym counter when it is overloaded.
+
+ if Nkind (P) = N_Subprogram_Body
+ and then not Acts_As_Spec (P)
+ then
+ Get_External_Name (Corresponding_Spec (P), Has_Suffix => False);
+
+ else
+ Get_External_Name (Defining_Entity (P), Has_Suffix => False);
+ end if;
+
+ Write_Str (Name_Buffer (1 .. Name_Len));
if Nkind (P) = N_Package_Declaration then
Write_Str ("___elabs");
and then
Is_Ancestor
(Find_Dispatching_Type (Ultimate_Alias (Prim)),
- Root_Type (Ctrl_Typ))
+ Root_Type (Ctrl_Typ),
+ Use_Full_View => True)
then
- Write_Int (UI_To_Int (Slot_Number (Ultimate_Alias (Prim))));
+ -- This is a special case in which we generate in the ci file the
+ -- slot number of the renaming primitive (i.e. Base2) but instead of
+ -- generating the name of this renaming entity we reference directly
+ -- the renamed entity (i.e. Base).
+
+ Write_Int (UI_To_Int (Slot_Number (Prim)));
Write_Char (':');
Write_Name
(Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
while Present (Elmt) loop
Prim := Node (Elmt);
- -- Display only primitives overriden or defined
+ -- Skip internal entities associated with overridden interface
+ -- primitives, and also inherited primitives.
- if Present (Alias (Prim)) then
+ if Present (Interface_Alias (Prim))
+ or else
+ (Present (Alias (Prim))
+ and then Find_Dispatching_Type (Prim) /=
+ Find_Dispatching_Type (Alias (Prim)))
+ then
goto Continue;
end if;
Write_Int (UI_To_Int (Slot_Number (Prim)));
Write_Char (':');
- Write_Name (Chars (Prim));
+
+ -- Handle renamed primitives
+
+ if Present (Alias (Prim)) then
+ Write_Name (Chars (Ultimate_Alias (Prim)));
+ else
+ Write_Name (Chars (Prim));
+ end if;
-- Display overriding of parent primitives
if Present (Overridden_Operation (Prim))
and then
Is_Ancestor
- (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ)
+ (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
+ Use_Full_View => True)
then
Write_Char (',');
Write_Int
Prim_Op := Node (Prim_Elmt);
Int_Alias := Interface_Alias (Prim_Op);
- if Present (Int_Alias) and then (Alias (Prim_Op)) = Prim then
+ if Present (Int_Alias)
+ and then
+ not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
+ Use_Full_View => True)
+ and then (Alias (Prim_Op)) = Prim
+ then
Write_Char (',');
Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
Write_Char (':');
OSDN Git Service
