===================================================================
@@ -139,87 +139,69 @@
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;
+ 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
+
+ -- Entries and entry families are not allowed by the lock-free
+ -- restrictions.
+
if Nkind (Decl) = N_Entry_Declaration then
if Complain then
- Error_Msg_N ("entry not allowed for lock-free " &
- "implementation",
+ Error_Msg_N ("entry not allowed when Lock_Free given",
Decl);
end if;
return False;
- end if;
- Next (Decl);
- end loop;
+ -- Non-elementary out parameters in protected procedure are not
+ -- allowed by the lock-free restrictions.
- -- Examine the private declarations
+ 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));
+ Par : constant Node_Id := First (Par_Specs);
+ Par_Typ : constant Entity_Id :=
+ Etype (Parameter_Type (Par));
- 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.
-
- else
- Comp_Size := UI_To_Int (RM_Size (Comp_Type));
- 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 =>
+ begin
+ if Out_Present (Par)
+ and then not Is_Elementary_Type (Par_Typ)
+ then
if Complain then
- Error_Msg_N ("must support atomic operations for " &
- "lock-free implementation",
- Decl);
+ Error_Msg_NE
+ ("non-elementary out parameter& not allowed " &
+ "when Lock_Free given",
+ Par,
+ Defining_Identifier (Par));
end if;
return False;
- end case;
+ end if;
+ end;
+ end if;
- -- Entries and entry families are not allowed
+ -- Examine the private declarations after the visible
+ -- declarations.
- elsif Nkind (Decl) = N_Entry_Declaration then
- if Complain then
- Error_Msg_N ("entry not allowed for lock-free " &
- "implementation",
- Decl);
- end if;
-
- return False;
+ if No (Next (Decl))
+ and then List_Containing (Decl) = Vis_Decls
+ then
+ Decl := First (Priv_Decls);
+ else
+ Next (Decl);
end if;
-
- Next (Decl);
end loop;
end;
@@ -248,6 +230,11 @@
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
@@ -260,152 +247,160 @@
function Check_Node (N : Node_Id) return Traverse_Result is
begin
- -- Function calls and attribute references must be static
+ if Is_Procedure then
+ -- Function calls and attribute references must be static
- 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;
+ 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;
- return Abandon;
+ return Abandon;
- 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;
+ 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;
- return Abandon;
+ return Abandon;
- -- Loop statements and procedure calls are prohibited
+ -- Loop statements and procedure calls are prohibited
- elsif Nkind (N) = N_Loop_Statement then
- if Complain then
- Error_Msg_N ("loop not allowed", N);
- end if;
+ elsif Nkind (N) = N_Loop_Statement then
+ if Complain then
+ Error_Msg_N ("loop not allowed", N);
+ end if;
- return Abandon;
+ return Abandon;
- elsif Nkind (N) = N_Procedure_Call_Statement then
- if Complain then
- Error_Msg_N ("procedure call not allowed", N);
+ elsif Nkind (N) = N_Procedure_Call_Statement then
+ if Complain then
+ Error_Msg_N ("procedure call not allowed", N);
+ end if;
+
+ return Abandon;
+
+ -- References
+
+ 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
+ -- 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);
+ end if;
+
+ return Abandon;
+ end if;
+ end;
end if;
+ end if;
- return Abandon;
+ -- 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.
- -- References
-
- elsif Nkind (N) = N_Identifier
+ if 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);
+ Id : constant Entity_Id := Entity (N);
+ Comp_Decl : Node_Id;
+ Comp_Id : Entity_Id := Empty;
+ Comp_Size : Int;
+ Comp_Type : Entity_Id;
begin
- -- Prohibit references to non-constant entities
- -- outside the protected subprogram scope.
+ if Ekind (Id) = E_Component then
+ Comp_Id := Id;
- 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))
+ elsif Ekind_In (Id, E_Constant, E_Variable)
+ and then Present (Prival_Link (Id))
then
- if Complain then
- Error_Msg_NE
- ("reference to global variable& not allowed",
- N, Id);
- end if;
+ Comp_Id := Prival_Link (Id);
+ end if;
- return Abandon;
+ if Present (Comp_Id) then
+ Comp_Decl := Parent (Comp_Id);
+ Comp_Type := Etype (Comp_Id);
- -- Prohibit non-scalar out parameters (scalar
- -- parameters are passed by copy).
+ if Nkind (Comp_Decl) = N_Component_Declaration
+ and then Is_List_Member (Comp_Decl)
+ and then List_Containing (Comp_Decl) = Priv_Decls
+ then
+ -- Make sure the protected component type has
+ -- size and alignment fields set at this point
+ -- whenever this is possible.
- 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);
- end if;
+ Layout_Type (Comp_Type);
- return Abandon;
+ if Known_Esize (Comp_Type) then
+ Comp_Size := UI_To_Int (Esize (Comp_Type));
- -- A protected subprogram may reference only one
- -- component of the protected 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.
- 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;
+ else
+ Comp_Size := UI_To_Int (RM_Size (Comp_Type));
+ end if;
- -- Check if another protected component has
- -- already been accessed by the subprogram
- -- body.
+ -- Check that the size of the component is 8,
+ -- 16, 32 or 64 bits.
- elsif Comp /= Id then
+ case Comp_Size is
+ when 8 | 16 | 32 | 64 =>
+ null;
+ when others =>
if Complain then
- Error_Msg_N
- ("only one protected component " &
- "allowed",
- N);
+ Error_Msg_NE
+ ("type of& must support atomic " &
+ "operations",
+ N, Comp_Id);
end if;
return Abandon;
- end if;
- end if;
- end;
+ end case;
- 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.
- -- Check if another protected component has
- -- already been accessed by the subprogram
- -- body.
+ if No (Comp) then
+ Comp := Id;
- elsif Comp /= Prival_Link (Id) then
- if Complain then
- Error_Msg_N
- ("only one protected component " &
- "allowed",
- N);
- end if;
+ elsif Comp /= Id then
+ if Complain then
+ Error_Msg_N
+ ("only one protected component allowed",
+ N);
+ end if;
- return Abandon;
- end if;
+ return Abandon;
end if;
- end;
+ end if;
end if;
end;
end if;
@@ -444,7 +439,7 @@
and then not Satisfies_Lock_Free_Requirements (Decl)
then
if Complain then
- Error_Msg_N ("body prevents lock-free implementation",
+ Error_Msg_N ("body not allowed when Lock_Free given",
Decl);
end if;
@@ -1787,6 +1782,43 @@
-- issued by Allows_Lock_Free_Implementation.
if Uses_Lock_Free (Defining_Identifier (N)) 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, Complain => True) then
return;
end if;
This patch reorganizes the Lock_Free restrictions. The compiler issues a warning whenever a Priority aspect/pragma is given while the lock-free implementation has been forced by an aspect/pragma. ------------ -- Source -- ------------ package T is protected type P1 with Lock_Free is pragma Priority (1); end P1; end T; ----------------- -- Compilation -- ----------------- gnatmake -q -gnat12 t.ads ------------ -- Output -- ------------ t.ads:5:07: warning: pragma "Priority" for "P1" has no effect when Lock_Free given gnatmake: "t.ads" compilation error Tested on x86_64-pc-linux-gnu, committed on trunk 2012-07-09 Vincent Pucci <pucci@adacore.com> * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support atomic operation moved to the protected body case. No non-elementary out parameter moved to the protected declaration case. Functions have only one lock-free restriction. (Analyze_Protected_Type_Declaration): Issue a warning when Priority given with Lock_Free.