This patch implements the semantics of aspect/pragma Max_Queue_Length
which restricts the entry queue length for protected entries by allowing
the aspect and pragma Max_Queue_Length to appear directly after protected
entries followed by a single argument -- a positive integer.
To achieve the runtime support all entry queue maximums are collected into
an array of natural integers (zero denoting no maximum specified) which then
gets passed to Initialize_Protection_Entry or Initialize_Protection_Entries
in System.Tasking.Protected_Objects.Single_Entry or
System.Tasking.Protected_Objects.Entries respectivly.
------------
-- Source --
------------
-- pass.ads
with System;
package Pass is
SOMETHING : constant Integer := 5;
Variable : Boolean := False;
protected type Protected_Example is
entry A (Item : Integer)
with Max_Queue_Length => 2; -- OK
entry B (Item : Integer);
pragma Max_Queue_Length (SOMETHING); -- OK
entry C (Item : Integer); -- OK
entry D (Item : Integer)
with Max_Queue_Length => 4; -- OK
entry D (Item : Integer; Item_B : Integer)
with Max_Queue_Length => Float'Digits; -- OK
entry E (Item : Integer);
pragma Max_Queue_Length (SOMETHING * 2); -- OK
entry E (Item : Integer; Item_B : Integer);
pragma Max_Queue_Length (11); -- OK
entry F (Item : Integer; Item_B : Integer);
pragma Pre (Variable = True);
pragma Max_Queue_Length (11); -- OK
entry G (Item : Integer; Item_B : Integer)
with Pre => (Variable = True),
Max_Queue_Length => 11; -- OK
private
Data : Boolean := True;
end Protected_Example;
Prot_Ex : Protected_Example;
end Pass;
-- fail.ads
package Fail is
-- Not near entry
pragma Max_Queue_Length (40); -- ERROR
-- Task type
task type Task_Example is
entry Insert (Item : in Integer)
with Max_Queue_Length => 10; -- ERROR
-- Entry family in task type
entry A (Positive) (Item : in Integer)
with Max_Queue_Length => 10; -- ERROR
end Task_Example;
Task_Ex : Task_Example;
-- Aspect applied to protected type
protected type Protected_Failure_0
with Max_Queue_Length => 50 is -- ERROR
entry A (Item : Integer);
private
Data : Integer := 0;
end Protected_Failure_0;
Protected_Failure_0_Ex : Protected_Failure_0;
protected type Protected_Failure is
pragma Max_Queue_Length (10); -- ERROR
-- Duplicates
entry A (Item : Integer)
with Max_Queue_Length => 10; -- OK
pragma Max_Queue_Length (4); -- ERROR
entry B (Item : Integer);
pragma Max_Queue_Length (40); -- OK
pragma Max_Queue_Length (4); -- ERROR
entry C (Item : Integer)
with Max_Queue_Length => 10, -- OK
Max_Queue_Length => 40; -- ERROR
-- Duplicates with the same value
entry AA (Item : Integer)
with Max_Queue_Length => 10; -- OK
pragma Max_Queue_Length (10); -- ERROR
entry BB (Item : Integer);
pragma Max_Queue_Length (40); -- OK
pragma Max_Queue_Length (40); -- ERROR
entry CC (Item : Integer)
with Max_Queue_Length => 10, -- OK
Max_Queue_Length => 10; -- ERROR
-- On subprogram
procedure D (Item : Integer)
with Max_Queue_Length => 10; -- ERROR
procedure E (Item : Integer);
pragma Max_Queue_Length (4); -- ERROR
function F (Item : Integer) return Integer
with Max_Queue_Length => 10; -- ERROR
function G (Item : Integer) return Integer;
pragma Max_Queue_Length (4); -- ERROR
-- Bad parameters
entry H (Item : Integer)
with Max_Queue_Length => 0; -- ERROR
entry I (Item : Integer)
with Max_Queue_Length => -1; -- ERROR
entry J (Item : Integer)
with Max_Queue_Length => 16#FFFF_FFFF_FFFF_FFFF_FFFF#; -- ERROR
entry K (Item : Integer)
with Max_Queue_Length => False; -- ERROR
entry L (Item : Integer)
with Max_Queue_Length => "JUNK"; -- ERROR
entry M (Item : Integer)
with Max_Queue_Length => 1.0; -- ERROR
entry N (Item : Integer)
with Max_Queue_Length => Long_Integer'(3); -- ERROR
-- Entry family
entry O (Boolean) (Item : Integer)
with Max_Queue_Length => 5; -- ERROR
private
Data : Integer := 0;
end Protected_Failure;
I : Positive := 1;
Protected_Failure_Ex : Protected_Failure;
end Fail;
----------------------------
-- Compilation and output --
----------------------------
$ gcc -c -gnatDG pass.ads
$ gcc -c fail.ads
$ grep '(2, 5, 0, 4, 6, 10, 11, 11, 11)' pass.ads.dg | wc -l
cannot generate code for file pass.ads (package spec)
fail.ads:5:04: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:12:15: aspect "Max_Queue_Length" cannot apply to task entries
fail.ads:17:15: aspect "Max_Queue_Length" cannot apply to task entries
fail.ads:26:12: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:36:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:42:07: pragma "Max_Queue_Length" duplicates aspect declared at line 41
fail.ads:46:07: pragma "Max_Queue_Length" duplicates pragma declared at line 45
fail.ads:50:15: aspect "Max_Queue_Length" for "C" previously given at line 49
fail.ads:56:07: pragma "Max_Queue_Length" duplicates aspect declared at line 55
fail.ads:60:07: pragma "Max_Queue_Length" duplicates pragma declared at line 59
fail.ads:64:15: aspect "Max_Queue_Length" for "CC" previously given at line 63
fail.ads:69:15: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:72:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:75:15: aspect "Max_Queue_Length" must apply to a protected entry
fail.ads:78:07: pragma "Max_Queue_Length" must apply to a protected entry
fail.ads:83:35: entity for aspect "Max_Queue_Length" must be positive
fail.ads:86:35: entity for aspect "Max_Queue_Length" must be positive
fail.ads:89:35: entity for aspect "Max_Queue_Length" out of range of Integer
fail.ads:92:35: expected an integer type
fail.ads:92:35: found type "Standard.Boolean"
fail.ads:95:35: expected an integer type
fail.ads:95:35: found a string type
fail.ads:98:35: expected an integer type
fail.ads:98:35: found type universal real
fail.ads:106:15: aspect "Max_Queue_Length" cannot apply to entry families
1
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-06 Justin Squirek <squi...@adacore.com>
* aspects.adb: Register aspect in Canonical_Aspect.
* aspects.ads: Associate qualities of Aspect_Max_Queue_Length
into respective tables.
* einfo.ads, einfo.adb: Add a new attribute for
handling the parameters for Pragma_Max_Entry_Queue
(Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms
for accessing and setting were added as well.
* par-prag.adb (Prag): Register Pramga_Max_Entry_Queue.
* exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit
declaration for pramga arguments and store them in the protected
type node.
(Make_Initialize_Protection): Pass a reference to
the Entry_Max_Queue_Lengths_Array in the protected type node to
the runtime.
* rtsfind.adb: Minor grammar fix.
* rtsfind.ads: Register new types taken from the
runtime libraries RE_Protected_Entry_Queue_Max and
RE_Protected_Entry_Queue_Max_Array
* s-tposen.adb, s-tpoben.adb
(Initialize_Protection_Entry/Initialize_Protection_Entries):
Add extra parameter and add assignment to local object.
* s-tposen.ads, s-tpoben.ads: Add new types to
store entry queue maximums and a field to the entry object record.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement
for Aspect_Max_Queue_Length.
(Check_Aspect_At_Freeze_Point):
Add aspect to list of aspects that don't require delayed analysis.
* sem_prag.adb (Analyze_Pragma): Add case statement for
Pragma_Max_Queue_Length, check semantics, and register arugments
in the respective entry nodes.
* sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length
and Has_Max_Queue_Length
* snames.ads-tmpl: Add constant for the new aspect-name
Name_Max_Queue_Length and corrasponding pragma.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 244124)
+++ exp_ch9.adb (working copy)
@@ -9045,7 +9045,7 @@
-- the specs refer to this type.
procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
- Discr_Map : constant Elist_Id := New_Elmt_List;
+ Discr_Map : constant Elist_Id := New_Elmt_List;
Loc : constant Source_Ptr := Sloc (N);
Prot_Typ : constant Entity_Id := Defining_Identifier (N);
@@ -9055,17 +9055,9 @@
Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
- Body_Arr : Node_Id;
- Body_Id : Entity_Id;
- Cdecls : List_Id;
- Comp : Node_Id;
Current_Node : Node_Id := N;
E_Count : Int;
Entries_Aggr : Node_Id;
- New_Priv : Node_Id;
- Object_Comp : Node_Id;
- Priv : Node_Id;
- Rec_Decl : Node_Id;
procedure Check_Inlining (Subp : Entity_Id);
-- If the original operation has a pragma Inline, propagate the flag
@@ -9295,7 +9287,17 @@
-- Local variables
- Sub : Node_Id;
+ Body_Arr : Node_Id;
+ Body_Id : Entity_Id;
+ Cdecls : List_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ New_Priv : Node_Id;
+ Obj_Def : Node_Id;
+ Object_Comp : Node_Id;
+ Priv : Node_Id;
+ Rec_Decl : Node_Id;
+ Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration
@@ -9760,6 +9762,96 @@
end loop;
end if;
+ -- Create the declaration of an array object which contains the values
+ -- of aspect/pragma Max_Queue_Length for all entries of the protected
+ -- type. This object is later passed to the appropriate protected object
+ -- initialization routine.
+
+ declare
+ 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
+
+ -- 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.
+
+ 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,
+ Intval => Get_Max_Queue_Length (Item)));
+ end if;
+
+ Next_Entity (Item);
+ end loop;
+
+ -- Create the declaration of the array object. Generate:
+
+ -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
+ -- (1 .. Count) := (..., ...);
+ -- or
+ -- Maxs_Id : aliased Protected_Entry_Queue_Max := <value>;
+
+ Maxs_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Prot_Typ), 'B'));
+
+ case Corresponding_Runtime_Package (Prot_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Expr := Make_Aggregate (Loc, Maxs);
+
+ Obj_Def :=
+ 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)))));
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Expr := Make_Integer_Literal (Loc, Intval (First (Maxs)));
+
+ Obj_Def :=
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Queue_Max), Loc);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Max_Vals :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Maxs_Id,
+ Aliased_Present => True,
+ Object_Definition => Obj_Def,
+ Expression => Expr);
+
+ -- 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;
+
-- Emit declaration for Entry_Bodies_Array, now that the addresses of
-- all protected subprograms have been collected.
@@ -9770,37 +9862,34 @@
case Corresponding_Runtime_Package (Prot_Typ) is
when System_Tasking_Protected_Objects_Entries =>
- Body_Arr :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Body_Id,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Body_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Make_Integer_Literal (Loc, 1),
- Make_Integer_Literal (Loc, E_Count))))),
- Expression => Entries_Aggr);
+ Expr := Entries_Aggr;
+ Obj_Def :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Body_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, E_Count)))));
when System_Tasking_Protected_Objects_Single_Entry =>
- Body_Arr :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Body_Id,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Entry_Body), Loc),
- Expression =>
- Remove_Head (Expressions (Entries_Aggr)));
+ Expr := Remove_Head (Expressions (Entries_Aggr));
+ Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
when others =>
raise Program_Error;
end case;
+ Body_Arr :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Body_Id,
+ Aliased_Present => True,
+ Object_Definition => Obj_Def,
+ Expression => Expr);
+
-- A pointer to this array will be placed in the corresponding record
-- by its initialization procedure so this needs to be analyzed here.
@@ -9821,6 +9910,7 @@
Sub :=
Make_Subprogram_Declaration (Loc,
Specification => Build_Find_Body_Index_Spec (Prot_Typ));
+
Insert_After (Current_Node, Sub);
Analyze (Sub);
end if;
@@ -14107,6 +14197,27 @@
raise Program_Error;
end case;
+ -- Entry_Queue_Maxs parameter. This is a pointer to an array of
+ -- naturals representing the entry queue maximums for each entry
+ -- in the protected type. Zero represents no max.
+
+ if Has_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));
+
+ -- Edge cases exist where entry initialization functions are
+ -- called, but no entries exist, so null is appended.
+
+ elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry
+ or else Pkg_Id = System_Tasking_Protected_Objects_Entries
+ then
+ Append_To (Args, Make_Null (Loc));
+ end if;
+
-- Entry_Bodies parameter. This is a pointer to an array of
-- pointers to the entry body procedures and barrier functions of
-- the object. If the protected type has no entries this object
Index: einfo.adb
===================================================================
--- einfo.adb (revision 244124)
+++ einfo.adb (working copy)
@@ -267,6 +267,7 @@
-- Contract Node34
-- Anonymous_Designated_Type Node35
+ -- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
-- Class_Wide_Preconds List38
@@ -1221,6 +1222,12 @@
return Node18 (Id);
end Entry_Index_Constant;
+ function Entry_Max_Queue_Lengths_Array (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Protected_Type);
+ return Node35 (Id);
+ end Entry_Max_Queue_Lengths_Array;
+
function Contains_Ignored_Ghost_Code (Id : E) return B is
begin
pragma Assert
@@ -4286,6 +4293,12 @@
Set_Node18 (Id, V);
end Set_Entry_Index_Constant;
+ procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Protected_Type);
+ Set_Node35 (Id, V);
+ end Set_Entry_Max_Queue_Lengths_Array;
+
procedure Set_Entry_Parameters_Type (Id : E; V : E) is
begin
Set_Node15 (Id, V);
@@ -10738,6 +10751,10 @@
when E_Variable =>
Write_Str ("Anonymous_Designated_Type");
+ when E_Entry |
+ E_Entry_Family =>
+ Write_Str ("Entry_Max_Queue_Lenghts_Array");
+
when Subprogram_Kind =>
Write_Str ("Import_Pragma");
Index: einfo.ads
===================================================================
--- einfo.ads (revision 244124)
+++ einfo.ads (working copy)
@@ -1154,6 +1154,11 @@
-- accept statement for a member of the family, and in the prefix of
-- 'COUNT when it applies to a family member.
+-- Entry_Max_Queue_Lengths_Array (Node35)
+-- Defined in protected types for which Has_Entries is true. Contains the
+-- defining identifier for the array of naturals used by the runtime to
+-- limit the queue size of each entry individually.
+
-- Entry_Parameters_Type (Node15)
-- Defined in entries. Points to the access-to-record type that is
-- constructed by the expander to hold a reference to the parameter
@@ -6381,6 +6386,7 @@
-- Stored_Constraint (Elist23)
-- Anonymous_Object (Node30)
-- Contract (Node34)
+ -- Entry_Max_Queue_Lengths_Array (Node35)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Sec_Stack_Needed_For_Return (Flag167) ???
@@ -6928,6 +6934,7 @@
function Entry_Formal (Id : E) return E;
function Entry_Index_Constant (Id : E) return E;
function Entry_Index_Type (Id : E) return E;
+ function Entry_Max_Queue_Lengths_Array (Id : E) return E;
function Entry_Parameters_Type (Id : E) return E;
function Enum_Pos_To_Rep (Id : E) return E;
function Enumeration_Pos (Id : E) return U;
@@ -7608,6 +7615,7 @@
procedure Set_Entry_Component (Id : E; V : E);
procedure Set_Entry_Formal (Id : E; V : E);
procedure Set_Entry_Index_Constant (Id : E; V : E);
+ procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E);
procedure Set_Entry_Parameters_Type (Id : E; V : E);
procedure Set_Enum_Pos_To_Rep (Id : E; V : E);
procedure Set_Enumeration_Pos (Id : E; V : U);
@@ -8921,6 +8929,7 @@
pragma Inline (Set_Entry_Cancel_Parameter);
pragma Inline (Set_Entry_Component);
pragma Inline (Set_Entry_Formal);
+ pragma Inline (Set_Entry_Max_Queue_Lengths_Array);
pragma Inline (Set_Entry_Parameters_Type);
pragma Inline (Set_Enum_Pos_To_Rep);
pragma Inline (Set_Enumeration_Pos);
Index: s-tpoben.adb
===================================================================
--- s-tpoben.adb (revision 244124)
+++ s-tpoben.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -174,6 +174,7 @@
(Object : Protection_Entries_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
+ Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
Entry_Bodies : Protected_Entry_Body_Access;
Find_Body_Index : Find_Body_Index_Access)
is
@@ -211,6 +212,7 @@
Object.Compiler_Info := Compiler_Info;
Object.Pending_Action := False;
Object.Call_In_Progress := null;
+ Object.Entry_Queue_Maxs := Entry_Queue_Maxs;
Object.Entry_Bodies := Entry_Bodies;
Object.Find_Body_Index := Find_Body_Index;
Index: s-tpoben.ads
===================================================================
--- s-tpoben.ads (revision 244124)
+++ s-tpoben.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,6 +66,12 @@
type Protected_Entry_Queue_Array is
array (Protected_Entry_Index range <>) of Entry_Queue;
+ type Protected_Entry_Queue_Max_Array is
+ array (Positive_Protected_Entry_Index range <>) of Natural;
+
+ type Protected_Entry_Queue_Max_Access is
+ access all 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
-- access type.
@@ -144,6 +150,10 @@
Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+ Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
+ -- Access to an array of naturals representing the max value for
+ -- each entry's queue length. A value of 0 signifies no max.
+
Entry_Names : Protected_Entry_Names_Access := null;
-- An array of string names which denotes entry [family member] names.
-- The structure is indexed by protected entry index and contains Num_
@@ -178,6 +188,7 @@
(Object : Protection_Entries_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
+ Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
Entry_Bodies : Protected_Entry_Body_Access;
Find_Body_Index : Find_Body_Index_Access);
-- Initialize the Object parameter so that it can be used by the runtime
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 244125)
+++ sem_prag.adb (working copy)
@@ -17659,6 +17659,86 @@
end loop;
end Main_Storage;
+ ----------------------
+ -- Max_Queue_Length --
+ ----------------------
+
+ -- pragma Max_Queue_Length (static_integer_EXPRESSION);
+
+ when Pragma_Max_Queue_Length => Max_Queue_Length : declare
+ Arg : Node_Id;
+ Entry_Decl : Node_Id;
+ Entry_Id : Entity_Id;
+ Val : Uint;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+
+ Entry_Decl :=
+ Find_Related_Declaration_Or_Body (N, Do_Checks => True);
+
+ -- Entry declaration
+
+ if Nkind (Entry_Decl) = N_Entry_Declaration then
+
+ -- Entry illegally within a task
+
+ if Nkind (Parent (N)) = N_Task_Definition then
+ Error_Pragma ("pragma % cannot apply to task entries");
+ return;
+ end if;
+
+ Entry_Id := Unique_Defining_Entity (Entry_Decl);
+
+ -- Pragma illegally applied to an entry family
+
+ if Ekind (Entry_Id) = E_Entry_Family then
+ Error_Pragma ("pragma % cannot apply to entry families");
+ return;
+ end if;
+
+ -- Otherwise the pragma is associated with an illegal construct
+
+ else
+ Error_Pragma ("pragma % must apply to a protected entry");
+ return;
+ end if;
+
+ -- Mark the pragma as Ghost if the related subprogram is also
+ -- Ghost. This also ensures that any expansion performed further
+ -- below will produce Ghost nodes.
+
+ Mark_Pragma_As_Ghost (N, Entry_Id);
+
+ -- Analyze the Integer expression
+
+ Arg := Get_Pragma_Arg (Arg1);
+ Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
+
+ Val := Expr_Value (Arg);
+
+ if Val <= 0 then
+ Error_Pragma_Arg
+ ("argument for pragma% must be positive", Arg1);
+
+ elsif not UI_Is_In_Int_Range (Val) then
+ Error_Pragma_Arg
+ ("argument for pragma% out of range of Integer", Arg1);
+
+ end if;
+
+ -- Manually subsitute the expression value of the pragma argument
+ -- if it not an integer literally because this is not taken care
+ -- of automatically elsewhere.
+
+ if Nkind (Arg) /= N_Integer_Literal then
+ Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
+ end if;
+
+ Record_Rep_Item (Entry_Id, N);
+ end Max_Queue_Length;
+
-----------------
-- Memory_Size --
-----------------
@@ -28642,6 +28722,7 @@
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
+ Pragma_Max_Queue_Length => 0,
Pragma_Memory_Size => 0,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
Index: rtsfind.adb
===================================================================
--- rtsfind.adb (revision 244124)
+++ rtsfind.adb (working copy)
@@ -1351,7 +1351,7 @@
-- is System. If so, return the value from the already compiled
-- declaration and otherwise do a regular find.
- -- Not pleasant, but these kinds of annoying recursion when
+ -- Not pleasant, but these kinds of annoying recursion senarios when
-- writing an Ada compiler in Ada have to be broken somewhere.
if Present (Main_Unit_Entity)
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 244124)
+++ rtsfind.ads (working copy)
@@ -1684,6 +1684,7 @@
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries
+ RE_Protected_Entry_Queue_Max_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries
@@ -1716,6 +1717,7 @@
RE_Service_Entry, -- Protected_Objects.Single_Entry
RE_Exceptional_Complete_Single_Entry_Body,
RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry
+ RE_Protected_Entry_Queue_Max, -- Protected_Objects.Single_Entry
RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry
RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects
@@ -2927,6 +2929,8 @@
System_Tasking_Protected_Objects_Entries,
RE_Protected_Entry_Names_Array =>
System_Tasking_Protected_Objects_Entries,
+ RE_Protected_Entry_Queue_Max_Array =>
+ System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries_Access =>
@@ -2989,6 +2993,8 @@
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Count_Entry =>
System_Tasking_Protected_Objects_Single_Entry,
+ RE_Protected_Entry_Queue_Max =>
+ System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Single_Entry_Caller =>
System_Tasking_Protected_Objects_Single_Entry,
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 244124)
+++ sem_util.adb (working copy)
@@ -8351,6 +8351,24 @@
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
end Get_Library_Unit_Name_String;
+ --------------------------
+ -- Get_Max_Queue_Length --
+ --------------------------
+
+ function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
+ 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 defaults to it.
+
+ if not Has_Max_Queue_Length (Id) or else not Present (Prag) then
+ return Uint_0;
+ end if;
+
+ return Intval (Expression (First (Pragma_Argument_Associations (Prag))));
+ end Get_Max_Queue_Length;
+
------------------------
-- Get_Name_Entity_Id --
------------------------
@@ -9648,15 +9666,25 @@
return False;
end Has_Interfaces;
+ --------------------------
+ -- Has_Max_Queue_Length --
+ --------------------------
+
+ function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind (Id) = E_Entry
+ and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
+ end Has_Max_Queue_Length;
+
---------------------------------
-- Has_No_Obvious_Side_Effects --
---------------------------------
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
begin
- -- For now, just handle literals, constants, and non-volatile
- -- variables and expressions combining these with operators or
- -- short circuit forms.
+ -- For now handle literals, constants, and non-volatile variables and
+ -- expressions combining these with operators or short circuit forms.
if Nkind (N) in N_Numeric_Or_String_Literal then
return True;
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 244124)
+++ sem_util.ads (working copy)
@@ -931,6 +931,10 @@
-- Retrieve the fully expanded name of the library unit declared by
-- Decl_Node into the name buffer.
+ function Get_Max_Queue_Length (Id : Entity_Id) return Uint;
+ -- Return the argument of pragma Max_Queue_Length or zero if the annotation
+ -- is not present. It is assumed that Id denotes an entry.
+
function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
pragma Inline (Get_Name_Entity_Id);
-- An entity value is associated with each name in the name table. The
@@ -1104,6 +1108,10 @@
-- Use_Full_View controls if the check is done using its full view (if
-- available).
+ function Has_Max_Queue_Length (Id : Entity_Id) return Boolean;
+ -- Determine whether Id is subject to pragma Max_Queue_Length. It is
+ -- assumed that Id denotes an entry.
+
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
-- This is a simple minded function for determining whether an expression
-- has no obvious side effects. It is used only for determining whether
Index: aspects.adb
===================================================================
--- aspects.adb (revision 244124)
+++ aspects.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -568,6 +568,7 @@
Aspect_Linker_Section => Aspect_Linker_Section,
Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix,
+ Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
Aspect_No_Return => Aspect_No_Return,
Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
Index: aspects.ads
===================================================================
--- aspects.ads (revision 244124)
+++ aspects.ads (working copy)
@@ -116,6 +116,7 @@
Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix,
+ Aspect_Max_Queue_Length, -- GNAT
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
@@ -247,6 +248,7 @@
Aspect_Inline_Always => True,
Aspect_Invariant => True,
Aspect_Lock_Free => True,
+ Aspect_Max_Queue_Length => True,
Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
@@ -353,6 +355,7 @@
Aspect_Link_Name => Expression,
Aspect_Linker_Section => Expression,
Aspect_Machine_Radix => Expression,
+ Aspect_Max_Queue_Length => Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@@ -460,6 +463,7 @@
Aspect_Linker_Section => Name_Linker_Section,
Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix,
+ Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Return => Name_No_Return,
Aspect_No_Tagged_Streams => Name_No_Tagged_Streams,
@@ -731,6 +735,7 @@
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay,
+ Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_No_Tagged_Streams => Never_Delay,
Aspect_Obsolescent => Never_Delay,
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 244124)
+++ par-prag.adb (working copy)
@@ -1396,6 +1396,7 @@
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
+ Pragma_Max_Queue_Length |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Elaboration_Code_All |
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 244124)
+++ sem_ch13.adb (working copy)
@@ -2823,6 +2823,19 @@
goto Continue;
end Initializes;
+ -- Max_Queue_Length
+
+ when Aspect_Max_Queue_Length =>
+ Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expr))),
+ Pragma_Name => Name_Max_Queue_Length);
+
+ Decorate (Aspect, Aitem);
+ Insert_Pragma (Aitem);
+ goto Continue;
+
-- Obsolescent
when Aspect_Obsolescent => declare
@@ -9251,6 +9264,7 @@
Aspect_Implicit_Dereference |
Aspect_Initial_Condition |
Aspect_Initializes |
+ Aspect_Max_Queue_Length |
Aspect_Obsolescent |
Aspect_Part_Of |
Aspect_Post |
Index: s-tposen.adb
===================================================================
--- s-tposen.adb (revision 244124)
+++ s-tposen.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -218,6 +218,7 @@
(Object : Protection_Entry_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
+ Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
Entry_Body : Entry_Body_Access)
is
begin
@@ -226,6 +227,7 @@
Object.Compiler_Info := Compiler_Info;
Object.Call_In_Progress := null;
Object.Entry_Body := Entry_Body;
+ Object.Entry_Queue_Max := Entry_Queue_Max;
Object.Entry_Queue := null;
end Initialize_Protection_Entry;
Index: s-tposen.ads
===================================================================
--- s-tposen.ads (revision 244124)
+++ s-tposen.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -182,10 +182,16 @@
type Protection_Entry_Access is access all Protection_Entry;
+ type Protected_Entry_Queue_Max is new Natural;
+
+ type Protected_Entry_Queue_Max_Access is
+ access all Protected_Entry_Queue_Max;
+
procedure Initialize_Protection_Entry
(Object : Protection_Entry_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
+ Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
Entry_Body : Entry_Body_Access);
-- Initialize the Object parameter so that it can be used by the run time
-- to keep track of the runtime state of a protected object.
@@ -270,6 +276,10 @@
Entry_Queue : Entry_Call_Link;
-- Place to store the waiting entry call (if any)
+
+ Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
+ -- Access to a natural representing the max value for the single
+ -- entry's queue length. A value of 0 signifies no max.
end record;
end System.Tasking.Protected_Objects.Single_Entry;
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 244124)
+++ snames.ads-tmpl (working copy)
@@ -575,6 +575,7 @@
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : constant Name_Id := N + $; -- GNAT
+ Name_Max_Queue_Length : constant Name_Id := N + $; -- GNAT
Name_Memory_Size : constant Name_Id := N + $; -- Ada 83
Name_No_Body : constant Name_Id := N + $; -- GNAT
Name_No_Elaboration_Code_All : constant Name_Id := N + $; -- GNAT
@@ -1904,6 +1905,7 @@
Pragma_Machine_Attribute,
Pragma_Main,
Pragma_Main_Storage,
+ Pragma_Max_Queue_Length,
Pragma_Memory_Size,
Pragma_No_Body,
Pragma_No_Elaboration_Code_All,
