diff options
Diffstat (limited to 'gcc/ada/sem_ch9.adb')
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 690 |
1 files changed, 482 insertions, 208 deletions
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 58a27c93256..6ee0bceeb81 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -67,25 +68,31 @@ package body Sem_Ch9 is ----------------------- function Allows_Lock_Free_Implementation - (N : Node_Id; - Complain : Boolean := False) return Boolean; + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean; -- This routine returns True iff N satisfies the following list of lock- -- free restrictions for protected type declaration and protected body: -- -- 1) Protected type declaration -- May not contain entries - -- Component types must support atomic compare and exchange + -- Protected subprogram declarations may not have non-elementary + -- parameters. -- -- 2) Protected Body -- Each protected subprogram body within N must satisfy: -- May reference only one protected component -- May not reference non-constant entities outside the protected -- subprogram scope. - -- May not reference non-elementary out parameters - -- May not contain loop statements or procedure calls + -- May not contain address representation items, allocators and + -- quantified expressions. + -- May not contain delay, goto, loop and procedure call + -- statements. + -- May not contain exported and imported entities + -- May not dereference access values -- Function calls and attribute references must be static -- - -- If Complain is True, an error message is issued when False is returned + -- If Lock_Free_Given is True, an error message is issued when False is + -- returned. procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); -- Given either a protected definition or a task definition in D, check @@ -115,22 +122,31 @@ package body Sem_Ch9 is ------------------------------------- function Allows_Lock_Free_Implementation - (N : Node_Id; - Complain : Boolean := False) return Boolean + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean is + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler so far + -- when Lock_Free_Given is True. + begin - pragma Assert (Nkind_In (N, - N_Protected_Type_Declaration, - N_Protected_Body)); + pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, + N_Protected_Body)); -- The lock-free implementation is currently enabled through a debug - -- flag. When Complain is True, an aspect Lock_Free forces the lock-free - -- implementation. In that case, the debug flag is not needed. + -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the + -- lock-free implementation. In that case, the debug flag is not needed. - if not Complain and then not Debug_Flag_9 then + if not Lock_Free_Given and then not Debug_Flag_9 then return False; end if; + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + -- Protected type declaration case if Nkind (N) = N_Protected_Type_Declaration then @@ -138,88 +154,71 @@ package body Sem_Ch9 is Pdef : constant Node_Id := Protected_Definition (N); Priv_Decls : constant List_Id := Private_Declarations (Pdef); Vis_Decls : constant List_Id := Visible_Declarations (Pdef); - - Comp_Id : Entity_Id; - Comp_Size : Int; - Comp_Type : Entity_Id; Decl : Node_Id; begin - -- Examine the visible declarations. Entries and entry families - -- are not allowed by the lock-free restrictions. + -- Examine the visible and the private declarations Decl := First (Vis_Decls); while Present (Decl) loop - if Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; - - return False; - end if; - - Next (Decl); - end loop; - - -- Examine the private declarations - - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- The protected type must define at least one scalar component - if Nkind (Decl) = N_Component_Declaration then - Comp_Id := Defining_Identifier (Decl); - Comp_Type := Etype (Comp_Id); - - -- Make sure the protected component type has size and - -- alignment fields set at this point whenever this is - -- possible. - - Layout_Type (Comp_Type); - - if Known_Esize (Comp_Type) then - Comp_Size := UI_To_Int (Esize (Comp_Type)); - - -- If the Esize (Object_Size) is unknown at compile-time, - -- look at the RM_Size (Value_Size) since it may have been - -- set by an explicit representation clause. + -- Entries and entry families are not allowed by the lock-free + -- restrictions. + if Nkind (Decl) = N_Entry_Declaration then + if Lock_Free_Given then + Error_Msg_N + ("entry not allowed when Lock_Free given", Decl); else - Comp_Size := UI_To_Int (RM_Size (Comp_Type)); + return False; end if; - -- Check that the size of the component is 8, 16, 32 or 64 - -- bits. - - case Comp_Size is - when 8 | 16 | 32 | 64 => - null; - when others => - if Complain then - Error_Msg_N ("must support atomic operations for " & - "lock-free implementation", - Decl); - end if; + -- Non-elementary parameters in protected procedure are not + -- allowed by the lock-free restrictions. - return False; - end case; + elsif Nkind (Decl) = N_Subprogram_Declaration + and then + Nkind (Specification (Decl)) = N_Procedure_Specification + and then + Present (Parameter_Specifications (Specification (Decl))) + then + declare + Par_Specs : constant List_Id := + Parameter_Specifications + (Specification (Decl)); - -- Entries and entry families are not allowed + Par : Node_Id; - elsif Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; + begin + Par := First (Par_Specs); + while Present (Par) loop + if not Is_Elementary_Type + (Etype (Defining_Identifier (Par))) + then + if Lock_Free_Given then + Error_Msg_NE + ("non-elementary parameter& not allowed " + & "when Lock_Free given", + Par, Defining_Identifier (Par)); + else + return False; + end if; + end if; - return False; + Next (Par); + end loop; + end; end if; - Next (Decl); + -- Examine private declarations after visible declarations + + if No (Next (Decl)) + and then List_Containing (Decl) = Vis_Decls + then + Decl := First (Priv_Decls); + else + Next (Decl); + end if; end loop; end; @@ -248,9 +247,18 @@ package body Sem_Ch9 is function Satisfies_Lock_Free_Requirements (Sub_Body : Node_Id) return Boolean is + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (Sub_Body)) = + E_Procedure; + -- Indicates if Sub_Body is a procedure body + Comp : Entity_Id := Empty; -- Track the current component which the body references + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler + -- so far when Lock_Free_Given is True. + function Check_Node (N : Node_Id) return Traverse_Result; -- Check that node N meets the lock free restrictions @@ -259,153 +267,361 @@ package body Sem_Ch9 is ---------------- function Check_Node (N : Node_Id) return Traverse_Result is - begin - -- Function calls and attribute references must be static + Kind : constant Node_Kind := Nkind (N); - if Nkind (N) = N_Attribute_Reference - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N - ("non-static attribute reference not allowed", - N); - end if; + -- The following function belongs in sem_eval ??? - return Abandon; + function Is_Static_Function (Attr : Node_Id) return Boolean; + -- Given an attribute reference node Attr, return True if + -- Attr denotes a static function according to the rules in + -- (RM 4.9 (22)). - elsif Nkind (N) = N_Function_Call - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N ("non-static function call not allowed", - N); - end if; + ------------------------ + -- Is_Static_Function -- + ------------------------ - return Abandon; + function Is_Static_Function + (Attr : Node_Id) return Boolean + is + Para : Node_Id; - -- Loop statements and procedure calls are prohibited + begin + pragma Assert (Nkind (Attr) = N_Attribute_Reference); + + case Attribute_Name (Attr) is + when Name_Min | + Name_Max | + Name_Pred | + Name_Succ | + Name_Value | + Name_Wide_Value | + Name_Wide_Wide_Value => + + -- A language-defined attribute denotes a static + -- function if the prefix denotes a static scalar + -- subtype, and if the parameter and result types + -- are scalar (RM 4.9 (22)). + + if Is_Scalar_Type (Etype (Attr)) + and then Is_Scalar_Type (Etype (Prefix (Attr))) + and then Is_Static_Subtype (Etype (Prefix (Attr))) + then + Para := First (Expressions (Attr)); + + while Present (Para) loop + if not Is_Scalar_Type (Etype (Para)) then + return False; + end if; - elsif Nkind (N) = N_Loop_Statement then - if Complain then - Error_Msg_N ("loop not allowed", N); - end if; + Next (Para); + end loop; - return Abandon; + return True; - elsif Nkind (N) = N_Procedure_Call_Statement then - if Complain then - Error_Msg_N ("procedure call not allowed", N); - end if; + else + return False; + end if; - return Abandon; + when others => return False; + end case; + end Is_Static_Function; - -- References + -- Start of processing for Check_Node - elsif Nkind (N) = N_Identifier - and then Present (Entity (N)) - then - declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := - Corresponding_Spec (Sub_Body); + begin + if Is_Procedure then + -- Allocators restricted - begin - -- Prohibit references to non-constant entities - -- outside the protected subprogram scope. - - if Ekind (Id) in Assignable_Kind - and then not Scope_Within_Or_Same (Scope (Id), - Sub_Id) - and then not Scope_Within_Or_Same (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) - then - if Complain then - Error_Msg_NE - ("reference to global variable& not allowed", - N, Id); + if Kind = N_Allocator then + if Lock_Free_Given then + Error_Msg_N ("allocator not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Aspects Address, Export and Import restricted + + elsif Kind = N_Aspect_Specification then + declare + Asp_Name : constant Name_Id := + Chars (Identifier (N)); + Asp_Id : constant Aspect_Id := + Get_Aspect_Id (Asp_Name); + + begin + if Asp_Id = Aspect_Address or else + Asp_Id = Aspect_Export or else + Asp_Id = Aspect_Import + then + Error_Msg_Name_1 := Asp_Name; + + if Lock_Free_Given then + Error_Msg_N ("aspect% not allowed", N); + return Skip; + end if; + + return Abandon; end if; + end; - return Abandon; + -- Address attribute definition clause restricted - -- Prohibit non-scalar out parameters (scalar - -- parameters are passed by copy). + elsif Kind = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = + Attribute_Address + then + Error_Msg_Name_1 := Chars (N); - elsif Ekind_In (Id, E_Out_Parameter, - E_In_Out_Parameter) - and then not Is_Elementary_Type (Etype (Id)) - and then Scope_Within_Or_Same (Scope (Id), Sub_Id) - then - if Complain then - Error_Msg_NE - ("non-elementary out parameter& not allowed", - N, Id); + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("% clause not allowed", N); end if; - return Abandon; - - -- A protected subprogram may reference only one - -- component of the protected type. - - elsif Ekind (Id) = E_Component then - declare - Comp_Decl : constant Node_Id := Parent (Id); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Id; - - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. - - elsif Comp /= Id then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); - end if; + return Skip; + end if; - return Abandon; + return Abandon; + + -- Non-static Attribute references that don't denote a + -- static function restricted. + + elsif Kind = N_Attribute_Reference + and then not Is_Static_Expression (N) + and then not Is_Static_Function (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static attribute reference not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Delay statements restricted + + elsif Kind in N_Delay_Statement then + if Lock_Free_Given then + Error_Msg_N ("delay not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Dereferences of access values restricted + + elsif Kind = N_Explicit_Dereference + or else (Kind = N_Selected_Component + and then Is_Access_Type (Etype (Prefix (N)))) + then + if Lock_Free_Given then + Error_Msg_N + ("dereference of access value not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Non-static function calls restricted + + elsif Kind = N_Function_Call + and then not Is_Static_Expression (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static function call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Goto statements restricted + + elsif Kind = N_Goto_Statement then + if Lock_Free_Given then + Error_Msg_N ("goto statement not allowed", N); + return Skip; + end if; + + return Abandon; + + -- References + + elsif Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); + + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not + Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not + Scope_Within_Or_Same + (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Lock_Free_Given then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Loop statements restricted + + elsif Kind = N_Loop_Statement then + if Lock_Free_Given then + Error_Msg_N ("loop not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Pragmas Export and Import restricted + + elsif Kind = N_Pragma then + declare + Prag_Name : constant Name_Id := Pragma_Name (N); + Prag_Id : constant Pragma_Id := + Get_Pragma_Id (Prag_Name); + + begin + if Prag_Id = Pragma_Export + or else Prag_Id = Pragma_Import + then + Error_Msg_Name_1 := Prag_Name; + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("pragma% not allowed", N); end if; + + return Skip; end if; - end; + + return Abandon; + end if; + end; + + -- Procedure call statements restricted + + elsif Kind = N_Procedure_Call_Statement then + if Lock_Free_Given then + Error_Msg_N ("procedure call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Quantified expression restricted. Note that we have + -- to check the original node as well, since at this + -- stage, it may have been rewritten. + + elsif Kind = N_Quantified_Expression + or else + Nkind (Original_Node (N)) = N_Quantified_Expression + then + if Lock_Free_Given then + Error_Msg_N + ("quantified expression not allowed", N); + return Skip; + end if; + + return Abandon; + end if; + end if; + + -- A protected subprogram (function or procedure) may + -- reference only one component of the protected type, plus + -- the type of the component must support atomic operation. + + if Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Comp_Decl : Node_Id; + Comp_Id : Entity_Id := Empty; + Comp_Type : Entity_Id; + + begin + if Ekind (Id) = E_Component then + Comp_Id := Id; elsif Ekind_In (Id, E_Constant, E_Variable) and then Present (Prival_Link (Id)) then - declare - Comp_Decl : constant Node_Id := - Parent (Prival_Link (Id)); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Prival_Link (Id); - - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. - - elsif Comp /= Prival_Link (Id) then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); + Comp_Id := Prival_Link (Id); + end if; + + if Present (Comp_Id) then + Comp_Decl := Parent (Comp_Id); + Comp_Type := Etype (Comp_Id); + + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Priv_Decls + then + -- Skip generic types since, in that case, we + -- will not build a body anyway (in the generic + -- template), and the size in the template may + -- have a fake value. + + if not Is_Generic_Type (Comp_Type) then + + -- Make sure the protected component type has + -- size and alignment fields set at this + -- point whenever this is possible. + + Layout_Type (Comp_Type); + + if not + Support_Atomic_Primitives (Comp_Type) + then + if Lock_Free_Given then + Error_Msg_NE + ("type of& must support atomic " & + "operations", + N, Comp_Id); + return Skip; end if; return Abandon; end if; end if; - end; + + -- Check if another protected component has + -- already been accessed by the subprogram body. + + if No (Comp) then + Comp := Comp_Id; + + elsif Comp /= Comp_Id then + if Lock_Free_Given then + Error_Msg_N + ("only one protected component allowed", + N); + return Skip; + end if; + + return Abandon; + end if; + end if; end if; end; end if; @@ -418,8 +634,16 @@ package body Sem_Ch9 is -- Start of processing for Satisfies_Lock_Free_Requirements begin - if Check_All_Nodes (Sub_Body) = OK then + -- Get the number of errors detected by the compiler so far + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + + if Check_All_Nodes (Sub_Body) = OK + and then (not Lock_Free_Given + or else Errors_Count = Serious_Errors_Detected) + then -- Establish a relation between the subprogram body and the -- unique protected component it references. @@ -438,17 +662,16 @@ package body Sem_Ch9 is begin Decl := First (Decls); - while Present (Decl) loop if Nkind (Decl) = N_Subprogram_Body and then not Satisfies_Lock_Free_Requirements (Decl) then - if Complain then - Error_Msg_N ("body prevents lock-free implementation", - Decl); + if Lock_Free_Given then + Error_Msg_N + ("illegal body when Lock_Free given", Decl); + else + return False; end if; - - return False; end if; Next (Decl); @@ -456,6 +679,15 @@ package body Sem_Ch9 is end Protected_Body_Case; end if; + -- When Lock_Free is given, check if no error has been detected during + -- the process. + + if Lock_Free_Given + and then Errors_Count /= Serious_Errors_Detected + then + return False; + end if; + return True; end Allows_Lock_Free_Implementation; @@ -484,7 +716,7 @@ package body Sem_Ch9 is else if Ada_Version >= Ada_2005 then Error_Msg_N ("expect task name or task interface class-wide " - & "object for ABORT", T_Name); + & "object for ABORT", T_Name); else Error_Msg_N ("expect task name for ABORT", T_Name); end if; @@ -1455,14 +1687,17 @@ package body Sem_Ch9 is begin if Present (Ritem) then + -- Pragma with one argument if Nkind (Ritem) = N_Pragma and then Present (Pragma_Argument_Associations (Ritem)) then return - Is_False (Static_Boolean - (Expression (First (Pragma_Argument_Associations (Ritem))))); + Is_False + (Static_Boolean + (Expression + (First (Pragma_Argument_Associations (Ritem))))); -- Aspect Specification with expression present @@ -1548,7 +1783,7 @@ package body Sem_Ch9 is -- otherwise Allows_Lock_Free_Implementation issues an error message. if Uses_Lock_Free (Spec_Id) then - if not Allows_Lock_Free_Implementation (N, Complain => True) then + if not Allows_Lock_Free_Implementation (N, True) then return; end if; @@ -1784,7 +2019,46 @@ package body Sem_Ch9 is -- issued by Allows_Lock_Free_Implementation. if Uses_Lock_Free (Defining_Identifier (N)) then - if not Allows_Lock_Free_Implementation (N, Complain => True) then + + -- Complain when there is an explicit aspect/pragma Priority (or + -- Interrupt_Priority) while the lock-free implementation is forced + -- by an aspect/pragma. + + declare + Id : constant Entity_Id := + Defining_Identifier (Original_Node (N)); + -- The warning must be issued on the original identifier in order + -- to deal properly with the case of a single protected object. + + Prio_Item : constant Node_Id := + Get_Rep_Item + (Defining_Identifier (N), + Name_Priority, + Check_Parents => False); + + begin + if Present (Prio_Item) then + + -- Aspect case + + if Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item) + then + Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); + Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + + -- Pragma case + + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + end if; + end if; + end; + + if not Allows_Lock_Free_Implementation (N, True) then return; end if; end if; |