From: Arnaud Charlet Date: Mon, 26 Oct 2015 15:35:49 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=335dde2981e5680619d25bf934527c9549959569;p=gcc.git [multiple changes] 2015-10-26 Hristian Kirtchev * sem_ch9.adb (Analyze_Single_Protected_Declaration): The anonymous object no longer comes from source. (Analyze_Single_Task_Declaration): The anonymous object no longer comes from source. * sem_prag.adb (Analyze_Pragma): The analysis of pragma SPARK_Mode now recognizes the internal anonymous object created for a single concurren type as a valid context. (Find_Related_Context): The internal anonymous object created for a single concurrent type is now a valid context. (Find_Related_Declaration_Or_Body): The internal anonymous object created for a single concurrent type is now a valid context. 2015-10-26 Ed Schonberg * sem_util.adb (Inherit_Rep_Item_Chain): Another another guard to prevent circularities in the rep_item_chain of the full view of a type extension in a child unit that extends a private type from the parent. From-SVN: r229374 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cec92831d62..86893ba18a1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2015-10-26 Hristian Kirtchev + + * sem_ch9.adb (Analyze_Single_Protected_Declaration): The anonymous + object no longer comes from source. + (Analyze_Single_Task_Declaration): The anonymous object no longer + comes from source. + * sem_prag.adb (Analyze_Pragma): The analysis of pragma SPARK_Mode + now recognizes the internal anonymous object created for a single + concurren type as a valid context. + (Find_Related_Context): The internal anonymous object created for a + single concurrent type is now a valid context. + (Find_Related_Declaration_Or_Body): The internal anonymous object + created for a single concurrent type is now a valid context. + +2015-10-26 Ed Schonberg + + * sem_util.adb (Inherit_Rep_Item_Chain): Another another guard + to prevent circularities in the rep_item_chain of the full view + of a type extension in a child unit that extends a private type + from the parent. + 2015-10-26 Hristian Kirtchev * atree.ads, atree.adb (Ekind_In): New 10 and 11 parameter versions. diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 2b3e42bf098..47cd3c663bb 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2665,11 +2665,6 @@ package body Sem_Ch9 is Defining_Identifier => Obj_Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); - -- Relocate the aspects that appear on the original single protected - -- declaration to the object as the object is the visible name. - - Set_Comes_From_Source (Obj_Decl, True); - Insert_After (N, Obj_Decl); Mark_Rewrite_Insertion (Obj_Decl); @@ -2756,11 +2751,6 @@ package body Sem_Ch9 is Defining_Identifier => Obj_Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); - -- Relocate the aspects that appear on the original single protected - -- declaration to the object as the object is the visible name. - - Set_Comes_From_Source (Obj_Decl, True); - Insert_After (N, Obj_Decl); Mark_Rewrite_Insertion (Obj_Decl); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c7c3f377ba8..a8998cc78cf 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -20543,6 +20543,20 @@ package body Sem_Prag is Process_Overloadable (Stmt); return; + -- The pragma applies to the anonymous object created for a + -- single concurrent type. + + -- protected type Anon_Prot_Typ ...; + -- Obj : Anon_Prot_Typ; + -- pragma SPARK_Mode ...; + + elsif Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object + (Defining_Entity (Stmt)) + then + Process_Overloadable (Stmt); + return; + -- Skip internally generated code elsif not Comes_From_Source (Stmt) then @@ -20567,20 +20581,6 @@ package body Sem_Prag is Process_Overloadable (Stmt); return; - -- The pragma applies to the anonymous object created for a - -- single concurrent type. - - -- protected type Anon_Prot_Typ ...; - -- Obj : Anon_Prot_Typ; - -- pragma SPARK_Mode ...; - - elsif Nkind (Stmt) = N_Object_Declaration - and then Is_Single_Concurrent_Object - (Defining_Entity (Stmt)) - then - Process_Overloadable (Stmt); - return; - -- Otherwise the pragma does not apply to a legal construct -- or it does not appear at the top of a declarative or a -- statement list. Issue an error and stop the analysis. @@ -26697,7 +26697,15 @@ package body Sem_Prag is -- Skip internally generated code elsif not Comes_From_Source (Stmt) then - null; + + -- The anonymous object created for a single concurrent type is a + -- suitable context. + + if Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) + then + return Stmt; + end if; -- Return the current source construct @@ -26800,7 +26808,16 @@ package body Sem_Prag is -- Skip internally generated code elsif not Comes_From_Source (Stmt) then - if Nkind (Stmt) = N_Subprogram_Declaration then + + -- The anonymous object created for a single concurrent type is a + -- suitable context. + + if Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) + then + return Stmt; + + elsif Nkind (Stmt) = N_Subprogram_Declaration then -- The subprogram declaration is an internally generated spec -- for an expression function. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 112c6e764ac..8e33f4c4036 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10320,6 +10320,25 @@ package body Sem_Util is Item := Next_Rep_Item (Item); end loop; + Item := First_Rep_Item (From_Typ); + + -- Additional check when both parent and current type have rep. + -- items, to prevent circularities when the derivation completes + -- a private declaration and inherits from both views of the parent. + -- There may be a remaining problem with the proper ordering of + -- attribute specifications and aspects on the chains of the four + -- entities involved. ??? + + if Present (Item) and then Present (From_Item) then + while Present (Item) loop + if Item = First_Rep_Item (Typ) then + return; + end if; + + Item := Next_Rep_Item (Item); + end loop; + end if; + -- When the destination type has a rep item chain, the chain of the -- source type is appended to it.