From 39af2bac25b7a60c9ab868e794202dd45af94e14 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 10 Oct 2013 14:56:07 +0200 Subject: [PATCH] [multiple changes] 2013-10-10 Hristian Kirtchev * aspects.adb: Add an entry in table Canonical_Aspect for Refined_State. * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, Aspect_Names and Aspect_Delay for Refined_State. * einfo.adb: Add with and use clauses for Elists. Remove Refined_State from the list of node usage. Add Refined_State_Pragma to the list of node usage. (Has_Null_Abstract_State): New routine. (Refined_State): Removed. (Refined_State_Pragma): New routine. (Set_Refined_State): Removed. (Set_Refined_State_Pragma): New routine. (Write_Field8_Name): Add output for Refined_State_Pragma. (Write_Field9_Name): Remove the output for Refined_State. * einfo.ads: Add new synthesized attribute Has_Null_Abstract_State along with usage in nodes. Remove attribute Refined_State along with usage in nodes. Add new attribute Refined_State_Pragma along with usage in nodes. (Has_Null_Abstract_State): New routine. (Refined_State): Removed. (Refined_State_Pragma): New routine. (Set_Refined_State): Removed. (Set_Refined_State_Pragma): New routine. * elists.adb (Clone): New routine. * elists.ads (Clone): New routine. * par-prag.adb: Add Refined_State to the pragmas that do not require special processing by the parser. * sem_ch3.adb: Add with and use clause for Sem_Prag. (Analyze_Declarations): Add local variables Body_Id, Context and Spec_Id. Add processing for delayed aspect/pragma Refined_State. * sem_ch13.adb (Analyze_Aspect_Specifications): Update the handling of aspect Abstract_State. Add processing for aspect Refined_State. Remove the bizzare insertion policy for aspect Abstract_State. (Check_Aspect_At_Freeze_Point): Add an entry for Refined_State. * sem_prag.adb: Add an entry to table Sig_Flags for pragma Refined_State. (Add_Item): Update the comment on usage. The inserted items need not be unique. (Analyze_Contract_Cases_In_Decl_Part): Rename variable Restore to Restore_Scope and update all its occurrences. (Analyze_Pragma): Update the handling of pragma Abstract_State. Add processing for pragma Refined_State. (Analyze_Pre_Post_Condition_In_Decl_Part): Rename variable Restore to Restore_Scope and update all its occurrences. (Analyze_Refined_State_In_Decl_Part): New routine. * sem_prag.ads (Analyze_Refined_State_In_Decl_Part): New routine. * snames.ads-tmpl: Add new predefined name for Refined_State. Add new Pragma_Id for Refined_State. 2013-10-10 Ed Schonberg * sem_ch10.adb (Install_Limited_Withed_Unit): handle properly the case of a record declaration in a limited view, when the record contains a self-referential component of an anonymous access type. From-SVN: r203371 --- gcc/ada/ChangeLog | 60 ++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 4 + gcc/ada/einfo.adb | 38 ++- gcc/ada/einfo.ads | 22 +- gcc/ada/elists.adb | 28 ++ gcc/ada/elists.ads | 4 + gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch10.adb | 93 +++---- gcc/ada/sem_ch13.adb | 99 +++++-- gcc/ada/sem_ch3.adb | 35 +++ gcc/ada/sem_prag.adb | 598 ++++++++++++++++++++++++++++++++++++++-- gcc/ada/sem_prag.ads | 3 + gcc/ada/snames.ads-tmpl | 5 + 14 files changed, 866 insertions(+), 125 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 59c7e497c73..5da6a9ea305 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2013-10-10 Hristian Kirtchev + + * aspects.adb: Add an entry in table Canonical_Aspect for + Refined_State. + * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, + Aspect_Names and Aspect_Delay for Refined_State. + * einfo.adb: Add with and use clauses for Elists. + Remove Refined_State from the list of node usage. + Add Refined_State_Pragma to the list of node usage. + (Has_Null_Abstract_State): New routine. + (Refined_State): Removed. + (Refined_State_Pragma): New routine. + (Set_Refined_State): Removed. + (Set_Refined_State_Pragma): New routine. + (Write_Field8_Name): Add output for Refined_State_Pragma. + (Write_Field9_Name): Remove the output for Refined_State. + * einfo.ads: Add new synthesized attribute Has_Null_Abstract_State + along with usage in nodes. Remove attribute Refined_State along + with usage in nodes. Add new attribute Refined_State_Pragma along + with usage in nodes. + (Has_Null_Abstract_State): New routine. + (Refined_State): Removed. + (Refined_State_Pragma): New routine. + (Set_Refined_State): Removed. + (Set_Refined_State_Pragma): New routine. + * elists.adb (Clone): New routine. + * elists.ads (Clone): New routine. + * par-prag.adb: Add Refined_State to the pragmas that do not + require special processing by the parser. + * sem_ch3.adb: Add with and use clause for Sem_Prag. + (Analyze_Declarations): Add local variables Body_Id, Context and + Spec_Id. Add processing for delayed aspect/pragma Refined_State. + * sem_ch13.adb (Analyze_Aspect_Specifications): Update the + handling of aspect Abstract_State. Add processing for aspect + Refined_State. Remove the bizzare insertion policy for aspect + Abstract_State. + (Check_Aspect_At_Freeze_Point): Add an entry for Refined_State. + * sem_prag.adb: Add an entry to table Sig_Flags + for pragma Refined_State. + (Add_Item): Update the + comment on usage. The inserted items need not be unique. + (Analyze_Contract_Cases_In_Decl_Part): Rename variable Restore to + Restore_Scope and update all its occurrences. + (Analyze_Pragma): + Update the handling of pragma Abstract_State. Add processing for + pragma Refined_State. + (Analyze_Pre_Post_Condition_In_Decl_Part): + Rename variable Restore to Restore_Scope and update all its + occurrences. + (Analyze_Refined_State_In_Decl_Part): New routine. + * sem_prag.ads (Analyze_Refined_State_In_Decl_Part): New routine. + * snames.ads-tmpl: Add new predefined name for Refined_State. Add + new Pragma_Id for Refined_State. + +2013-10-10 Ed Schonberg + + * sem_ch10.adb (Install_Limited_Withed_Unit): handle properly the + case of a record declaration in a limited view, when the record + contains a self-referential component of an anonymous access type. + 2013-10-10 Thomas Quinot * exp_ch4.adb (Process_Transient_Object): For any context other diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 0f21ad48b37..2aea7b3ee8b 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -470,6 +470,7 @@ package body Aspects is Aspect_Refined_Global => Aspect_Refined_Global, Aspect_Refined_Post => Aspect_Refined_Post, Aspect_Refined_Pre => Aspect_Refined_Pre, + Aspect_Refined_State => Aspect_Refined_State, Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, Aspect_Remote_Types => Aspect_Remote_Types, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 50ac1aa58cb..15c6e4cec43 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -115,6 +115,7 @@ package Aspects is Aspect_Refined_Global, -- GNAT Aspect_Refined_Post, -- GNAT Aspect_Refined_Pre, -- GNAT + Aspect_Refined_State, -- GNAT Aspect_Relative_Deadline, Aspect_Scalar_Storage_Order, -- GNAT Aspect_Simple_Storage_Pool, -- GNAT @@ -327,6 +328,7 @@ package Aspects is Aspect_Refined_Global => Expression, Aspect_Refined_Post => Expression, Aspect_Refined_Pre => Expression, + Aspect_Refined_State => Expression, Aspect_Relative_Deadline => Expression, Aspect_Scalar_Storage_Order => Expression, Aspect_Simple_Storage_Pool => Name, @@ -427,6 +429,7 @@ package Aspects is Aspect_Refined_Global => Name_Refined_Global, Aspect_Refined_Post => Name_Refined_Post, Aspect_Refined_Pre => Name_Refined_Pre, + Aspect_Refined_State => Name_Refined_State, Aspect_Relative_Deadline => Name_Relative_Deadline, Aspect_Remote_Access_Type => Name_Remote_Access_Type, Aspect_Remote_Call_Interface => Name_Remote_Call_Interface, @@ -620,6 +623,7 @@ package Aspects is Aspect_Read => Always_Delay, Aspect_Refined_Depends => Always_Delay, Aspect_Refined_Global => Always_Delay, + Aspect_Refined_State => Always_Delay, Aspect_Relative_Deadline => Always_Delay, Aspect_Remote_Access_Type => Always_Delay, Aspect_Remote_Call_Interface => Always_Delay, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8314834af68..5d4da12efd6 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -33,6 +33,7 @@ pragma Style_Checks (All_Checks); -- Turn off subprogram ordering, not used for this unit with Atree; use Atree; +with Elists; use Elists; with Namet; use Namet; with Nlists; use Nlists; with Output; use Output; @@ -79,12 +80,12 @@ package body Einfo is -- Mechanism Uint8 (but returns Mechanism_Type) -- Normalized_First_Bit Uint8 -- Postcondition_Proc Node8 + -- Refined_State_Pragma Node8 -- Return_Applies_To Node8 -- First_Exit_Statement Node8 -- Class_Wide_Type Node9 -- Current_Value Node9 - -- Refined_State Node9 -- Renaming_Map Uint9 -- Direct_Primitive_Operations Elist10 @@ -2647,11 +2648,11 @@ package body Einfo is return Flag227 (Id); end Referenced_As_Out_Parameter; - function Refined_State (Id : E) return E is + function Refined_State_Pragma (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - return Node9 (Id); - end Refined_State; + pragma Assert (Ekind (Id) = E_Package_Body); + return Node8 (Id); + end Refined_State_Pragma; function Register_Exception_Call (Id : E) return N is begin @@ -5307,11 +5308,11 @@ package body Einfo is Set_Flag227 (Id, V); end Set_Referenced_As_Out_Parameter; - procedure Set_Refined_State (Id : E; V : E) is + procedure Set_Refined_State_Pragma (Id : E; V : N) is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - Set_Node9 (Id, V); - end Set_Refined_State; + pragma Assert (Ekind (Id) = E_Package_Body); + Set_Node8 (Id, V); + end Set_Refined_State_Pragma; procedure Set_Register_Exception_Call (Id : E; V : N) is begin @@ -6427,6 +6428,19 @@ package body Einfo is return False; end Has_Interrupt_Handler; + ----------------------------- + -- Has_Null_Abstract_State -- + ----------------------------- + + function Has_Null_Abstract_State (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package)); + + return + Present (Abstract_States (Id)) + and then Is_Null_State (Node (First_Elmt (Abstract_States (Id)))); + end Has_Null_Abstract_State; + -------------------- -- Has_Unmodified -- -------------------- @@ -8292,6 +8306,9 @@ package body Einfo is when E_Procedure => Write_Str ("Postcondition_Proc"); + when E_Package_Body => + Write_Str ("Refined_State_Pragma"); + when E_Return_Statement => Write_Str ("Return_Applies_To"); @@ -8313,9 +8330,6 @@ package body Einfo is when Object_Kind => Write_Str ("Current_Value"); - when E_Abstract_State => - Write_Str ("Refined_State"); - when E_Function | E_Generic_Function | E_Generic_Package | diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 02626f572d1..1b4c381a8a4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1645,6 +1645,10 @@ package Einfo is -- are not considered to be significant since they do not affect -- stored bit patterns. +-- Has_Null_Abstract_State (synth) +-- Defined in package entities. True if the package is subject to a null +-- Abstract_State aspect/pragma. + -- Has_Object_Size_Clause (Flag172) -- Defined in entities for types and subtypes. Set if an Object_Size -- clause has been processed for the type Used to prevent multiple @@ -3533,9 +3537,9 @@ package Einfo is -- we have a separate warning for variables that are only assigned and -- never read, and out parameters are a special case. --- Refined_State (Node9) --- Defined in E_Abstract_State entities. Contains the entity of the --- abstract state completion which is usually foung in package bodies. +-- Refined_State_Pragma (Node8) +-- Defined in [generic] package bodies. Contains the pragma that refines +-- all abstract states defined in the corresponding package declaration. -- Register_Exception_Call (Node20) -- Defined in exception entities. When an exception is declared, @@ -5092,7 +5096,6 @@ package Einfo is ------------------------------------------ -- E_Abstract_State - -- Refined_State (Node9) -- Is_External_State (synth) -- Is_Input_Only_State (synth) -- Is_Null_State (synth) @@ -5636,10 +5639,12 @@ package Einfo is -- Is_Visible_Lib_Unit (Flag116) -- Renamed_In_Spec (Flag231) (non-generic case only) -- Static_Elaboration_Desired (Flag77) (non-generic case only) + -- Has_Null_Abstract_State (synth) -- Is_Wrapper_Package (synth) (non-generic case only) -- Scope_Depth (synth) -- E_Package_Body + -- Refined_State_Pragma (Node8) -- Handler_Records (List10) (non-generic case only) -- Related_Instance (Node15) (non-generic case only) -- First_Entity (Node17) @@ -6535,7 +6540,7 @@ package Einfo is function Referenced (Id : E) return B; function Referenced_As_LHS (Id : E) return B; function Referenced_As_Out_Parameter (Id : E) return B; - function Refined_State (Id : E) return E; + function Refined_State_Pragma (Id : E) return E; function Register_Exception_Call (Id : E) return N; function Related_Array_Object (Id : E) return E; function Related_Expression (Id : E) return N; @@ -6674,6 +6679,7 @@ package Einfo is function Has_Attach_Handler (Id : E) return B; function Has_Entries (Id : E) return B; function Has_Foreign_Convention (Id : E) return B; + function Has_Null_Abstract_State (Id : E) return B; function Implementation_Base_Type (Id : E) return E; function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; @@ -7152,7 +7158,7 @@ package Einfo is procedure Set_Referenced (Id : E; V : B := True); procedure Set_Referenced_As_LHS (Id : E; V : B := True); procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True); - procedure Set_Refined_State (Id : E; V : E); + procedure Set_Refined_State_Pragma (Id : E; V : N); procedure Set_Register_Exception_Call (Id : E; V : N); procedure Set_Related_Array_Object (Id : E; V : E); procedure Set_Related_Expression (Id : E; V : N); @@ -7902,7 +7908,7 @@ package Einfo is pragma Inline (Referenced); pragma Inline (Referenced_As_LHS); pragma Inline (Referenced_As_Out_Parameter); - pragma Inline (Refined_State); + pragma Inline (Refined_State_Pragma); pragma Inline (Register_Exception_Call); pragma Inline (Related_Array_Object); pragma Inline (Related_Expression); @@ -8318,7 +8324,7 @@ package Einfo is pragma Inline (Set_Referenced); pragma Inline (Set_Referenced_As_LHS); pragma Inline (Set_Referenced_As_Out_Parameter); - pragma Inline (Set_Refined_State); + pragma Inline (Set_Refined_State_Pragma); pragma Inline (Set_Register_Exception_Call); pragma Inline (Set_Related_Array_Object); pragma Inline (Set_Related_Expression); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 6170585272e..a840d95e333 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -158,6 +158,34 @@ package body Elists is end loop; end Append_Unique_Elmt; + ----------- + -- Clone -- + ------------ + + function Clone (List : Elist_Id) return Elist_Id is + Result : Elist_Id; + Elmt : Elmt_Id; + + begin + if List = No_Elist then + return No_Elist; + + -- Replicate the contents of the input list while preserving the + -- original order. + + else + Result := New_Elmt_List; + + Elmt := First_Elmt (List); + while Present (Elmt) loop + Append_Elmt (Node (Elmt), Result); + Next_Elmt (Elmt); + end loop; + + return Result; + end if; + end Clone; + -------------- -- Contains -- -------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 8f66e0553bf..d2eb745cc8a 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -153,6 +153,10 @@ package Elists is -- affected, but the space used by the list element may be (but is not -- required to be) freed for reuse in a subsequent Append_Elmt call. + function Clone (List : Elist_Id) return Elist_Id; + -- Create a copy of the input list. Internal list nodes are not shared and + -- order of elements is preserved. + function Contains (List : Elist_Id; N : Node_Or_Entity_Id) return Boolean; -- Perform a sequential search to determine whether the given list contains -- a node or an entity. diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index e8bea1fced3..bf23bc7d609 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1254,6 +1254,7 @@ begin Pragma_Refined_Global | Pragma_Refined_Post | Pragma_Refined_Pre | + Pragma_Refined_State | Pragma_Relative_Deadline | Pragma_Remote_Access_Type | Pragma_Remote_Call_Interface | diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 8d64964ac78..ee2ab6300cd 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -330,9 +330,8 @@ package body Sem_Ch10 is function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is begin return Entity (N) = P - or else - (Present (Renamed_Object (P)) - and then Entity (N) = Renamed_Object (P)); + or else (Present (Renamed_Object (P)) + and then Entity (N) = Renamed_Object (P)); end Same_Unit; -- Start of processing for Process_Body_Clauses @@ -404,14 +403,12 @@ package body Sem_Ch10 is elsif Nkind (Cont_Item) = N_Pragma and then Nam_In (Pragma_Name (Cont_Item), Name_Elaborate, - Name_Elaborate_All) + Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := First (Pragma_Argument_Associations (Cont_Item)); - while Present (Prag_Unit) - and then not Used_Type_Or_Elab - loop + while Present (Prag_Unit) and then not Used_Type_Or_Elab loop if Entity (Expression (Prag_Unit)) = Nam_Ent then Used_Type_Or_Elab := True; end if; @@ -478,7 +475,7 @@ package body Sem_Ch10 is -- with Pack; -- with Pack; -- pragma Elaborate (Pack); - -- + -- In this case, the second with clause is redundant since -- the pragma applies only to the first "with Pack;". @@ -558,10 +555,8 @@ package body Sem_Ch10 is if (Withed_In_Spec and then not Used_Type_Or_Elab) and then - ((not Used_In_Spec - and then not Used_In_Body) - or else - Used_In_Spec) + ((not Used_In_Spec and then not Used_In_Body) + or else Used_In_Spec) then Error_Msg_N -- CODEFIX ("redundant with clause in body??", Clause); @@ -1014,9 +1009,8 @@ package body Sem_Ch10 is N_Package_Renaming_Declaration, N_Subprogram_Declaration) or else Nkind (Unit_Node) in N_Generic_Declaration - or else - (Nkind (Unit_Node) = N_Subprogram_Body - and then Acts_As_Spec (Unit_Node)) + or else (Nkind (Unit_Node) = N_Subprogram_Body + and then Acts_As_Spec (Unit_Node)) then Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); @@ -1932,10 +1926,9 @@ package body Sem_Ch10 is Nam := Full_View (Nam); end if; - if No (Nam) - or else not Is_Protected_Type (Etype (Nam)) - then + if No (Nam) or else not Is_Protected_Type (Etype (Nam)) then Error_Msg_N ("missing specification for Protected body", N); + else Set_Scope (Defining_Entity (N), Current_Scope); Set_Has_Completion (Etype (Nam)); @@ -1970,9 +1963,7 @@ package body Sem_Ch10 is N_Subprogram_Body) then Decl := First (Declarations (Parent (N))); - while Present (Decl) - and then Decl /= N - loop + while Present (Decl) and then Decl /= N loop if Nkind (Decl) = N_Subprogram_Body_Stub and then (Chars (Defining_Unit_Name (Specification (Decl))) = Chars (Defining_Unit_Name (Specification (N)))) @@ -2184,9 +2175,7 @@ package body Sem_Ch10 is E := First_Entity (Current_Scope); while Present (E) loop - if not Is_Child_Unit (E) - or else Is_Visible_Lib_Unit (E) - then + if not Is_Child_Unit (E) or else Is_Visible_Lib_Unit (E) then Set_Is_Immediately_Visible (E); end if; @@ -2312,8 +2301,8 @@ package body Sem_Ch10 is if Is_Package_Or_Generic_Package (Par_Unit) then if not Is_Immediately_Visible (Par_Unit) or else (Present (First_Entity (Par_Unit)) - and then not Is_Immediately_Visible - (First_Entity (Par_Unit))) + and then not + Is_Immediately_Visible (First_Entity (Par_Unit))) then Set_Is_Immediately_Visible (Par_Unit); Install_Visible_Declarations (Par_Unit); @@ -2923,7 +2912,7 @@ package body Sem_Ch10 is or else Private_Present (Item) or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) or else (Nkind (Lib_Unit) = N_Subprogram_Body - and then not Acts_As_Spec (Parent (Lib_Unit))) + and then not Acts_As_Spec (Parent (Lib_Unit))) then null; @@ -3464,7 +3453,7 @@ package body Sem_Ch10 is if Nkind (Lib_Unit) = N_Package_Body or else (Nkind (Lib_Unit) = N_Subprogram_Body - and then not Acts_As_Spec (N)) + and then not Acts_As_Spec (N)) then Install_Context (Library_Unit (N)); @@ -3636,9 +3625,7 @@ package body Sem_Ch10 is -- Check all the enclosing scopes. E2 := E; - while E2 /= Standard_Standard - and then E2 /= WEnt - loop + while E2 /= Standard_Standard and then E2 /= WEnt loop E2 := Scope (E2); end loop; @@ -3856,9 +3843,7 @@ package body Sem_Ch10 is Check_Private_Limited_Withed_Unit (Item); - if not Implicit_With (Item) - and then Is_Child_Spec (Unit (N)) - then + if not Implicit_With (Item) and then Is_Child_Spec (Unit (N)) then Check_Renamings (Parent_Spec (Unit (N)), Item); end if; @@ -3998,7 +3983,7 @@ package body Sem_Ch10 is or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation or else (Nkind (Lib_Unit) = N_Package_Declaration - and then Present (Generic_Parent (Specification (Lib_Unit)))) + and then Present (Generic_Parent (Specification (Lib_Unit)))) then null; else @@ -4061,9 +4046,7 @@ package body Sem_Ch10 is Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); end if; - if Is_Private - or else Private_Present (Parent (Lib_Unit)) - then + if Is_Private or else Private_Present (Parent (Lib_Unit)) then Install_Private_Declarations (P_Name); Install_Private_With_Clauses (P_Name); Set_Use (Private_Declarations (P_Spec)); @@ -4992,7 +4975,18 @@ package body Sem_Ch10 is -- Replace E in the homonyms list, so that the limited view -- becomes available. - if E = Non_Limited_View (Lim_Typ) then + -- If the non-limited view is a record with an anonymous + -- self-referential component, the analysis of the record + -- declaration creates an incomplete type with the same name + -- in order to define an internal access type. The visible + -- entity is now the incomplete type, and that is the one to + -- replace in the visibility structure. + + if E = Non_Limited_View (Lim_Typ) + or else + (Ekind (E) = E_Incomplete_Type + and then Full_View (E) = Non_Limited_View (Lim_Typ)) + then Set_Homonym (Lim_Typ, Homonym (Prev)); Set_Current_Entity (Lim_Typ); @@ -5004,9 +4998,7 @@ package body Sem_Ch10 is -- limited_with_clause. exit when No (E); - exit when E = Non_Limited_View (Lim_Typ); - Prev := Homonym (Prev); end loop; @@ -5128,7 +5120,7 @@ package body Sem_Ch10 is if Sloc (Uname) /= No_Location and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) - or else Current_Sem_Unit = Main_Unit) + or else Current_Sem_Unit = Main_Unit) then Check_Restricted_Unit (Unit_Name (Get_Source_Unit (Uname)), With_Clause); @@ -5224,9 +5216,7 @@ package body Sem_Ch10 is begin U2 := Homonym (Uname); - while Present (U2) - and then U2 /= Standard_Standard - loop + while Present (U2) and then U2 /= Standard_Standard loop P2 := Scope (U2); Decl2 := Unit_Declaration_Node (P2); @@ -5836,9 +5826,7 @@ package body Sem_Ch10 is Ent : Entity_Id; begin - if Is_Subprogram (E) - and then Has_Pragma_Inline (E) - then + if Is_Subprogram (E) and then Has_Pragma_Inline (E) then return True; elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then @@ -6225,9 +6213,8 @@ package body Sem_Ch10 is begin Item := First (Context_Items (Comp_Unit)); while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then Private_Present (Item) - then + if Nkind (Item) = N_With_Clause and then Private_Present (Item) then + -- If private_with_clause is redundant, remove it from context, -- as a small optimization to subsequent handling of private_with -- clauses in other nested packages. @@ -6310,9 +6297,7 @@ package body Sem_Ch10 is Set_Name_Entity_Id (Chars (E), Homonym (E)); else - while Present (Prev) - and then Homonym (Prev) /= E - loop + while Present (Prev) and then Homonym (Prev) /= E loop Prev := Homonym (Prev); end loop; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d96c5bc8c5e..0b812a73f63 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1883,12 +1883,45 @@ package body Sem_Ch13 is -- Abstract_State - when Aspect_Abstract_State => - Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr))), - Pragma_Name => Name_Abstract_State); + when Aspect_Abstract_State => Abstract_State : declare + Decls : List_Id; + Spec : Node_Id; + + begin + -- Aspect Abstract_State introduces implicit declarations + -- for all state abstraction entities it defines. To emulate + -- this behavior, insert the pragma at the beginning of the + -- visible declarations of the related package so that it is + -- analyzed immediately. + + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Spec := Specification (N); + Decls := Visible_Declarations (Spec); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Abstract_State); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Abstract_State; -- Depends @@ -1967,6 +2000,42 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Refined_Pre); + -- Refined_State + + when Aspect_Refined_State => Refined_State : declare + Decls : List_Id; + + begin + -- The corresponding pragma for Refined_State is inserted in + -- the declarations of the related package body. This action + -- synchronizes both the source and from-aspect versions of + -- the pragma. + + if Nkind (N) = N_Package_Body then + Decls := Declarations (N); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_State); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package body", Aspect, Id); + end if; + + goto Continue; + end Refined_State; + -- Relative_Deadline when Aspect_Relative_Deadline => @@ -2411,21 +2480,6 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem, True); end if; - -- Aspect Abstract_State introduces implicit declarations for all - -- state abstraction entities it defines. To emulate this behavior - -- insert the pragma at the start of the visible declarations of - -- the related package. - - if Nam = Name_Abstract_State - and then Nkind (N) = N_Package_Declaration - then - if No (Visible_Declarations (Specification (N))) then - Set_Visible_Declarations (Specification (N), New_List); - end if; - - Prepend (Aitem, Visible_Declarations (Specification (N))); - goto Continue; - -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux -- node (no delay is required here) except for aspects on a @@ -2434,7 +2488,7 @@ package body Sem_Ch13 is -- copy (see sem_ch12), and for package instantiations, where -- the library unit pragmas are better handled early. - elsif Nkind (Parent (N)) = N_Compilation_Unit + if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) then declare @@ -7651,6 +7705,7 @@ package body Sem_Ch13 is Aspect_Refined_Global | Aspect_Refined_Post | Aspect_Refined_Pre | + Aspect_Refined_State | Aspect_SPARK_Mode | Aspect_Test_Case => raise Program_Error; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1e6abf24cec..5e40656e76b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -64,6 +64,7 @@ with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Smem; use Sem_Smem; with Sem_Type; use Sem_Type; @@ -2079,8 +2080,11 @@ package body Sem_Ch3 is -- Local variables + Body_Id : Entity_Id; + Context : Node_Id; Freeze_From : Entity_Id := Empty; Next_Decl : Node_Id; + Spec_Id : Entity_Id; -- Start of processing for Analyze_Declarations @@ -2190,6 +2194,37 @@ package body Sem_Ch3 is Decl := Next_Decl; end loop; + -- Analyze the state refinements within a package body now, after all + -- hidden states have been encountered and freely visible. Refinements + -- must be processed before pragmas Refined_Depends and Refined_Global + -- because the last two may mention constituents. + + if Present (L) then + Context := Parent (L); + + if Nkind (Context) = N_Package_Body then + Body_Id := Defining_Entity (Context); + Spec_Id := Corresponding_Spec (Context); + + -- The analysis of pragma Refined_State detects whether the spec + -- has abstract states available for refinement. + + if Present (Refined_State_Pragma (Body_Id)) then + Analyze_Refined_State_In_Decl_Part + (Refined_State_Pragma (Body_Id)); + + -- State refinement is required when the package declaration has + -- abstract states. Null states are not considered. + + elsif Present (Abstract_States (Spec_Id)) + and then not Has_Null_Abstract_State (Spec_Id) + then + Error_Msg_NE + ("package & requires state refinement", Context, Spec_Id); + end if; + end if; + end if; + -- Analyze the contracts of a subprogram declaration or a body now due -- to delayed visibility requirements of aspects. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7b0f71f15b0..c0475343e83 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -168,9 +168,9 @@ package body Sem_Prag is ------------------------------------- procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); - -- Subsidiary routine to the analysis of pragmas Depends and Global. Append - -- an input or output item to a list. If the list is empty, a new one is - -- created. + -- Subsidiary routine to the analysis of pragmas Depends, Global and + -- Refined_State. Append an entity to a list. If the list is empty, create + -- a new list. function Adjust_External_Name_Case (N : Node_Id) return Node_Id; -- This routine is used for possible casing adjustment of an explicit @@ -285,7 +285,7 @@ package body Sem_Prag is To_List := New_Elmt_List; end if; - Append_Unique_Elmt (Item, To_List); + Append_Elmt (Item, To_List); end Add_Item; ------------------------------- @@ -404,10 +404,12 @@ package body Sem_Prag is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); All_Cases : Node_Id; CCase : Node_Id; - Restore : Boolean := False; Subp_Decl : Node_Id; Subp_Id : Entity_Id; + Restore_Scope : Boolean := False; + -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit + -- Start of processing for Analyze_Contract_Cases_In_Decl_Part begin @@ -432,7 +434,7 @@ package body Sem_Prag is -- for subprogram bodies because the formals are already visible. if Requires_Profile_Installation (N, Subp_Decl) then - Restore := True; + Restore_Scope := True; Push_Scope (Subp_Id); Install_Formals (Subp_Id); end if; @@ -443,7 +445,7 @@ package body Sem_Prag is Next (CCase); end loop; - if Restore then + if Restore_Scope then End_Scope; end if; end if; @@ -8494,7 +8496,6 @@ package body Sem_Prag is Set_Parent (Id, State); Set_Ekind (Id, E_Abstract_State); Set_Etype (Id, Standard_Void_Type); - Set_Refined_State (Id, Empty); -- Every non-null state must be nameable and resolvable the -- same way a constant is. @@ -8523,8 +8524,8 @@ package body Sem_Prag is -- Local variables - Par : Node_Id; - State : Node_Id; + Context : constant Node_Id := Parent (Parent (N)); + State : Node_Id; -- Start of processing for Abstract_State @@ -8536,24 +8537,14 @@ package body Sem_Prag is -- Ensure the proper placement of the pragma. Abstract states must -- be associated with a package declaration. - if From_Aspect_Specification (N) then - Par := Parent (Corresponding_Aspect (N)); - else - Par := Parent (Parent (N)); - end if; - - if Nkind (Par) = N_Compilation_Unit then - Par := Unit (Par); - end if; - - if not Nkind_In (Par, N_Generic_Package_Declaration, - N_Package_Declaration) + if not Nkind_In (Context, N_Generic_Package_Declaration, + N_Package_Declaration) then Pragma_Misplaced; return; end if; - Pack_Id := Defining_Entity (Par); + Pack_Id := Defining_Entity (Context); State := Expression (Arg1); -- Multiple abstract states appear as an aggregate @@ -15974,6 +15965,62 @@ package body Sem_Prag is when Pragma_Refined_Pre => Analyze_Refined_Pre_Post_Condition; + ------------------- + -- Refined_State -- + ------------------- + + -- pragma Refined_State (REFINEMENT_LIST); + + -- REFINEMENT_LIST ::= + -- REFINEMENT_CLAUSE + -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) + + -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST + + -- CONSTITUENT_LIST ::= + -- null + -- | CONSTITUENT + -- | (CONSTITUENT {, CONSTITUENT}) + + -- CONSTITUENT ::= object_NAME | state_NAME + + when Pragma_Refined_State => Refined_State : declare + Context : constant Node_Id := Parent (N); + Spec_Id : Entity_Id; + + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Refined states must + -- be associated with a package body. + + if Nkind (Context) /= N_Package_Body then + Pragma_Misplaced; + return; + end if; + + -- State refinement is allowed only when the corresponding package + -- declaration has a non-null aspect/pragma Abstract_State. + + Spec_Id := Corresponding_Spec (Context); + + if No (Abstract_States (Spec_Id)) + or else Has_Null_Abstract_State (Spec_Id) + then + Error_Pragma + ("useless pragma %, package does not define abstract states"); + return; + end if; + + -- The pragma must be analyzed at the end of the declarations as + -- it has visibility over the whole declarative region. Save the + -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part). + + Set_Refined_State_Pragma (Defining_Entity (Context), N); + end Refined_State; + ----------------------- -- Relative_Deadline -- ----------------------- @@ -18313,17 +18360,18 @@ package body Sem_Prag is (Prag : Node_Id; Subp_Id : Entity_Id) is - Arg1 : constant Node_Id := - First (Pragma_Argument_Associations (Prag)); - Expr : Node_Id; - Restore : Boolean := False; + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag)); + Expr : Node_Id; + + Restore_Scope : Boolean := False; + -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit begin -- Ensure that the subprogram and its formals are visible when analyzing -- the expression of the pragma. if Current_Scope /= Subp_Id then - Restore := True; + Restore_Scope := True; Push_Scope (Subp_Id); Install_Formals (Subp_Id); end if; @@ -18465,7 +18513,7 @@ package body Sem_Prag is -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. - if Restore then + if Restore_Scope then End_Scope; end if; end Analyze_Pre_Post_Condition_In_Decl_Part; @@ -18494,6 +18542,497 @@ package body Sem_Prag is null; end Analyze_Refined_Global_In_Decl_Part; + ---------------------------------------- + -- Analyze_Refined_State_In_Decl_Part -- + ---------------------------------------- + + procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is + Pack_Body : constant Node_Id := Parent (N); + Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body); + + Abstr_States : Elist_Id := No_Elist; + -- A list of all abstract states defined in the package declaration. The + -- list is used to report unrefined states. + + Constituents_Seen : Elist_Id := No_Elist; + -- A list that contains all constituents processed so far. The list is + -- used to detect multiple uses of the same constituent. + + Hidden_States : Elist_Id := No_Elist; + -- A list of all hidden states (abstract states and variables) that + -- appear in the package spec and body. The list is used to report + -- unused hidden states. + + Refined_States_Seen : Elist_Id := No_Elist; + -- A list that contains all refined states processed so far. The list is + -- used to detect duplicate refinements. + + procedure Analyze_Refinement_Clause (Clause : Node_Id); + -- Perform full analysis of a single refinement clause + + function Collect_Hidden_States return Elist_Id; + -- Gather the entities of all hidden states that appear in the spec and + -- body of the related package. + + procedure Report_Unrefined_States; + -- Emit errors for all abstract states that have not been refined by + -- the pragma. + + procedure Report_Unused_Hidden_States; + -- Emit errors for all hidden states of the related package that do not + -- participate in a refinement. + + ------------------------------- + -- Analyze_Refinement_Clause -- + ------------------------------- + + procedure Analyze_Refinement_Clause (Clause : Node_Id) is + Non_Null_Seen : Boolean := False; + Null_Seen : Boolean := False; + -- Flags used to detect multiple uses of null in a single clause or a + -- mixture of null and non-null constituents. + + procedure Analyze_Constituent (Constit : Node_Id); + -- Perform full analysis of a single constituent + + procedure Check_Matching_State + (State : Node_Id; + State_Id : Entity_Id); + -- Determine whether state State denoted by its name State_Id appears + -- in Abstr_States. Emit an error when attempting to re-refine the + -- state or when the state is not defined in the package declaration. + -- Otherwise remove the state from Abstr_States. + + ------------------------- + -- Analyze_Constituent -- + ------------------------- + + procedure Analyze_Constituent (Constit : Node_Id) is + procedure Check_Matching_Constituent (Constit_Id : Entity_Id); + -- Determine whether constituent Constit denoted by its entity + -- Constit_Id appears in Hidden_States. Emit an error when the + -- constituent is not a valid hidden state of the related package + -- or when it is used more than once. Otherwise remove the + -- constituent from Hidden_States. + + -------------------------------- + -- Check_Matching_Constituent -- + -------------------------------- + + procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is + State_Elmt : Elmt_Id; + + begin + -- Detect a duplicate use of a constituent + + if Contains (Constituents_Seen, Constit_Id) then + Error_Msg_NE + ("duplicate use of constituent &", Constit, Constit_Id); + return; + end if; + + -- Inspect the hidden states of the related package looking for + -- a match. + + State_Elmt := First_Elmt (Hidden_States); + while Present (State_Elmt) loop + + -- A valid hidden state or variable participates in a + -- refinement. Add the constituent to the list of processed + -- items to aid with the detection of duplicate constituent + -- use. Remove the constituent from Hidden_States to signal + -- that it has already been used. + + if Node (State_Elmt) = Constit_Id then + Add_Item (Constit_Id, Constituents_Seen); + Remove_Elmt (Hidden_States, State_Elmt); + + return; + end if; + + Next_Elmt (State_Elmt); + end loop; + + -- If we get here, we are refining a state that is not hidden + -- with respect to the related package. + + Error_Msg_Name_1 := Chars (Spec_Id); + Error_Msg_NE + ("cannot use & in refinement, constituent is not a hidden " + & "state of package %", Constit, Constit_Id); + end Check_Matching_Constituent; + + -- Local variables + + Constit_Id : Entity_Id; + + -- Start of processing for Analyze_Constituent + + begin + -- Detect multiple uses of null in a single refinement clause or a + -- mixture of null and non-null constituents. + + if Nkind (Constit) = N_Null then + if Null_Seen then + Error_Msg_N + ("multiple null constituents not allowed", Constit); + + elsif Non_Null_Seen then + Error_Msg_N + ("cannot mix null and non-null constituents", Constit); + + else + Null_Seen := True; + end if; + + -- Non-null constituents + + else + Non_Null_Seen := True; + + if Null_Seen then + Error_Msg_N + ("cannot mix null and non-null constituents", Constit); + end if; + + Analyze (Constit); + + -- Ensure that the constituent denotes a valid state or a + -- whole variable. + + if Is_Entity_Name (Constit) then + Constit_Id := Entity (Constit); + + if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then + Check_Matching_Constituent (Constit_Id); + else + Error_Msg_NE + ("constituent & must denote a variable or state", + Constit, Constit_Id); + end if; + + -- The constituent is illegal + + else + Error_Msg_N ("malformed constituent", Constit); + end if; + end if; + end Analyze_Constituent; + + -------------------------- + -- Check_Matching_State -- + -------------------------- + + procedure Check_Matching_State + (State : Node_Id; + State_Id : Entity_Id) + is + State_Elmt : Elmt_Id; + + begin + -- Detect a duplicate refinement of a state + + if Contains (Refined_States_Seen, State_Id) then + Error_Msg_NE + ("duplicate refinement of state &", State, State_Id); + return; + end if; + + -- Inspect the abstract states defined in the package declaration + -- looking for a match. + + State_Elmt := First_Elmt (Abstr_States); + while Present (State_Elmt) loop + + -- A valid abstract state is being refined in the body. Add + -- the state to the list of processed refined states to aid + -- with the detection of duplicate refinements. Remove the + -- state from Abstr_States to signal that it has already been + -- refined. + + if Node (State_Elmt) = State_Id then + Add_Item (State_Id, Refined_States_Seen); + Remove_Elmt (Abstr_States, State_Elmt); + + return; + end if; + + Next_Elmt (State_Elmt); + end loop; + + -- If we get here, we are refining a state that is not defined in + -- the package declaration. + + Error_Msg_Name_1 := Chars (Spec_Id); + Error_Msg_NE + ("cannot refine state, & is not defined in package %", + State, State_Id); + end Check_Matching_State; + + -- Local declarations + + Constit : Node_Id; + State : Node_Id; + State_Id : Entity_Id := Empty; + + -- Start of processing for Analyze_Refinement_Clause + + begin + -- Analyze the state name of a refinement clause + + State := First (Choices (Clause)); + while Present (State) loop + if Present (State_Id) then + Error_Msg_N + ("refinement clause cannot cover multiple states", State); + + else + Analyze (State); + + -- Ensure that the state name denotes a valid abstract state + -- that is defined in the spec of the related package. + + if Is_Entity_Name (State) then + State_Id := Entity (State); + + -- Catch any attempts to re-refine a state or refine a + -- state that is not defined in the package declaration. + + if Ekind (State_Id) = E_Abstract_State then + Check_Matching_State (State, State_Id); + else + Error_Msg_NE + ("& must denote an abstract state", State, State_Id); + end if; + + -- The state name is illegal + + else + Error_Msg_N + ("malformed state name in refinement clause", State); + end if; + end if; + + Next (State); + end loop; + + -- Analyze all constituents of the refinement. Multiple constituents + -- appear as an aggregate. + + Constit := Expression (Clause); + + if Nkind (Constit) = N_Aggregate then + if Present (Component_Associations (Constit)) then + Error_Msg_N + ("constituents of refinement clause must appear in " + & "positional form", Constit); + + else pragma Assert (Present (Expressions (Constit))); + Constit := First (Expressions (Constit)); + while Present (Constit) loop + Analyze_Constituent (Constit); + + Next (Constit); + end loop; + end if; + + -- Various forms of a single constituent. Note that these may include + -- malformed constituents. + + else + Analyze_Constituent (Constit); + end if; + end Analyze_Refinement_Clause; + + --------------------------- + -- Collect_Hidden_States -- + --------------------------- + + function Collect_Hidden_States return Elist_Id is + Result : Elist_Id := No_Elist; + + procedure Collect_Hidden_States_In_Decls (Decls : List_Id); + -- Find all hidden states that appear in declarative list Decls and + -- append their entities to Result. + + ------------------------------------ + -- Collect_Hidden_States_In_Decls -- + ------------------------------------ + + procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is + procedure Collect_Abstract_States (States : Elist_Id); + -- Copy the abstract states defined in list States to list Result + + ----------------------------- + -- Collect_Abstract_States -- + ----------------------------- + + procedure Collect_Abstract_States (States : Elist_Id) is + State_Elmt : Elmt_Id; + + begin + State_Elmt := First_Elmt (States); + while Present (State_Elmt) loop + Add_Item (Node (State_Elmt), Result); + + Next_Elmt (State_Elmt); + end loop; + end Collect_Abstract_States; + + -- Local variables + + Decl : Node_Id; + + -- Start of processing for Collect_Hidden_States_In_Decls + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Objects (non-constants) are valid hidden states + + if Nkind (Decl) = N_Object_Declaration + and then not Constant_Present (Decl) + then + Add_Item (Defining_Entity (Decl), Result); + + -- Gather the abstract states of a package along with all + -- hidden states in its visible declarations. + + elsif Nkind (Decl) = N_Package_Declaration then + Collect_Abstract_States + (Abstract_States (Defining_Entity (Decl))); + + Collect_Hidden_States_In_Decls + (Visible_Declarations (Specification (Decl))); + end if; + + Next (Decl); + end loop; + end Collect_Hidden_States_In_Decls; + + -- Local variables + + Pack_Spec : constant Node_Id := Parent (Spec_Id); + + -- Start of processing for Collect_Hidden_States + + begin + -- Process the private declarations of the package spec and the + -- declarations of the body. + + Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec)); + Collect_Hidden_States_In_Decls (Declarations (Pack_Body)); + + return Result; + end Collect_Hidden_States; + + ----------------------------- + -- Report_Unrefined_States -- + ----------------------------- + + procedure Report_Unrefined_States is + State_Elmt : Elmt_Id; + + begin + if Present (Abstr_States) then + State_Elmt := First_Elmt (Abstr_States); + while Present (State_Elmt) loop + Error_Msg_N + ("abstract state & must be refined", Node (State_Elmt)); + + Next_Elmt (State_Elmt); + end loop; + end if; + end Report_Unrefined_States; + + --------------------------------- + -- Report_Unused_Hidden_States -- + --------------------------------- + + procedure Report_Unused_Hidden_States is + Posted : Boolean := False; + State_Elmt : Elmt_Id; + State_Id : Entity_Id; + + begin + if Present (Hidden_States) then + State_Elmt := First_Elmt (Hidden_States); + while Present (State_Elmt) loop + State_Id := Node (State_Elmt); + + -- Generate an error message of the form: + + -- package ... has unused hidden states + -- abstract state ... defined at ... + -- variable ... defined at ... + + if not Posted then + Posted := True; + Error_Msg_NE + ("package & has unused hidden states", N, Spec_Id); + end if; + + Error_Msg_Sloc := Sloc (State_Id); + + if Ekind (State_Id) = E_Abstract_State then + Error_Msg_NE ("\ abstract state & defined #", N, State_Id); + else + Error_Msg_NE ("\ variable & defined #", N, State_Id); + end if; + + Next_Elmt (State_Elmt); + end loop; + end if; + end Report_Unused_Hidden_States; + + -- Local declarations + + Clauses : constant Node_Id := + Expression (First (Pragma_Argument_Associations (N))); + Clause : Node_Id; + + -- Start of processing for Analyze_Refined_State_In_Decl_Part + + begin + Set_Analyzed (N); + + -- Initialize the various lists used during analysis + + Abstr_States := Clone (Abstract_States (Spec_Id)); + Hidden_States := Collect_Hidden_States; + + -- Multiple state refinements appear as an aggregate + + if Nkind (Clauses) = N_Aggregate then + if Present (Expressions (Clauses)) then + Error_Msg_N + ("state refinements must appear as component associations", + Clauses); + + else pragma Assert (Present (Component_Associations (Clauses))); + Clause := First (Component_Associations (Clauses)); + while Present (Clause) loop + Analyze_Refinement_Clause (Clause); + + Next (Clause); + end loop; + end if; + + -- Various forms of a single state refinement. Note that these may + -- include malformed refinements. + + else + Analyze_Refinement_Clause (Clauses); + end if; + + -- Ensure that all abstract states have been refined and all hidden + -- states of the related package unilized in refinements. + + Report_Unrefined_States; + Report_Unused_Hidden_States; + end Analyze_Refined_State_In_Decl_Part; + ------------------------------------ -- Analyze_Test_Case_In_Decl_Part -- ------------------------------------ @@ -19250,6 +19789,7 @@ package body Sem_Prag is Pragma_Refined_Global => -1, Pragma_Refined_Post => -1, Pragma_Refined_Pre => -1, + Pragma_Refined_State => -1, Pragma_Relative_Deadline => -1, Pragma_Remote_Access_Type => -1, Pragma_Remote_Call_Interface => -1, diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 3b8114fef0d..a50757b3ef4 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -77,6 +77,9 @@ package Sem_Prag is procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id); -- Perform full analysis of delayed pragma Refined_Global + procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Refined_State + procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id); -- Perform preanalysis of pragma Test_Case that applies to a subprogram -- declaration. Parameter N denotes the pragma, S is the entity of the diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 8aed6308bae..ceb50f848cd 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -584,6 +584,10 @@ package Snames is Name_Refined_Global : constant Name_Id := N + $; -- GNAT Name_Refined_Post : constant Name_Id := N + $; -- GNAT Name_Refined_Pre : constant Name_Id := N + $; -- GNAT + + -- Kirchev + + Name_Refined_State : constant Name_Id := N + $; -- GNAT Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05 Name_Remote_Access_Type : constant Name_Id := N + $; -- GNAT Name_Remote_Call_Interface : constant Name_Id := N + $; @@ -1871,6 +1875,7 @@ package Snames is Pragma_Refined_Global, Pragma_Refined_Post, Pragma_Refined_Pre, + Pragma_Refined_State, Pragma_Relative_Deadline, Pragma_Remote_Access_Type, Pragma_Remote_Call_Interface,