OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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:
Ed Schonberg 2008-04-08 08:52:41 +02:00 committed by Arnaud Charlet
parent 99cf6c77d0
commit f7d5442e99
3 changed files with 106 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/lib-xref.adb
View File

@ -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 ('<');

73
gcc/ada/sem_ch7.adb
View File

@ -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

14
gcc/ada/sem_disp.adb
View File

@ -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;