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

sem_ch12.adb (Analyze_Formal_Package_Declaration): Code clean up.

Browse Source 
2015-10-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Formal_Package_Declaration): Code clean up.
	* sem_ch13.adb (Check_Inherited_Indexing): New inner procedure
	of Check_Indexing_Functions, to verify that a derived type with an
	Indexing aspect is not inheriting such an aspect from an ancestor.
	(Check_Indexing_Functions): Call Check_Inherited_Indexing within
	an instance.

From-SVN: r229316
This commit is contained in:
Ed Schonberg 2015-10-26 10:24:05 +00:00 committed by Arnaud Charlet
parent 013a83cc02
commit 8c14315a0d
3 changed files with 55 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2015-10-26 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Formal_Package_Declaration): Code clean up.
* sem_ch13.adb (Check_Inherited_Indexing): New inner procedure
of Check_Indexing_Functions, to verify that a derived type with an
Indexing aspect is not inheriting such an aspect from an ancestor.
(Check_Indexing_Functions): Call Check_Inherited_Indexing within
an instance.
2015-10-26 Gary Dismukes <dismukes@adacore.com>
* a-reatim.adb, contracts.adb, contracts.ads: Minor reformatting and

1
gcc/ada/sem_ch12.adb
View File

@ -2587,7 +2587,6 @@ package body Sem_Ch12 is
or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
then
Associations := False;
Set_Box_Present (N);
end if;
-- If there are no generic associations, the generic parameters appear

80
gcc/ada/sem_ch13.adb
View File

@ -3971,6 +3971,10 @@ package body Sem_Ch13 is
procedure Check_Indexing_Functions is
Indexing_Found : Boolean := False;
procedure Check_Inherited_Indexing;
-- For a derived type, check that no indexing aspect is specified
-- for the type if it is also inherited
procedure Check_One_Function (Subp : Entity_Id);
-- Check one possible interpretation. Sets Indexing_Found True if a
-- legal indexing function is found.
@ -3979,6 +3983,46 @@ package body Sem_Ch13 is
-- Diagnose illegal indexing function if not overloaded. In the
-- overloaded case indicate that no legal interpretation exists.
------------------------------
-- Check_Inherited_Indexing --
------------------------------
procedure Check_Inherited_Indexing is
Inherited : Node_Id;
begin
if Attr = Name_Constant_Indexing then
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
else pragma Assert (Attr = Name_Variable_Indexing);
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
end if;
if Present (Inherited) then
if Debug_Flag_Dot_XX then
null;
-- OK if current attribute_definition_clause is expansion
-- of inherited aspect.
elsif Aspect_Rep_Item (Inherited) = N then
null;
-- Indicate the operation that must be overridden, rather
-- than redefining the indexing aspect
else
Illegal_Indexing
("indexing function already inherited "
& "from parent type");
Error_Msg_NE
("!override & instead",
N, Entity (Expression (Inherited)));
end if;
end if;
end Check_Inherited_Indexing;
------------------------
-- Check_One_Function --
------------------------
@ -4013,40 +4057,8 @@ package body Sem_Ch13 is
("indexing function must have at least two parameters");
return;
-- For a derived type, check that no indexing aspect is specified
-- for the type if it is also inherited
elsif Is_Derived_Type (Ent) then
declare
Inherited : Node_Id;
begin
if Attr = Name_Constant_Indexing then
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
else pragma Assert (Attr = Name_Variable_Indexing);
Inherited :=
Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
end if;
if Present (Inherited) then
if Debug_Flag_Dot_XX then
null;
-- Indicate the operation that must be overridden, rather
-- than redefining the indexing aspect
else
Illegal_Indexing
("indexing function already inherited "
& "from parent type");
Error_Msg_NE
("!override & instead",
N, Entity (Expression (Inherited)));
return;
end if;
end if;
end;
Check_Inherited_Indexing;
end if;
if not Check_Primitive_Function (Subp) then
@ -4165,7 +4177,7 @@ package body Sem_Ch13 is
begin
if In_Instance then
return;
Check_Inherited_Indexing;
end if;
Analyze (Expr);