lib-xref.adb (Is_On_LHS): Remove dead code
2008-04-08 Ed Schonberg <schonberg@adacore.com> Robert Dewar <dewar@adacore.com> Gary Dismukes <dismukes@adacore.com> * 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
This commit is contained in:
parent
99cf6c77d0
commit
f7d5442e99
|
@ -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 ('<');
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
Loading…
Reference in New Issue