From: Ed Schonberg Date: Tue, 8 Apr 2008 06:52:41 +0000 (+0200) Subject: lib-xref.adb (Is_On_LHS): Remove dead code X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f7d5442e99264f95e19868931a0ec530f26a19f5;p=gcc.git lib-xref.adb (Is_On_LHS): Remove dead code 2008-04-08 Ed Schonberg Robert Dewar Gary Dismukes * lib-xref.adb (Is_On_LHS): Remove dead code (Output_Overriden_Op): If the overridden operation is itself inherited, list the ancestor operation, which is the one whose body or absstract specification is actually being overridden. * sem_ch7.adb (Is_Primitive_Of): use base type to determine whether operation is primitive for the type. (Declare_Inherited_Private_Subprograms): If the new operation overrides an inherited private subprogram, set properly the Overridden_Operation attribute, for better cross-reference information. (Analyze_Package_Specification): Do late analysis of spec PPCs (Install_Private_Declaration, Uninstall_Declarations): Save/restore properly the full view and underlying full views of a private type in a child unit, whose full view is derived from a private type in a parent unit, and whose own full view becomes visible in the child body. * sem_disp.adb (Check_Dispatching_Operation): When a body declares a primitive operation after the type has been frozen, add an explicit reference to the type and the operation, because other primitive references have been emitted already. (Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a dispatching call on VM targets. From-SVN: r134038 --- diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 690cde9eb62..a7cc61a06e1 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -309,10 +309,6 @@ package body Lib.Xref is return False; end if; end loop; - - -- Parent (N) is assignment statement, check whether N is its name - - return Name (Parent (N)) = N; end Is_On_LHS; --------------------------- @@ -1579,14 +1575,34 @@ package body Lib.Xref is -------------------------- 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; + + elsif Present (Alias (Old_E)) then + Op := Alias (Old_E); + + 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 ('<'); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2e95a1f5f43..ebeec699183 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -51,6 +51,7 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; +with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; @@ -757,6 +758,12 @@ package body Sem_Ch7 is -- private_with_clauses, and remove them at the end of the nested -- package. + procedure Analyze_PPCs (Decls : List_Id); + -- Given a list of declarations, go through looking for subprogram + -- specs, and for each one found, analyze any pre/postconditions that + -- are chained to the spec. This is the implementation of the late + -- visibility analysis for preconditions and postconditions in specs. + procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); -- Clears constant indications (Never_Set_In_Source, Constant_Value, -- and Is_True_Constant) on all variables that are entities of Id, @@ -785,6 +792,33 @@ package body Sem_Ch7 is -- private part rather than being done in Sem_Ch12.Install_Parent -- (which is where the parents' visible declarations are installed). + ------------------ + -- Analyze_PPCs -- + ------------------ + + procedure Analyze_PPCs (Decls : List_Id) is + Decl : Node_Id; + Spec : Node_Id; + Sent : Entity_Id; + Prag : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then + Spec := Specification (Original_Node (Decl)); + Sent := Defining_Unit_Name (Spec); + Prag := Spec_PPC_List (Sent); + while Present (Prag) loop + Analyze_PPC_In_Decl_Part (Prag, Sent); + Prag := Next_Pragma (Prag); + end loop; + end if; + + Next (Decl); + end loop; + end Analyze_PPCs; + --------------------- -- Clear_Constants -- --------------------- @@ -937,9 +971,9 @@ package body Sem_Ch7 is begin Inst_Par := Inst_Id; + Gen_Par := Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); - while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop Inst_Node := Get_Package_Instantiation_Node (Inst_Par); @@ -1017,6 +1051,7 @@ package body Sem_Ch7 is begin if Present (Vis_Decls) then Analyze_Declarations (Vis_Decls); + Analyze_PPCs (Vis_Decls); end if; -- Verify that incomplete types have received full declarations @@ -1152,6 +1187,7 @@ package body Sem_Ch7 is end if; Analyze_Declarations (Priv_Decls); + Analyze_PPCs (Priv_Decls); -- Check the private declarations for incomplete deferred constants @@ -1345,13 +1381,17 @@ package body Sem_Ch7 is Formal : Entity_Id; begin - if Etype (S) = T then + -- If the full view is a scalar type, the type is the anonymous + -- base type, but the operation mentions the first subtype, so + -- check the signature againt the base type. + + if Base_Type (Etype (S)) = Base_Type (T) then return True; else Formal := First_Formal (S); while Present (Formal) loop - if Etype (Formal) = T then + if Base_Type (Etype (Formal)) = Base_Type (T) then return True; end if; @@ -1427,6 +1467,7 @@ package body Sem_Ch7 is Replace_Elmt (Op_Elmt, New_Op); Remove_Elmt (Op_List, Op_Elmt_2); Set_Is_Overriding_Operation (New_Op); + Set_Overridden_Operation (New_Op, Parent_Subp); -- We don't need to inherit its dispatching slot. -- Set_All_DT_Position has previously ensured that @@ -1664,11 +1705,18 @@ package body Sem_Ch7 is -- when the parent type is defined in the parent unit. At this -- point the current type is not private either, and we have to -- install the underlying full view, which is now visible. + -- Save the current full view as well, so that all views can + -- be restored on exit. It may seem that after compiling the + -- child body there are not environments to restore, but the + -- back-end expects those links to be valid, and freeze nodes + -- depend on them. if No (Full_View (Full)) and then Present (Underlying_Full_View (Full)) then Set_Full_View (Id, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Id, Full); + Set_Underlying_Full_View (Full, Empty); Set_Is_Frozen (Full_View (Id)); end if; @@ -2153,7 +2201,8 @@ package body Sem_Ch7 is end if; -- Make private entities invisible and exchange full and private - -- declarations for private types. + -- declarations for private types. Id is now the first private + -- entity in the package. while Present (Id) loop if Debug_Flag_E then @@ -2240,6 +2289,22 @@ package body Sem_Ch7 is Exchange_Declarations (Id); + -- If we have installed an underlying full view for a type + -- derived from a private type in a child unit, restore the + -- proper views of private and full view. See corresponding + -- code in Install_Private_Declarations. + -- After the exchange, Full denotes the private type in the + -- visible part of the package. + + if Is_Private_Base_Type (Full) + and then Present (Full_View (Full)) + and then Present (Underlying_Full_View (Full)) + and then In_Package_Body (Current_Scope) + then + Set_Full_View (Full, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Full, Empty); + end if; + elsif Ekind (Id) = E_Incomplete_Type and then No (Full_View (Id)) then diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 1652a82fc67..c990800ac56 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -31,6 +31,7 @@ with Exp_Disp; use Exp_Disp; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Errout; use Errout; +with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -790,6 +791,9 @@ package body Sem_Disp is -- if the subprogram is already frozen, we must update -- its dispatching information explicitly here. The -- information is taken from the overridden subprogram. + -- We must also generate a cross-reference entry because + -- references to other primitives were already created + -- when type was frozen. Body_Is_Last_Primitive := True; @@ -819,6 +823,8 @@ package body Sem_Disp is Prim => Subp, Ins_Nod => Subp_Body); end if; + + Generate_Reference (Tagged_Type, Subp, 'p', False); end if; end if; end if; @@ -1543,6 +1549,14 @@ package body Sem_Disp is if VM_Target = No_VM then Expand_Dispatching_Call (Call_Node); + + -- Expansion of a dispatching call results in an indirect call, which in + -- turn causes current values to be killed (see Resolve_Call), so on VM + -- targets we do the call here to ensure consistent warnings between VM + -- and non-VM targets. + + else + Kill_Current_Values; end if; end Propagate_Tag;