From ac8380d5d8e2d9b4a82f000b5d95165124a73a95 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 6 Jan 2017 11:48:39 +0100 Subject: [PATCH] [multiple changes] 2017-01-06 Yannick Moy * ghost.adb Minor fixing of references to SPARK RM. (Check_Ghost_Context): Check whether reference is to a lvalue before issuing an error about violation of SPARK RM 6.9(13) when declaration has Ghost policy Check and reference has Ghost policy Ignore. * sem_util.adb Minor indentation. * sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub, Analyze_Task_Body_Stub): Set Ekind of the defining identifier. * sem_util.ads (Unique_Defining_Entity): Document the result for package body stubs. 2017-01-06 Tristan Gingold * raise-gcc.c (abort): Macro to call Abort_Propagation. * s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access constant. * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Do not generate the Entry_Max_Queue_Lengths_Array if all default values. * exp_util.adb (Corresponding_Runtime_Package): Consider Max_Queue_Length pragma. From-SVN: r244129 --- gcc/ada/ChangeLog | 24 +++++++ gcc/ada/exp_ch9.adb | 168 ++++++++++++++++++++----------------------- gcc/ada/exp_util.adb | 42 ++++++++++- gcc/ada/ghost.adb | 31 ++++---- gcc/ada/raise-gcc.c | 7 +- gcc/ada/s-tpoben.ads | 2 +- gcc/ada/sem_ch10.adb | 3 + gcc/ada/sem_util.adb | 5 +- gcc/ada/sem_util.ads | 8 +-- 9 files changed, 172 insertions(+), 118 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 66cacf11b3b..a4c2eb3fca9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2017-01-06 Yannick Moy + + * ghost.adb Minor fixing of references to SPARK RM. + (Check_Ghost_Context): Check whether reference is to a lvalue + before issuing an error about violation of SPARK RM 6.9(13) + when declaration has Ghost policy Check and reference has Ghost + policy Ignore. + * sem_util.adb Minor indentation. + * sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub, + Analyze_Task_Body_Stub): Set Ekind of the defining identifier. + * sem_util.ads (Unique_Defining_Entity): Document the result + for package body stubs. + +2017-01-06 Tristan Gingold + + * raise-gcc.c (abort): Macro to call Abort_Propagation. + * s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access + constant. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): + Do not generate the Entry_Max_Queue_Lengths_Array if all default + values. + * exp_util.adb (Corresponding_Runtime_Package): Consider + Max_Queue_Length pragma. + 2017-01-06 Justin Squirek * exp_ch9.adb (Expand_N_Protected_Type_Declaration): diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6d31de7670b..0b029426cdc 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -9767,102 +9767,85 @@ package body Exp_Ch9 is -- type. This object is later passed to the appropriate protected object -- initialization routine. - declare - Max : Uint; - Maxs : constant List_Id := New_List; - Count : Int; - Item : Entity_Id; - Maxs_Id : Entity_Id; - Max_Vals : Node_Id; - - begin - if Has_Entries (Prot_Typ) then + if Has_Entries (Prot_Typ) then + declare + Need_Array : Boolean := False; + Maxs : List_Id; + Count : Int; + Item : Entity_Id; + Maxs_Id : Entity_Id; + Max_Vals : Node_Id; - -- Gather the Max_Queue_Length values of all entries in a list. A - -- value of zero indicates that the entry has no limitation on its - -- queue length. + begin + -- First check if there is any Max_Queue_Length pragma - Count := 0; Item := First_Entity (Prot_Typ); while Present (Item) loop - if Is_Entry (Item) then - Count := Count + 1; - Max := Get_Max_Queue_Length (Item); - - -- The package System_Tasking_Protected_Objects_Single_Entry - -- is only used in cases where queue length is 1, so if this - -- package is being used and there is a value supplied for - -- it print an error message and halt compilation. - - if Max /= 0 - and then Corresponding_Runtime_Package (Prot_Typ) = - System_Tasking_Protected_Objects_Single_Entry - then - Error_Msg_N - ("max_queue_length cannot be applied to entries under " - & "the Ravenscar profile", Item); - raise Program_Error; - end if; - - Append_To (Maxs, Make_Integer_Literal (Loc, Intval => Max)); + if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then + Need_Array := True; + exit; end if; - Next_Entity (Item); end loop; - case Corresponding_Runtime_Package (Prot_Typ) is - when System_Tasking_Protected_Objects_Entries => - - -- Create the declaration of the array object. Generate: - - -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array - -- (1 .. Count) := (..., ...); - - Maxs_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Prot_Typ), 'B')); - - Max_Vals := - Make_Object_Declaration (Loc, - Defining_Identifier => Maxs_Id, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Make_Integer_Literal (Loc, 1), - Make_Integer_Literal (Loc, Count))))), - Expression => Make_Aggregate (Loc, Maxs)); - - -- A pointer to this array will be placed in the - -- corresponding record by its initialization procedure so - -- this needs to be analyzed here. + -- Gather the Max_Queue_Length values of all entries in a list. A + -- value of zero indicates that the entry has no limitation on its + -- queue length. - Insert_After (Current_Node, Max_Vals); - Current_Node := Max_Vals; - Analyze (Max_Vals); + if Need_Array then + Maxs := New_List; + Count := 0; + Item := First_Entity (Prot_Typ); + while Present (Item) loop + if Is_Entry (Item) then + Count := Count + 1; + Append_To (Maxs, + Make_Integer_Literal (Loc, + Get_Max_Queue_Length (Item))); + end if; - Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id); + Next_Entity (Item); + end loop; - when System_Tasking_Protected_Objects_Single_Entry => + -- Create the declaration of the array object. Generate: - -- If this section is entered this means the package - -- System_Tasking_Protected_Objects_Single_Entry is being - -- used and that it correctly has no Max_Queue_Length - -- specified, so fall through and continue normally. + -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array + -- (1 .. Count) := (..., ...); - null; + Maxs_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Prot_Typ), 'B')); - when others => - raise Program_Error; - end case; - end if; - end; + Max_Vals := + Make_Object_Declaration (Loc, + Defining_Identifier => Maxs_Id, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, Count))))), + Expression => Make_Aggregate (Loc, Maxs)); + + -- A pointer to this array will be placed in the + -- corresponding record by its initialization procedure so + -- this needs to be analyzed here. + + Insert_After (Current_Node, Max_Vals); + Current_Node := Max_Vals; + Analyze (Max_Vals); + + Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id); + end if; + end; + end if; -- Emit declaration for Entry_Bodies_Array, now that the addresses of -- all protected subprograms have been collected. @@ -14209,19 +14192,24 @@ package body Exp_Ch9 is raise Program_Error; end case; - -- Entry_Queue_Maxs parameter. This is a pointer to an array of + -- Entry_Queue_Maxs parameter. This is an access to an array of -- naturals representing the entry queue maximums for each entry - -- in the protected type. Zero represents no max. + -- in the protected type. Zero represents no max. The access is + -- null if there is no limit for all entries (usual case). if Has_Entry and then Pkg_Id /= System_Tasking_Protected_Objects_Single_Entry then - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), - Attribute_Name => Name_Unrestricted_Access)); + if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + Append_To (Args, Make_Null (Loc)); + end if; -- Edge cases exist where entry initialization functions are -- called, but no entries exist, so null is appended. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 05dbf8f1cfa..29d167b8b6c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2020,6 +2020,45 @@ package body Exp_Util is ----------------------------------- function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is + + function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean; + -- Return True if protected type T has one entry and the maximum queue + -- length is one. + + -------------------------------- + -- Has_One_Entry_And_No_Queue -- + -------------------------------- + + function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is + Is_First : Boolean := True; + Ent : Entity_Id; + begin + Ent := First_Entity (T); + while Present (Ent) loop + if Is_Entry (Ent) then + if not Is_First then + -- More than one entry + + return False; + end if; + + if not Restriction_Active (No_Entry_Queue) + and then Get_Max_Queue_Length (Ent) /= Uint_1 + then + -- Max queue length is not 1 + + return False; + end if; + + Is_First := False; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return True; + end Has_One_Entry_And_No_Queue; + Pkg_Id : RTU_Id := RTU_Null; begin @@ -2047,9 +2086,8 @@ package body Exp_Util is or else Has_Interrupt_Handler (Typ) then if Abort_Allowed - or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Select_Statements) = False - or else Number_Entries (Typ) > 1 + or else not Has_One_Entry_And_No_Queue (Typ) or else (Has_Attach_Handler (Typ) and then not Restricted_Profile) then diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 8621aea1514..26ea406f433 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -148,10 +148,10 @@ package body Ghost is ------------------------- procedure Check_Ghost_Context (Ghost_Id : Entity_Id; Ghost_Ref : Node_Id) is - procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id); + procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id); -- Verify that the Ghost policy at the point of declaration of entity Id - -- matches the policy at the point of reference. If this is not the case - -- emit an error at Err_N. + -- matches the policy at the point of reference Ref. If this is not the + -- case emit an error at Ref. function Is_OK_Ghost_Context (Context : Node_Id) return Boolean; -- Determine whether node Context denotes a Ghost-friendly context where @@ -539,26 +539,29 @@ package body Ghost is -- Check_Ghost_Policy -- ------------------------ - procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id) is + procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id) is Policy : constant Name_Id := Policy_In_Effect (Name_Ghost); begin -- The Ghost policy in effect a the point of declaration and at the -- point of use must match (SPARK RM 6.9(13)). - if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then - Error_Msg_Sloc := Sloc (Err_N); + if Is_Checked_Ghost_Entity (Id) + and then Policy = Name_Ignore + and then May_Be_Lvalue (Ref) + then + Error_Msg_Sloc := Sloc (Ref); - Error_Msg_N ("incompatible ghost policies in effect", Err_N); - Error_Msg_NE ("\& declared with ghost policy `Check`", Err_N, Id); - Error_Msg_NE ("\& used # with ghost policy `Ignore`", Err_N, Id); + Error_Msg_N ("incompatible ghost policies in effect", Ref); + Error_Msg_NE ("\& declared with ghost policy `Check`", Ref, Id); + Error_Msg_NE ("\& used # with ghost policy `Ignore`", Ref, Id); elsif Is_Ignored_Ghost_Entity (Id) and then Policy = Name_Check then - Error_Msg_Sloc := Sloc (Err_N); + Error_Msg_Sloc := Sloc (Ref); - Error_Msg_N ("incompatible ghost policies in effect", Err_N); - Error_Msg_NE ("\& declared with ghost policy `Ignore`", Err_N, Id); - Error_Msg_NE ("\& used # with ghost policy `Check`", Err_N, Id); + Error_Msg_N ("incompatible ghost policies in effect", Ref); + Error_Msg_NE ("\& declared with ghost policy `Ignore`", Ref, Id); + Error_Msg_NE ("\& used # with ghost policy `Check`", Ref, Id); end if; end Check_Ghost_Policy; @@ -573,7 +576,7 @@ package body Ghost is Check_Ghost_Policy (Ghost_Id, Ghost_Ref); -- Otherwise the Ghost entity appears in a non-Ghost context and affects - -- its behavior or value (SPARK RM 6.9(11,12)). + -- its behavior or value (SPARK RM 6.9(10,11)). else Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref); diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index a2b6f645db6..0074ad53fbc 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -86,12 +86,9 @@ extern struct Exception_Occurrence *__gnat_setup_current_excep extern void __gnat_unhandled_except_handler (_Unwind_Exception *); #ifdef CERT +/* Called in case of error during propagation. */ +extern void __gnat_raise_abort (void) __attribute__ ((noreturn)); #define abort() __gnat_raise_abort() -static void __gnat_raise_abort(void) -{ - while (1) - ; -} #endif #include "unwind-pe.h" diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 79c9c4407c4..28a00990328 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -70,7 +70,7 @@ package System.Tasking.Protected_Objects.Entries is array (Positive_Protected_Entry_Index range <>) of Natural; type Protected_Entry_Queue_Max_Access is - access all Protected_Entry_Queue_Max_Array; + access constant Protected_Entry_Queue_Max_Array; -- The following declarations define an array that contains the string -- names of entries and entry family members, together with an associated diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index bc842e449cb..e0baf7b0e49 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1590,6 +1590,7 @@ package body Sem_Ch10 is Set_Has_Completion (Nam); Set_Scope (Defining_Entity (N), Current_Scope); + Set_Ekind (Defining_Entity (N), E_Package_Body); Set_Corresponding_Spec_Of_Stub (N, Nam); Generate_Reference (Nam, Id, 'b'); Analyze_Proper_Body (N, Nam); @@ -1931,6 +1932,7 @@ package body Sem_Ch10 is else Set_Scope (Defining_Entity (N), Current_Scope); + Set_Ekind (Defining_Entity (N), E_Protected_Body); Set_Has_Completion (Etype (Nam)); Set_Corresponding_Spec_Of_Stub (N, Nam); Generate_Reference (Nam, Defining_Identifier (N), 'b'); @@ -2384,6 +2386,7 @@ package body Sem_Ch10 is else Set_Scope (Defining_Entity (N), Current_Scope); + Set_Ekind (Defining_Entity (N), E_Task_Body); Generate_Reference (Nam, Defining_Identifier (N), 'b'); Set_Corresponding_Spec_Of_Stub (N, Nam); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 15d2240648d..cd75585ea89 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8375,13 +8375,14 @@ package body Sem_Util is -------------------------- function Get_Max_Queue_Length (Id : Entity_Id) return Uint is + pragma Assert (Is_Entry (Id)); Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length); begin -- A value of 0 represents no maximum specified, and entries and entry -- families with no Max_Queue_Length aspect or pragma default to it. - if not Has_Max_Queue_Length (Id) or else not Present (Prag) then + if not Present (Prag) then return Uint_0; end if; @@ -15677,7 +15678,7 @@ package body Sem_Util is when N_Assignment_Statement => return N = Name (P); - -- Function call arguments are never lvalues + -- Function call arguments are never lvalues when N_Function_Call => return False; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a0f34770bb8..b1559ad9c19 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2344,12 +2344,12 @@ package Sem_Util is -- Return the entity which represents declaration N, so that different -- views of the same entity have the same unique defining entity: -- * entry declaration and entry body - -- * package spec and body - -- * protected type declaration, protected body stub and protected body + -- * package spec, package body, and package body stub + -- * protected type declaration, protected body and protected body stub -- * private view and full view of a deferred constant -- * private view and full view of a type - -- * subprogram declaration, subprogram stub and subprogram body - -- * task type declaration, task body stub and task body + -- * subprogram declaration, subprogram and subprogram body stub + -- * task type declaration, task body and task body stub -- In other cases, return the defining entity for N. function Unique_Entity (E : Entity_Id) return Entity_Id; -- 2.30.2