-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
-- --
-- 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- --
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
Table_Increment => Alloc.Xrefs_Increment,
Table_Name => "Xrefs");
+ ------------------------
+ -- Local Subprograms --
+ ------------------------
+
+ procedure Generate_Prim_Op_References (Typ : Entity_Id);
+ -- For a tagged type, generate implicit references to its primitive
+ -- operations, for source navigation. This is done right before emitting
+ -- cross-reference information rather than at the freeze point of the type
+ -- in order to handle late bodies that are primitive operations.
+
-------------------------
-- Generate_Definition --
-------------------------
if Sloc (Entity (N)) /= Standard_Location then
Generate_Reference (Entity (N), N);
- -- A reference to an implicit inequality operator is a also a
- -- reference to the user-defined equality.
+ -- A reference to an implicit inequality operator is also a reference
+ -- to the user-defined equality.
if Nkind (N) = N_Op_Ne
and then not Comes_From_Source (Entity (N))
end if;
end Generate_Operator_Reference;
+ ---------------------------------
+ -- Generate_Prim_Op_References --
+ ---------------------------------
+
+ procedure Generate_Prim_Op_References (Typ : Entity_Id) is
+ Base_T : Entity_Id;
+ Prim : Elmt_Id;
+ Prim_List : Elist_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Handle subtypes of synchronized types
+
+ if Ekind (Typ) = E_Protected_Subtype
+ or else Ekind (Typ) = E_Task_Subtype
+ then
+ Base_T := Etype (Typ);
+ else
+ Base_T := Typ;
+ end if;
+
+ -- References to primitive operations are only relevant for tagged types
+
+ if not Is_Tagged_Type (Base_T)
+ or else Is_Class_Wide_Type (Base_T)
+ then
+ return;
+ end if;
+
+ -- Ada 2005 (AI-345): For synchronized types generate reference
+ -- to the wrapper that allow us to dispatch calls through their
+ -- implemented abstract interface types.
+
+ -- The check for Present here is to protect against previously
+ -- reported critical errors.
+
+ if Is_Concurrent_Type (Base_T)
+ and then Present (Corresponding_Record_Type (Base_T))
+ then
+ Prim_List := Primitive_Operations
+ (Corresponding_Record_Type (Base_T));
+ else
+ Prim_List := Primitive_Operations (Base_T);
+ end if;
+
+ if No (Prim_List) then
+ return;
+ end if;
+
+ Prim := First_Elmt (Prim_List);
+ while Present (Prim) loop
+
+ -- If the operation is derived, get the original for cross-reference
+ -- reference purposes (it is the original for which we want the xref
+ -- and for which the comes_from_source test must be performed).
+
+ Ent := Node (Prim);
+ while Present (Alias (Ent)) loop
+ Ent := Alias (Ent);
+ end loop;
+
+ Generate_Reference (Typ, Ent, 'p', Set_Ref => False);
+ Next_Elmt (Prim);
+ end loop;
+ end Generate_Prim_Op_References;
+
------------------------
-- Generate_Reference --
------------------------
procedure Generate_Reference
- (E : Entity_Id;
- N : Node_Id;
- Typ : Character := 'r';
- Set_Ref : Boolean := True;
- Force : Boolean := False)
+ (E : Entity_Id;
+ N : Node_Id;
+ Typ : Character := 'r';
+ Set_Ref : Boolean := True;
+ Force : Boolean := False)
is
Indx : Nat;
Nod : Node_Id;
Def : Source_Ptr;
Ent : Entity_Id;
+ Call : Node_Id;
+ Formal : Entity_Id;
+ -- Used for call to Find_Actual
+
Kind : Entity_Kind;
- Call : Node_Id;
- -- Arguments used in call to Find_Actual_Mode
+ -- If Formal is non-Empty, then its Ekind, otherwise E_Void
function Is_On_LHS (Node : Node_Id) return Boolean;
-- Used to check if a node is on the left hand side of an assignment.
--
-- Out param Same as above cases, but OUT parameter
+ function OK_To_Set_Referenced return Boolean;
+ -- Returns True if the Referenced flag can be set. There are a few
+ -- exceptions where we do not want to set this flag, see body for
+ -- details of these exceptional cases.
+
---------------
-- Is_On_LHS --
---------------
return False;
end if;
- -- Immediat return if appeared as OUT parameter
+ -- Immediate return if appeared as OUT parameter
if Kind = E_Out_Parameter then
return True;
return False;
end if;
end loop;
+ end Is_On_LHS;
- -- Parent (N) is assignment statement, check whether N is its name
+ ---------------------------
+ -- OK_To_Set_Referenced --
+ ---------------------------
- return Name (Parent (N)) = N;
- end Is_On_LHS;
+ function OK_To_Set_Referenced return Boolean is
+ P : Node_Id;
+
+ begin
+ -- A reference from a pragma Unreferenced or pragma Unmodified or
+ -- pragma Warnings does not cause the Referenced flag to be set.
+ -- This avoids silly warnings about things being referenced and
+ -- not assigned when the only reference is from the pragma.
+
+ if Nkind (N) = N_Identifier then
+ P := Parent (N);
+
+ if Nkind (P) = N_Pragma_Argument_Association then
+ P := Parent (P);
+
+ if Nkind (P) = N_Pragma then
+ if Pragma_Name (P) = Name_Warnings
+ or else
+ Pragma_Name (P) = Name_Unmodified
+ or else
+ Pragma_Name (P) = Name_Unreferenced
+ then
+ return False;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ return True;
+ end OK_To_Set_Referenced;
-- Start of processing for Generate_Reference
begin
pragma Assert (Nkind (E) in N_Entity);
- Find_Actual_Mode (N, Kind, Call);
+ Find_Actual (N, Formal, Call);
+
+ if Present (Formal) then
+ Kind := Ekind (Formal);
+ else
+ Kind := E_Void;
+ end if;
-- Check for obsolescent reference to package ASCII. GNAT treats this
-- element of annex J specially since in practice, programs make a lot
if Set_Ref then
- -- For a variable that appears on the left side of an assignment
- -- statement, we set the Referenced_As_LHS flag since this is indeed
- -- a left hand side. We also set the Referenced_As_LHS flag of a
- -- prefix of selected or indexed component.
+ -- Assignable object appearing on left side of assignment or as
+ -- an out parameter.
- if (Ekind (E) = E_Variable or else Is_Formal (E))
+ if Is_Assignable (E)
and then Is_On_LHS (N)
+ and then Ekind (E) /= E_In_Out_Parameter
then
- -- If we have the OUT parameter case and the warning mode for
- -- OUT parameters is not set, treat this as an ordinary reference
- -- since we don't want warnings about it being unset.
+ -- For objects that are renamings, just set as simply referenced
+ -- we do not try to do assignment type tracking in this case.
- if Kind = E_Out_Parameter and not Warn_On_Out_Parameter_Unread then
+ if Present (Renamed_Object (E)) then
Set_Referenced (E);
- -- For other cases, set referenced on LHS
+ -- Out parameter case
+
+ elsif Kind = E_Out_Parameter then
+
+ -- If warning mode for all out parameters is set, or this is
+ -- the only warning parameter, then we want to mark this for
+ -- later warning logic by setting Referenced_As_Out_Parameter
+
+ if Warn_On_Modified_As_Out_Parameter (Formal) then
+ Set_Referenced_As_Out_Parameter (E, True);
+ Set_Referenced_As_LHS (E, False);
+
+ -- For OUT parameter not covered by the above cases, we simply
+ -- regard it as a normal reference (in this case we do not
+ -- want any of the warning machinery for out parameters).
+
+ else
+ Set_Referenced (E);
+ end if;
+
+ -- For the left hand of an assignment case, we do nothing here.
+ -- The processing for Analyze_Assignment_Statement will set the
+ -- Referenced_As_LHS flag.
else
- Set_Referenced_As_LHS (E);
+ null;
end if;
-- Check for a reference in a pragma that should not count as a
-- All other cases
else
- -- Special processing for IN OUT and OUT parameters, where we
- -- have an implicit assignment to a simple variable.
+ -- Special processing for IN OUT parameters, where we have an
+ -- implicit assignment to a simple variable.
- if (Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter)
- and then Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Assignable (Entity (N))
+ if Kind = E_In_Out_Parameter
+ and then Is_Assignable (E)
then
- -- Record implicit assignment unless we have an intrinsic
- -- subprogram, which is most likely an instantiation of
- -- Unchecked_Deallocation which we do not want to consider
- -- as an assignment since it generates false positives. We
- -- also exclude the case of an IN OUT parameter to a procedure
- -- called Free, since we suspect similar semantics.
-
- if Is_Entity_Name (Name (Call))
+ -- For sure this counts as a normal read reference
+
+ Set_Referenced (E);
+ Set_Last_Assignment (E, Empty);
+
+ -- We count it as being referenced as an out parameter if the
+ -- option is set to warn on all out parameters, except that we
+ -- have a special exclusion for an intrinsic subprogram, which
+ -- is most likely an instantiation of Unchecked_Deallocation
+ -- which we do not want to consider as an assignment since it
+ -- generates false positives. We also exclude the case of an
+ -- IN OUT parameter if the name of the procedure is Free,
+ -- since we suspect similar semantics.
+
+ if Warn_On_All_Unread_Out_Parameters
+ and then Is_Entity_Name (Name (Call))
and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
- and then (Kind /= E_In_Out_Parameter
- or else Chars (Name (Call)) /= Name_Free)
+ and then Chars (Name (Call)) /= Name_Free
then
- Set_Referenced_As_LHS (E);
+ Set_Referenced_As_Out_Parameter (E, True);
+ Set_Referenced_As_LHS (E, False);
end if;
- -- For IN OUT case, treat as also being normal reference
+ -- Don't count a recursive reference within a subprogram as a
+ -- reference (that allows detection of a recursive subprogram
+ -- whose only references are recursive calls as unreferenced).
- if Kind = E_In_Out_Parameter then
- Set_Referenced (E);
- end if;
+ elsif Is_Subprogram (E)
+ and then E = Nearest_Dynamic_Scope (Current_Scope)
+ then
+ null;
- -- Any other occurrence counts as referencing the entity
+ -- Any other occurrence counts as referencing the entity
- else
+ elsif OK_To_Set_Referenced then
Set_Referenced (E);
-- If variable, this is an OK reference after an assignment
-- Check for pragma Unreferenced given and reference is within
-- this source unit (occasion for possible warning to be issued).
- if Has_Pragma_Unreferenced (E)
+ if Has_Unreferenced (E)
and then In_Same_Extended_Unit (E, N)
then
-- A reference as a named parameter in a call does not count
while Present (BE) loop
if Chars (BE) = Chars (E) then
Error_Msg_NE
- ("?pragma Unreferenced given for&", N, BE);
+ ("?pragma Unreferenced given for&!", N, BE);
exit;
end if;
-- Here we issue the warning, since this is a real reference
else
- Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
+ Error_Msg_NE ("?pragma Unreferenced given for&!", N, E);
end if;
end if;
and then Sloc (E) > No_Location
and then Sloc (N) > No_Location
- -- We ignore references from within an instance
+ -- We ignore references from within an instance, except for default
+ -- subprograms, for which we generate an implicit reference.
- and then Instantiation_Location (Sloc (N)) = No_Location
+ and then
+ (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i')
-- Ignore dummy references
then
Ent := Original_Record_Component (E);
+ -- If this is an expanded reference to a discriminant, recover the
+ -- original discriminant, which gets the reference.
+
+ elsif Ekind (E) = E_In_Parameter
+ and then Present (Discriminal_Link (E))
+ then
+ Ent := Discriminal_Link (E);
+ Set_Referenced (Ent);
+
-- Ignore reference to any other entity that is not from source
else
-- set to Empty, and Left/Right are set to space.
procedure Output_Import_Export_Info (Ent : Entity_Id);
- -- Ouput language and external name information for an interfaced
+ -- Output language and external name information for an interfaced
-- entity, using the format <language, external_name>,
------------------------
return;
end if;
+ -- First we add references to the primitive operations of tagged
+ -- types declared in the main unit.
+
+ Handle_Prim_Ops : declare
+ Ent : Entity_Id;
+
+ begin
+ for J in 1 .. Xrefs.Last loop
+ Ent := Xrefs.Table (J).Ent;
+
+ if Is_Type (Ent)
+ and then Is_Tagged_Type (Ent)
+ and then Ent = Base_Type (Ent)
+ and then In_Extended_Main_Source_Unit (Ent)
+ then
+ Generate_Prim_Op_References (Ent);
+ end if;
+ end loop;
+ end Handle_Prim_Ops;
+
-- Before we go ahead and output the references we have a problem
-- that needs dealing with. So far we have captured things that are
-- definitely referenced by the main unit, or defined in the main
New_Entry (Tref);
if Is_Record_Type (Ent)
- and then Present (Abstract_Interfaces (Ent))
+ and then Present (Interfaces (Ent))
then
-- Add an entry for each one of the given interfaces
-- implemented by type Ent.
declare
- Elmt : Elmt_Id;
-
+ Elmt : Elmt_Id := First_Elmt (Interfaces (Ent));
begin
- Elmt := First_Elmt (Abstract_Interfaces (Ent));
while Present (Elmt) loop
New_Entry (Node (Elmt));
Next_Elmt (Elmt);
function Parent_Op (E : Entity_Id) return Entity_Id is
Orig_Op : constant Entity_Id := Alias (E);
+
begin
if No (Orig_Op) then
return Empty;
+
elsif not Comes_From_Source (E)
and then not Has_Xref_Entry (Orig_Op)
and then Comes_From_Source (Orig_Op)
if Name_Len /= Curlen then
return True;
-
else
return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
end if;
-- Used for {} or <> or () for type reference
procedure Check_Type_Reference
- (Ent : Entity_Id;
+ (Ent : Entity_Id;
List_Interface : Boolean);
-- Find whether there is a meaningful type reference for
-- Ent, and display it accordingly. If List_Interface is
--------------------------
procedure Check_Type_Reference
- (Ent : Entity_Id;
+ (Ent : Entity_Id;
List_Interface : Boolean)
is
begin
(Int (Get_Logical_Line_Number (Sloc (Tref))));
declare
- Ent : Entity_Id := Tref;
- Kind : constant Entity_Kind := Ekind (Ent);
- Ctyp : Character := Xref_Entity_Letters (Kind);
+ Ent : Entity_Id;
+ Ctyp : Character;
begin
+ Ent := Tref;
+ Ctyp := Xref_Entity_Letters (Ekind (Ent));
+
if Ctyp = '+'
and then Present (Full_View (Ent))
then
--------------------------
procedure Output_Overridden_Op (Old_E : Entity_Id) is
+ Op : Entity_Id;
+
begin
- if Present (Old_E)
- and then Sloc (Old_E) /= Standard_Location
+ -- The overridden operation has an implicit declaration
+ -- at the point of derivation. What we want to display
+ -- is the original operation, which has the actual body
+ -- (or abstract declaration) that is being overridden.
+ -- The overridden operation is not always set, e.g. when
+ -- it is a predefined operator.
+
+ if No (Old_E) then
+ return;
+
+ -- Follow alias chain if one is present
+
+ elsif Present (Alias (Old_E)) then
+
+ -- The subprogram may have been implicitly inherited
+ -- through several levels of derivation, so find the
+ -- ultimate (source) ancestor.
+
+ Op := Alias (Old_E);
+ while Present (Alias (Op)) loop
+ Op := Alias (Op);
+ end loop;
+
+ -- Normal case of no alias present
+
+ else
+ Op := Old_E;
+ end if;
+
+ if Present (Op)
+ and then Sloc (Op) /= Standard_Location
then
declare
- Loc : constant Source_Ptr := Sloc (Old_E);
+ Loc : constant Source_Ptr := Sloc (Op);
Par_Unit : constant Unit_Number_Type :=
Get_Source_Unit (Loc);
+
begin
Write_Info_Char ('<');
Par : Node_Id;
begin
- if Ekind (Scope (E)) /= E_Generic_Package then
+ -- The Present check here is an error defense
+
+ if Present (Scope (E))
+ and then Ekind (Scope (E)) /= E_Generic_Package
+ then
return False;
end if;
begin
Write_Info_Char ('[');
+
if Curru /= Gen_U then
Write_Info_Nat (Dependency_Num (Gen_U));
Write_Info_Char ('|');
-- Additional information for types with progenitors
if Is_Record_Type (XE.Ent)
- and then Present (Abstract_Interfaces (XE.Ent))
+ and then Present (Interfaces (XE.Ent))
then
declare
- Elmt : Elmt_Id;
-
+ Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
begin
- Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
while Present (Elmt) loop
Check_Type_Reference (Node (Elmt), True);
Next_Elmt (Elmt);
Output_Import_Export_Info (XE.Ent);
end if;
- Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
+ Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
Output_Instantiation_Refs (Sloc (XE.Ent));
end if;
projects / platform / upstream / gcc.git / blobdiff