FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_ch9.adb (Analyze_Protected_Definition): Remove call to Check_Overriding_Indicator.

Browse source 
2006-10-31  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch9.adb (Analyze_Protected_Definition): Remove call to
	Check_Overriding_Indicator.
	(Analyze_Task_Definition): Ditto.
	(Analyze_Protected_Type, Analyze_Task_Type): Code cleanup.
	(Check_Overriding_Indicator): To find overridden interface operation,
	examine only homonyms that have an explicit subprogram declaration, not
	inherited operations created by an unrelated type derivation.
	(Check_Overriding_Indicator): When checking for the presence of "null"
	in a procedure, ensure that the queried node is a procedure
	specification.
	(Matches_Prefixed_View_Profile): Add mechanism to retrieve the parameter
	type when the formal is an access to variable.
	(Analyze_Protected_Type): Add check for Preelaborable_Initialization
	(Analyze_Task_Type): Same addition
	(Analyze_Entry_Declaration): Call Generate_Reference_To_Formals, to
	provide navigation capabilities for entries.

From-SVN: r118307
This commit is contained in:
Hristian Kirtchev 2006-10-31 19:08:46 +01:00 • committed by Arnaud Charlet
parent 923fa078d5
commit 3100e48f7c
1 changed files with 50 additions and 283 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

333
gcc/ada/sem_ch9.adb
View file

@ -68,11 +68,6 @@ package body Sem_Ch9 is
-- count the entries (checking the static requirement), and compare with
-- the given maximum.
procedure Check_Overriding_Indicator (Def : Node_Id);
-- Ada 2005 (AI-397): Check the overriding indicator of entries and
-- subprograms of protected or task types. Def is the definition of the
-- protected or task type.
function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
@ -404,9 +399,8 @@ package body Sem_Ch9 is
-- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
-- fields on all entry formals (this loop ignores all other entities).
-- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that we
-- can post accurate warnings on each accept statement for the same
-- entry.
-- Reset Referenced and Has_Pragma_Unreferenced as well, so that we can
-- post accurate warnings on each accept statement for the same entry.
E := First_Entity (Entry_Nam);
while Present (E) loop
@ -927,6 +921,8 @@ package body Sem_Ch9 is
if Ekind (Id) = E_Entry then
New_Overloaded_Entity (Id);
end if;
Generate_Reference_To_Formals (Id);
end Analyze_Entry_Declaration;
---------------------------------------
@ -1096,7 +1092,6 @@ package body Sem_Ch9 is
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
Check_Overriding_Indicator (N);
end Analyze_Protected_Definition;
----------------------------
@ -1108,7 +1103,6 @@ package body Sem_Ch9 is
T : Entity_Id;
Def_Id : constant Entity_Id := Defining_Identifier (N);
Iface : Node_Id;
Iface_Def : Node_Id;
Iface_Typ : Entity_Id;
begin
@ -1143,7 +1137,6 @@ package body Sem_Ch9 is
Iface := First (Interface_List (N));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
if not Is_Interface (Iface_Typ) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
@ -1158,13 +1151,13 @@ package body Sem_Ch9 is
-- Ada 2005 (AI-345): Protected types can only implement
-- limited, synchronized or protected interfaces.
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Protected_Present (Iface_Def)
if Is_Limited_Interface (Iface_Typ)
or else Is_Protected_Interface (Iface_Typ)
or else Is_Synchronized_Interface (Iface_Typ)
then
null;
elsif Task_Present (Iface_Def) then
elsif Is_Task_Interface (Iface_Typ) then
Error_Msg_N ("(Ada 2005) protected type cannot implement a "
& "task interface", Iface);
@ -1253,13 +1246,28 @@ package body Sem_Ch9 is
End_Scope;
-- Case of a completion of a private declaration
if T /= Def_Id
and then Is_Private_Type (Def_Id)
and then Has_Discriminants (Def_Id)
and then Expander_Active
then
Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
-- Deal with preelaborable initialization. Note that this processing
-- is done by Process_Full_View, but as can be seen below, in this
-- case the call to Process_Full_View is skipped if any serious
-- errors have occurred, and we don't want to lose this check.
if Known_To_Have_Preelab_Init (Def_Id) then
Set_Must_Have_Preelab_Init (T);
end if;
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view. Skip if errors are present,
-- to prevent cascaded messages.
if Serious_Errors_Detected = 0 then
Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end if;
end Analyze_Protected_Type;
@ -1849,7 +1857,6 @@ package body Sem_Ch9 is
Check_Max_Entries (N, Max_Task_Entries);
Process_End_Label (N, 'e', Current_Scope);
Check_Overriding_Indicator (N);
end Analyze_Task_Definition;
-----------------------
@ -1860,7 +1867,6 @@ package body Sem_Ch9 is
T : Entity_Id;
Def_Id : constant Entity_Id := Defining_Identifier (N);
Iface : Node_Id;
Iface_Def : Node_Id;
Iface_Typ : Entity_Id;
begin
@ -1891,7 +1897,6 @@ package body Sem_Ch9 is
Iface := First (Interface_List (N));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
if not Is_Interface (Iface_Typ) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
@ -1906,13 +1911,13 @@ package body Sem_Ch9 is
-- Ada 2005 (AI-345): Task types can only implement limited,
-- synchronized or task interfaces.
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Task_Present (Iface_Def)
if Is_Limited_Interface (Iface_Typ)
or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ)
then
null;
elsif Protected_Present (Iface_Def) then
elsif Is_Protected_Interface (Iface_Typ) then
Error_Msg_N ("(Ada 2005) task type cannot implement a " &
"protected interface", Iface);
@ -1983,13 +1988,28 @@ package body Sem_Ch9 is
End_Scope;
-- Case of a completion of a private declaration
if T /= Def_Id
and then Is_Private_Type (Def_Id)
and then Has_Discriminants (Def_Id)
and then Expander_Active
then
Exp_Ch9.Expand_N_Task_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
-- Deal with preelaborable initialization. Note that this processing
-- is done by Process_Full_View, but as can be seen below, in this
-- case the call to Process_Full_View is skipped if any serious
-- errors have occurred, and we don't want to lose this check.
if Known_To_Have_Preelab_Init (Def_Id) then
Set_Must_Have_Preelab_Init (T);
end if;
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view. Skip if errors are present,
-- to prevent cascaded messages.
if Serious_Errors_Detected = 0 then
Exp_Ch9.Expand_N_Task_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end if;
end Analyze_Task_Type;
@ -2154,259 +2174,6 @@ package body Sem_Ch9 is
end if;
end Check_Max_Entries;
--------------------------------
-- Check_Overriding_Indicator --
--------------------------------
procedure Check_Overriding_Indicator (Def : Node_Id) is
Aliased_Hom : Entity_Id;
Decl : Node_Id;
Def_Id : Entity_Id;
Hom : Entity_Id;
Ifaces : constant List_Id := Interface_List (Parent (Def));
Overrides : Boolean;
Spec : Node_Id;
Vis_Decls : constant List_Id := Visible_Declarations (Def);
function Matches_Prefixed_View_Profile
(Ifaces : List_Id;
Entry_Params : List_Id;
Proc_Params : List_Id) return Boolean;
-- Ada 2005 (AI-397): Determine if an entry parameter profile matches
-- the prefixed view profile of an abstract procedure. Also determine
-- whether the abstract procedure belongs to an implemented interface.
-----------------------------------
-- Matches_Prefixed_View_Profile --
-----------------------------------
function Matches_Prefixed_View_Profile
(Ifaces : List_Id;
Entry_Params : List_Id;
Proc_Params : List_Id) return Boolean
is
Entry_Param : Node_Id;
Proc_Param : Node_Id;
Proc_Param_Typ : Entity_Id;
function Includes_Interface
(Iface : Entity_Id;
Ifaces : List_Id) return Boolean;
-- Determine if an interface is contained in a list of interfaces
------------------------
-- Includes_Interface --
------------------------
function Includes_Interface
(Iface : Entity_Id;
Ifaces : List_Id) return Boolean
is
Ent : Entity_Id;
begin
Ent := First (Ifaces);
while Present (Ent) loop
if Etype (Ent) = Iface then
return True;
end if;
Next (Ent);
end loop;
return False;
end Includes_Interface;
-- Start of processing for Matches_Prefixed_View_Profile
begin
Proc_Param := First (Proc_Params);
Proc_Param_Typ := Etype (Parameter_Type (Proc_Param));
-- The first parameter of the abstract procedure must be of an
-- interface type. The task or protected type must also implement
-- that interface.
if not Is_Interface (Proc_Param_Typ)
or else not Includes_Interface (Proc_Param_Typ, Ifaces)
then
return False;
end if;
Entry_Param := First (Entry_Params);
Proc_Param := Next (Proc_Param);
while Present (Entry_Param) and then Present (Proc_Param) loop
-- The two parameters must be mode conformant and have the exact
-- same types.
if Ekind (Defining_Identifier (Entry_Param)) /=
Ekind (Defining_Identifier (Proc_Param))
or else Etype (Parameter_Type (Entry_Param)) /=
Etype (Parameter_Type (Proc_Param))
then
return False;
end if;
Next (Entry_Param);
Next (Proc_Param);
end loop;
-- One of the lists is longer than the other
if Present (Entry_Param) or else Present (Proc_Param) then
return False;
end if;
return True;
end Matches_Prefixed_View_Profile;
-- Start of processing for Check_Overriding_Indicator
begin
if Present (Ifaces) then
Decl := First (Vis_Decls);
while Present (Decl) loop
-- Consider entries with either "overriding" or "not overriding"
-- indicator present.
if Nkind (Decl) = N_Entry_Declaration
and then (Must_Override (Decl)
or else
Must_Not_Override (Decl))
then
Def_Id := Defining_Identifier (Decl);
Overrides := False;
Hom := Homonym (Def_Id);
while Present (Hom) loop
-- The current entry may override a procedure from an
-- implemented interface.
if Ekind (Hom) = E_Procedure
and then (Is_Abstract (Hom)
or else
Null_Present (Parent (Hom)))
then
Aliased_Hom := Hom;
while Present (Alias (Aliased_Hom)) loop
Aliased_Hom := Alias (Aliased_Hom);
end loop;
if Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Decl),
Parameter_Specifications (Parent (Aliased_Hom)))
then
Overrides := True;
exit;
end if;
end if;
Hom := Homonym (Hom);
end loop;
if Overrides then
if Must_Not_Override (Decl) then
Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id);
end if;
else
if Must_Override (Decl) then
Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
end if;
end if;
-- Consider subprograms with either "overriding" or "not
-- overriding" indicator present.
elsif Nkind (Decl) = N_Subprogram_Declaration
and then (Must_Override (Specification (Decl))
or else
Must_Not_Override (Specification (Decl)))
then
Spec := Specification (Decl);
Def_Id := Defining_Unit_Name (Spec);
Overrides := False;
Hom := Homonym (Def_Id);
while Present (Hom) loop
-- Function
if Ekind (Def_Id) = E_Function
and then Ekind (Hom) = E_Function
and then Is_Abstract (Hom)
and then Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Spec),
Parameter_Specifications (Parent (Hom)))
and then Etype (Result_Definition (Spec)) =
Etype (Result_Definition (Parent (Hom)))
then
Overrides := True;
exit;
-- Procedure
elsif Ekind (Def_Id) = E_Procedure
and then Ekind (Hom) = E_Procedure
and then (Is_Abstract (Hom)
or else
Null_Present (Parent (Hom)))
and then Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Spec),
Parameter_Specifications (Parent (Hom)))
then
Overrides := True;
exit;
end if;
Hom := Homonym (Hom);
end loop;
if Overrides then
if Must_Not_Override (Spec) then
Error_Msg_NE
("subprogram& is overriding", Def_Id, Def_Id);
end if;
else
if Must_Override (Spec) then
Error_Msg_NE
("subprogram& is not overriding", Def_Id, Def_Id);
end if;
end if;
end if;
Next (Decl);
end loop;
-- The protected or task type is not implementing an interface, we need
-- to check for the presence of "overriding" entries or subprograms and
-- flag them as erroneous.
else
Decl := First (Vis_Decls);
while Present (Decl) loop
if Nkind (Decl) = N_Entry_Declaration
and then Must_Override (Decl)
then
Def_Id := Defining_Identifier (Decl);
Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Must_Override (Specification (Decl))
then
Def_Id := Defining_Identifier (Specification (Decl));
Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id);
end if;
Next (Decl);
end loop;
end if;
end Check_Overriding_Indicator;
--------------------------
-- Find_Concurrent_Spec --
--------------------------