===================================================================
@@ -3188,7 +3188,7 @@
Rewrite (Stmt,
Make_Implicit_If_Statement (N,
- Condition =>
+ Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Try_Write, Loc),
@@ -3379,9 +3379,9 @@
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Defining_Identifier (Comp_Decl),
- Subtype_Mark =>
+ Subtype_Mark =>
New_Occurrence_Of (Comp_Type, Loc),
- Name =>
+ Name =>
New_Reference_To (Desired_Comp, Loc)));
-- Wrap any return or raise statements in Stmts in same the manner
===================================================================
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -68,24 +69,30 @@
function Allows_Lock_Free_Implementation
(N : Node_Id;
- Complain : Boolean := False) return Boolean;
+ 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,32 @@
-------------------------------------
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));
-- 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
@@ -150,14 +167,14 @@
-- restrictions.
if Nkind (Decl) = N_Entry_Declaration then
- if Complain then
+ if Lock_Free_Given then
Error_Msg_N
("entry not allowed when Lock_Free given", Decl);
+ else
+ return False;
end if;
- return False;
-
- -- Non-elementary out parameters in protected procedure are not
+ -- Non-elementary parameters in protected procedure are not
-- allowed by the lock-free restrictions.
elsif Nkind (Decl) = N_Subprogram_Declaration
@@ -176,18 +193,17 @@
begin
Par := First (Par_Specs);
while Present (Par) loop
- if Out_Present (Par)
- and then not Is_Elementary_Type
- (Etype (Parameter_Type (Par)))
+ if not Is_Elementary_Type
+ (Etype (Defining_Identifier (Par)))
then
- if Complain then
+ if Lock_Free_Given then
Error_Msg_NE
- ("non-elementary out parameter& not allowed "
+ ("non-elementary parameter& not allowed "
& "when Lock_Free given",
Par, Defining_Identifier (Par));
+ else
+ return False;
end if;
-
- return False;
end if;
Next (Par);
@@ -240,6 +256,10 @@
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
@@ -248,6 +268,7 @@
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
+ Kind : constant Node_Kind := Nkind (N);
-- The following function belongs in sem_eval ???
@@ -310,51 +331,123 @@
begin
if Is_Procedure then
- -- Attribute references must be static or denote a static
- -- function.
+ -- Allocators restricted
- if Nkind (N) = N_Attribute_Reference
+ 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;
+
+ -- Address attribute definition clause restricted
+
+ elsif Kind = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) =
+ Attribute_Address
+ then
+ Error_Msg_Name_1 := Chars (N);
+
+ 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 Skip;
+ end if;
+
+ 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 Complain then
+ if Lock_Free_Given then
Error_Msg_N
("non-static attribute reference not allowed", N);
+ return Skip;
end if;
return Abandon;
- -- Function calls must be static
+ -- Delay statements restricted
- elsif Nkind (N) = N_Function_Call
+ 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;
+
+ -- Explicit dereferences restricted (i.e. dereferences of
+ -- access values).
+
+ elsif Kind = N_Explicit_Dereference then
+ if Lock_Free_Given then
+ Error_Msg_N ("explicit dereference 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 Complain then
+ if Lock_Free_Given then
Error_Msg_N ("non-static function call not allowed",
N);
+ return Skip;
end if;
return Abandon;
- -- Loop statements and procedure calls are prohibited
+ -- Goto statements restricted
- elsif Nkind (N) = N_Loop_Statement then
- if Complain then
- Error_Msg_N ("loop not allowed", N);
+ 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;
- 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
+ elsif Kind = N_Identifier
and then Present (Entity (N))
then
declare
@@ -372,15 +465,75 @@
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
- if Complain 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;
+
+ 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
+
+ elsif Kind = 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;
@@ -388,7 +541,7 @@
-- reference only one component of the protected type, plus
-- the type of the component must support atomic operation.
- if Nkind (N) = N_Identifier
+ if Kind = N_Identifier
and then Present (Entity (N))
then
declare
@@ -441,11 +594,12 @@
when 8 | 16 | 32 | 64 =>
null;
when others =>
- if Complain then
+ if Lock_Free_Given then
Error_Msg_NE
("type of& must support atomic " &
"operations",
N, Comp_Id);
+ return Skip;
end if;
return Abandon;
@@ -458,10 +612,11 @@
Comp := Comp_Id;
elsif Comp /= Comp_Id then
- if Complain then
+ if Lock_Free_Given then
Error_Msg_N
("only one protected component allowed",
N);
+ return Skip;
end if;
return Abandon;
@@ -479,8 +634,17 @@
-- 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.
@@ -503,12 +667,12 @@
if Nkind (Decl) = N_Subprogram_Body
and then not Satisfies_Lock_Free_Requirements (Decl)
then
- if Complain then
+ if Lock_Free_Given then
Error_Msg_N
- ("body not allowed when Lock_Free given", Decl);
+ ("illegal body when Lock_Free given", Decl);
+ else
+ return False;
end if;
-
- return False;
end if;
Next (Decl);
@@ -516,6 +680,15 @@
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;
@@ -1611,7 +1784,7 @@
-- 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;
@@ -1886,7 +2059,7 @@
end if;
end;
- if not Allows_Lock_Free_Implementation (N, Complain => True) then
+ if not Allows_Lock_Free_Implementation (N, True) then
return;
end if;
end if;
This patch updates the restrictions of the lock-free implementation. Furthermore, it also catches every error messages issued by the routine Allows_Lock_Free_Implementation. The test below illustrates some of the new restrictions: ------------ -- Source -- ------------ package Typ is protected Prot with Lock_Free is procedure Test; private Count : Integer := 0; L : Integer := 0; end Prot; end Typ; package body Typ is protected body Prot is procedure Test is type Rec is record I, J : Integer; end record; type Rec_Access is access Rec; IA : Rec_Access := new Rec'(1,2); begin delay 3.0; if Count = 0 then goto Continue; end if; loop Count := Count + IA.J; exit when Count = 10; end loop; <<Continue>> L := Count + 1; end Test; end Prot; end Typ; ------------------------------- -- Compilation and Execution -- ------------------------------- $ gnatmake -q -gnat12 -gnatws typ.adb typ.adb:3:07: body not allowed when Lock_Free given typ.adb:9:29: allocator not allowed typ.adb:12:10: procedure call not allowed typ.adb:15:13: goto statement not allowed typ.adb:18:10: loop not allowed typ.adb:25:10: only one protected component allowed gnatmake: "typ.adb" compilation error Tested on x86_64-pc-linux-gnu, committed on trunk 2012-07-23 Vincent Pucci <pucci@adacore.com> * sem_ch9.adb (Allows_Lock_Free_Implementation): Flag Lock_Free_Given renames previous flag Complain. Description updated. Henceforth, catch every error messages issued by this routine when Lock_Free_Given is True. Declaration restriction updated: No non-elementary parameter instead (even in parameter) New subprogram body restrictions implemented: No allocator, no address, import or export rep items, no delay statement, no goto statement, no quantified expression and no dereference of access value.