diff options
Diffstat (limited to 'gcc/ada/lib-xref.adb')
| -rw-r--r-- | gcc/ada/lib-xref.adb | 154 |
1 files changed, 114 insertions, 40 deletions
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index c12f794..b0a96af 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -44,7 +44,7 @@ with Stand; use Stand; with Table; use Table; with Widechar; use Widechar; -with GNAT.Heap_Sort_A; +with GNAT.Heap_Sort_G; package body Lib.Xref is @@ -200,11 +200,11 @@ package body Lib.Xref is ------------------------ 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; @@ -212,18 +212,25 @@ package body Lib.Xref is Def : Source_Ptr; Ent : Entity_Id; + Kind : Entity_Kind; + Call : Node_Id; + -- Arguments used in call to Find_Actual_Mode + function Is_On_LHS (Node : Node_Id) return Boolean; -- Used to check if a node is on the left hand side of an assignment. -- The following cases are handled: -- - -- Variable Node is a direct descendant of an assignment statement. + -- Variable Node is a direct descendant of left hand side of an + -- assignment statement. + -- + -- Prefix Of an indexed or selected component that is present in + -- a subtree rooted by an assignment statement. There is + -- no restriction of nesting of components, thus cases + -- such as A.B (C).D are handled properly. However a prefix + -- of a dereference (either implicit or explicit) is never + -- considered as on a LHS. -- - -- Prefix Of an indexed or selected component that is present in a - -- subtree rooted by an assignment statement. There is no - -- restriction of nesting of components, thus cases such as - -- A.B (C).D are handled properly. - -- However a prefix of a dereference (either implicit or - -- explicit) is never considered as on a LHS. + -- Out param Same as above cases, but OUT parameter --------------- -- Is_On_LHS -- @@ -235,28 +242,41 @@ package body Lib.Xref is -- Sem_Util.May_Be_Lvalue -- Sem_Util.Known_To_Be_Assigned -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context + -- Exp_Smem.Is_Out_Actual function Is_On_LHS (Node : Node_Id) return Boolean is - N : Node_Id := Node; + N : Node_Id; + P : Node_Id; + K : Node_Kind; begin -- Only identifiers are considered, is this necessary??? - if Nkind (N) /= N_Identifier then + if Nkind (Node) /= N_Identifier then return False; end if; - -- Reach the assignment statement subtree root. In the case of a - -- variable being a direct descendant of an assignment statement, - -- the loop is skiped. + -- Immediat return if appeared as OUT parameter - while Nkind (Parent (N)) /= N_Assignment_Statement loop + if Kind = E_Out_Parameter then + return True; + end if; - -- Check whether the parent is a component and the current node - -- is its prefix, but return False if the current node has an - -- access type, as in that case the selected or indexed component - -- is an implicit dereference, and the LHS is the designated - -- object, not the access object. + -- Search for assignment statement subtree root + + N := Node; + loop + P := Parent (N); + K := Nkind (P); + + if K = N_Assignment_Statement then + return Name (P) = N; + + -- Check whether the parent is a component and the current node is + -- its prefix, but return False if the current node has an access + -- type, as in that case the selected or indexed component is an + -- implicit dereference, and the LHS is the designated object, not + -- the access object. -- ??? case of a slice assignment? @@ -267,15 +287,16 @@ package body Lib.Xref is -- dereference. If the dereference is on an LHS, this causes a -- false positive. - if (Nkind (Parent (N)) = N_Selected_Component - or else - Nkind (Parent (N)) = N_Indexed_Component) - and then Prefix (Parent (N)) = N + elsif (K = N_Selected_Component or else K = N_Indexed_Component) + and then Prefix (P) = N and then not (Present (Etype (N)) and then Is_Access_Type (Etype (N))) then - N := Parent (N); + N := P; + + -- All other cases, definitely not on left side + else return False; end if; @@ -290,6 +311,7 @@ package body Lib.Xref is begin pragma Assert (Nkind (E) in N_Entity); + Find_Actual_Mode (N, Kind, Call); -- Check for obsolescent reference to package ASCII. GNAT treats this -- element of annex J specially since in practice, programs make a lot @@ -393,7 +415,18 @@ package body Lib.Xref is if (Ekind (E) = E_Variable or else Is_Formal (E)) and then Is_On_LHS (N) then - Set_Referenced_As_LHS (E); + -- 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. + + if Kind = E_Out_Parameter and not Warn_On_Out_Parameter_Unread then + Set_Referenced (E); + + -- For other cases, set referenced on LHS + + else + Set_Referenced_As_LHS (E); + end if; -- Check for a reference in a pragma that should not count as a -- making the variable referenced for warning purposes. @@ -433,13 +466,49 @@ package body Lib.Xref is then null; - -- Any other occurrence counts as referencing the entity + -- All other cases else - Set_Referenced (E); + -- Special processing for IN OUT and 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)) + 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)) + and then not Is_Intrinsic_Subprogram (Entity (Name (Call))) + and then (Kind /= E_In_Out_Parameter + or else Chars (Name (Call)) /= Name_Free) + then + Set_Referenced_As_LHS (E); + end if; + + -- For IN OUT case, treat as also being normal reference + + if Kind = E_In_Out_Parameter then + Set_Referenced (E); + end if; + + -- Any other occurrence counts as referencing the entity + + else + Set_Referenced (E); + + -- If variable, this is an OK reference after an assignment + -- so we can clear the Last_Assignment indication. - if Ekind (E) = E_Variable then - Set_Last_Assignment (E, Empty); + if Is_Assignable (E) then + Set_Last_Assignment (E, Empty); + end if; end if; end if; @@ -954,11 +1023,14 @@ package body Lib.Xref is Handle_Orphan_Type_References : declare J : Nat; Tref : Entity_Id; - L, R : Character; Indx : Nat; Ent : Entity_Id; Loc : Source_Ptr; + L, R : Character; + pragma Warnings (Off, L); + pragma Warnings (Off, R); + procedure New_Entry (E : Entity_Id); -- Make an additional entry into the Xref table for a type entity -- that is related to the current entity (parent, type ancestor, @@ -1140,6 +1212,8 @@ package body Lib.Xref is procedure Move (From : Natural; To : Natural); -- Move procedure for Sort call + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + -------- -- Lt -- -------- @@ -1230,10 +1304,7 @@ package body Lib.Xref is -- Sort the references - GNAT.Heap_Sort_A.Sort - (Integer (Nrefs), - Move'Unrestricted_Access, - Lt'Unrestricted_Access); + Sorting.Sort (Integer (Nrefs)); -- Eliminate duplicate entries @@ -1272,9 +1343,12 @@ package body Lib.Xref is for Refno in 1 .. Nrefs loop Output_One_Ref : declare P2 : Source_Ptr; + Ent : Entity_Id; + WC : Char_Code; Err : Boolean; - Ent : Entity_Id; + pragma Warnings (Off, WC); + pragma Warnings (Off, Err); XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); -- The current entry to be accessed |