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

sem_disp.adb (Check_Dispatching_Operation): Do not flag subprograms inherited from an interface ancestor by another... 

2006-10-31  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_disp.adb (Check_Dispatching_Operation): Do not flag subprograms
	inherited from an interface ancestor by another interface in the
	context of an instance as 'late'.
	(Is_Tag_Indeterminate, Propagate_Tag): Handle properly the dereference
	of a call to a function that dispatches on access result.
	(Check_Dispatching_Operation): In case of late overriding of a primitive
	that covers abstract interface subprograms we register it in all the
	secondary dispatch tables associated with abstract interfaces.
	(Check_Dispatching_Call): Add check that a dispatching call is not made
	to a function with a controlling result of a limited type. This is a
	current implementation restriction.
	(Check_Controlling_Formal): Remove bogus checks for E.2.2(14).
	(Check_Dispatching_Operation): Do no emit a warning if the controlling
	argument is an interface type that is a generic formal.
	(Is_Interface_Subprogram): Removed.
	(Check_Dispatching_Operation): If the subprogram is not a dispatching
	operation, check the formals to handle the case in which it is
	associated with an abstract interface type.

From-SVN: r118308
This commit is contained in:
Hristian Kirtchev 2006-10-31 19:09:03 +01:00 committed by Arnaud Charlet
parent 3100e48f7c
commit 67f3c450aa
1 changed files with 169 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

294
gcc/ada/sem_disp.adb
View File

@ -29,9 +29,9 @@ with Debug; use Debug;
with Elists; use Elists;
with Einfo; use Einfo;
with Exp_Disp; use Exp_Disp;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
@ -94,10 +94,6 @@ package body Sem_Disp is
is
Formal : Entity_Id;
Ctrl_Type : Entity_Id;
Remote : constant Boolean :=
Is_Remote_Types (Current_Scope)
and then Comes_From_Source (Subp)
and then Scope (Typ) = Current_Scope;
begin
Formal := First_Formal (Subp);
@ -109,9 +105,9 @@ package body Sem_Disp is
if Ctrl_Type = Typ then
Set_Is_Controlling_Formal (Formal);
-- Ada 2005 (AI-231):Anonymous access types used in controlling
-- parameters exclude null because it is necessary to read the
-- tag to dispatch, and null has no tag.
-- Ada 2005 (AI-231): Anonymous access types used in
-- controlling parameters exclude null because it is necessary
-- to read the tag to dispatch, and null has no tag.
if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
Set_Can_Never_Be_Null (Etype (Formal));
@ -153,16 +149,6 @@ package body Sem_Disp is
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
-- Verify that the restriction in E.2.2 (14) is obeyed
elsif Remote
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
then
Error_Msg_N
("access parameter of remote object primitive"
& " must be controlling",
Formal);
end if;
Next_Formal (Formal);
@ -175,8 +161,7 @@ package body Sem_Disp is
if Ctrl_Type = Typ then
Set_Has_Controlling_Result (Subp);
-- Check that the result subtype statically matches
-- the first subtype.
-- Check that result subtype statically matches first subtype
if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
Error_Msg_N
@ -187,18 +172,6 @@ package body Sem_Disp is
Error_Msg_N
("operation can be dispatching in only one type", Subp);
end if;
-- The following check is clearly required, although the RM says
-- nothing about return types. If the return type is a limited
-- class-wide type declared in the current scope, there is no way
-- to declare stream procedures for it, so the return cannot be
-- marshalled.
elsif Remote
and then Is_Limited_Type (Typ)
and then Etype (Subp) = Class_Wide_Type (Typ)
then
Error_Msg_N ("return type has no stream attributes", Subp);
end if;
end if;
end Check_Controlling_Formals;
@ -456,6 +429,25 @@ package body Sem_Disp is
Set_Controlling_Argument (N, Control);
-- Ada 2005 (AI-318-02): Check current implementation restriction
-- that a dispatching call cannot be made to a primitive function
-- with a limited result type. This restriction can be removed
-- once calls to limited functions with class-wide results are
-- supported. ???
if Ada_Version = Ada_05
and then Nkind (N) = N_Function_Call
then
Func := Entity (Name (N));
if Has_Controlling_Result (Func)
and then Is_Limited_Type (Etype (Func))
then
Error_Msg_N ("(Ada 2005) limited function call in this" &
" context is not yet implemented", N);
end if;
end if;
else
-- The call is not dispatching, so check that there aren't any
-- tag-indeterminate abstract calls left.
@ -574,6 +566,61 @@ package body Sem_Disp is
and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
-- Ada 2005 (AI-251): Check that Subp is not a primitive associated
-- with an abstract interface type unless the interface acts as a
-- parent type in a derivation. If the interface type is a formal
-- type then the operation is not primitive and therefore legal.
declare
E : Entity_Id;
Typ : Entity_Id;
begin
E := First_Entity (Subp);
while Present (E) loop
if Is_Access_Type (Etype (E)) then
Typ := Designated_Type (Etype (E));
else
Typ := Etype (E);
end if;
if not Is_Class_Wide_Type (Typ)
and then Is_Interface (Typ)
and then not Is_Derived_Type (Typ)
and then not Is_Generic_Type (Typ)
then
Error_Msg_N ("?declaration of& is too late!", Subp);
Error_Msg_NE
("\spec should appear immediately after declaration of &!",
Subp, Typ);
exit;
end if;
Next_Entity (E);
end loop;
-- In case of functions check also the result type
if Ekind (Subp) = E_Function then
if Is_Access_Type (Etype (Subp)) then
Typ := Designated_Type (Etype (Subp));
else
Typ := Etype (Subp);
end if;
if not Is_Class_Wide_Type (Typ)
and then Is_Interface (Typ)
and then not Is_Derived_Type (Typ)
then
Error_Msg_N ("?declaration of& is too late!", Subp);
Error_Msg_NE
("\spec should appear immediately after declaration of &!",
Subp, Typ);
end if;
end if;
end;
return;
-- The subprograms build internally after the freezing point (such as
@ -744,6 +791,41 @@ package body Sem_Disp is
else
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Set_Is_Overriding_Operation (Subp);
-- Ada 2005 (AI-251): In case of late overriding of a primitive
-- that covers abstract interface subprograms we must register it
-- in all the secondary dispatch tables associated with abstract
-- interfaces.
if Body_Is_Last_Primitive then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Elmt : Elmt_Id;
Prim : Node_Id;
begin
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
Prim := Node (Elmt);
if Present (Alias (Prim))
and then Present (Abstract_Interface_Alias (Prim))
and then Alias (Prim) = Subp
then
Register_Interface_DT_Entry (Subp_Body, Prim);
end if;
Next_Elmt (Elmt);
end loop;
-- Redisplay the contents of the updated dispatch table.
if Debug_Flag_ZZ then
Write_Str ("Late overriding: ");
Write_DT (Tagged_Type);
end if;
end;
end if;
end if;
-- If no old subprogram, then we add this as a dispatching operation,
@ -815,7 +897,7 @@ package body Sem_Disp is
-- The new operation is added to the actions of the freeze
-- node for the type, but this node has already been analyzed,
-- so we must retrieve and analyze explicitly the one new body,
-- so we must retrieve and analyze explicitly the new body.
if Present (F_Node)
and then Present (Actions (F_Node))
@ -1176,6 +1258,16 @@ package body Sem_Disp is
Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
then
return True;
-- In Ada 2005 a function that returns an anonymous access type can
-- dispatching, and the dereference of a call to such a function
-- is also tag-indeterminate.
elsif Nkind (Orig_Node) = N_Explicit_Dereference
and then Ada_Version >= Ada_05
then
return Is_Tag_Indeterminate (Prefix (Orig_Node));
else
return False;
end if;
@ -1190,38 +1282,8 @@ package body Sem_Disp is
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
Elmt : Elmt_Id;
Found : Boolean;
E : Entity_Id;
function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
-- Traverse the list of aliased entities to check if the overriden
-- entity corresponds with a primitive operation of an abstract
-- interface type.
-----------------------------
-- Is_Interface_Subprogram --
-----------------------------
function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is
Aux : Entity_Id;
begin
Aux := Op;
while Present (Alias (Aux))
and then Present (DTC_Entity (Alias (Aux)))
loop
if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then
return True;
end if;
Aux := Alias (Aux);
end loop;
return False;
end Is_Interface_Subprogram;
-- Start of processing for Override_Dispatching_Operation
Elmt : Elmt_Id;
Prim : Node_Id;
begin
-- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
@ -1232,79 +1294,52 @@ package body Sem_Disp is
Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
end if;
-- Patch the primitive operation list
while Present (Op_Elmt)
and then Node (Op_Elmt) /= Prev_Op
loop
Next_Elmt (Op_Elmt);
end loop;
-- If there is no previous operation to override, the type declaration
-- was malformed, and an error must have been emitted already.
if No (Op_Elmt) then
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt)
and then Node (Elmt) /= Prev_Op
loop
Next_Elmt (Elmt);
end loop;
if No (Elmt) then
return;
end if;
-- Ada 2005 (AI-251): Do not replace subprograms inherited from
-- abstract interfaces. They will be used later to generate the
-- corresponding thunks to initialize the Vtable (see subprogram
-- Freeze_Subprogram). The inherited operation itself must also
-- become hidden, to avoid spurious ambiguities; name resolution
-- must pick up only the operation that implements it,
Replace_Elmt (Elmt, New_Op);
if Is_Interface_Subprogram (Prev_Op) then
Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op)));
Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op));
Set_Is_Overriding_Operation (Prev_Op);
if Ada_Version >= Ada_05
and then Has_Abstract_Interfaces (Tagged_Type)
then
-- Ada 2005 (AI-251): Update the attribute alias of all the aliased
-- entities of the overriden primitive to reference New_Op, and also
-- propagate them the new value of the attribute Is_Abstract.
-- Traverse the list of aliased entities to look for the overriden
-- abstract interface subprogram.
E := Alias (Prev_Op);
while Present (Alias (E))
and then Present (DTC_Entity (E))
and then not (Is_Abstract (E))
and then not Is_Interface (Scope (DTC_Entity (E)))
loop
E := Alias (E);
end loop;
Set_Abstract_Interface_Alias (Prev_Op, E);
Set_Alias (Prev_Op, New_Op);
Set_Is_Internal (Prev_Op);
Set_Is_Hidden (Prev_Op);
-- Override predefined primitive operations
if Is_Predefined_Dispatching_Operation (Prev_Op) then
Replace_Elmt (Op_Elmt, New_Op);
return;
end if;
-- Check if this primitive operation was previously added for another
-- interface.
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
Found := False;
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
if Node (Elmt) = New_Op then
Found := True;
exit;
Prim := Node (Elmt);
if Prim = New_Op then
null;
elsif Present (Abstract_Interface_Alias (Prim))
and then Alias (Prim) = Prev_Op
then
Set_Alias (Prim, New_Op);
Set_Is_Abstract (Prim, Is_Abstract (New_Op));
-- Ensure that this entity will be expanded to fill the
-- corresponding entry in its dispatch table.
if not Is_Abstract (Prim) then
Set_Has_Delayed_Freeze (Prim);
end if;
end if;
Next_Elmt (Elmt);
end loop;
if not Found then
Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
end if;
return;
else
Replace_Elmt (Op_Elmt, New_Op);
end if;
if (not Is_Package_Or_Generic_Package (Current_Scope))
@ -1350,6 +1385,15 @@ package body Sem_Disp is
Call_Node := Expression (Parent (Entity (Actual)));
-- Ada 2005: If this is a dereference of a call to a function with a
-- dispatching access-result, the tag is propagated when the dereference
-- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
elsif Nkind (Actual) = N_Explicit_Dereference
and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
then
return;
-- Only other possibilities are parenthesized or qualified expression,
-- or an expander-generated unchecked conversion of a function call to
-- a stream Input attribute.