From 8c14315a0de2a70121941f646942a476767fad4e Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 26 Oct 2015 10:24:05 +0000 Subject: [PATCH] sem_ch12.adb (Analyze_Formal_Package_Declaration): Code clean up. 2015-10-26 Ed Schonberg * 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 --- gcc/ada/ChangeLog | 9 +++++ gcc/ada/sem_ch12.adb | 1 - gcc/ada/sem_ch13.adb | 80 +++++++++++++++++++++++++------------------- 3 files changed, 55 insertions(+), 35 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 936a924f316..d0f3e5f8dac 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2015-10-26 Ed Schonberg + + * 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 * a-reatim.adb, contracts.adb, contracts.ads: Minor reformatting and diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 6891c64b225..7d52d2e44ae 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9f7794f61c7..fea90d11d64 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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); -- 2.30.2