+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_case.adb: Minor reformatting.
+
+2017-01-06 Thomas Quinot <quinot@adacore.com>
+
+ * g-socthi-mingw.adb: Remove now extraneous USE TYPE clause
+
+2017-01-06 Justin Squirek <squirek@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.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Is_Controlled_Function_Call):
+ Reimplemented. Consider any node which has an entity as the
+ function call may appear in various ways.
+
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb (Rewrite_Stream_Proc_Call): Use
function Ada.Unchecked_Conversion (S : Source) return Target;
+pragma No_Elaboration_Code_All (Unchecked_Conversion);
pragma Pure (Unchecked_Conversion);
pragma Import (Intrinsic, Unchecked_Conversion);
------------------------------------------------------------------------------
package Ada is
+ pragma No_Elaboration_Code_All;
pragma Pure;
end Ada;
-- --
-- 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- --
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,
Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix,
+ Aspect_Max_Queue_Length, -- GNAT
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
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,
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,
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,
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,
-- Contract Node34
-- Anonymous_Designated_Type Node35
+ -- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
-- Class_Wide_Preconds List38
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
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);
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");
-- 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
-- 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) ???
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;
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);
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);
-- 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);
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
-- 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
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.
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.
Sub :=
Make_Subprogram_Declaration (Loc,
Specification => Build_Find_Body_Index_Spec (Prot_Typ));
+
Insert_After (Current_Node, Sub);
Analyze (Sub);
end if;
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
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-- N_Selected_Component
- case Nkind (Expr) is
- when N_Function_Call =>
+ loop
+ if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
- -- Check for "Obj.Func (Formal => Actual)" case
-
- if Nkind (Expr) = N_Selected_Component then
- Expr := Selector_Name (Expr);
- end if;
-
-- "Obj.Func (Actual)" case
- when N_Indexed_Component =>
+ elsif Nkind (Expr) = N_Indexed_Component then
Expr := Prefix (Expr);
- if Nkind (Expr) = N_Selected_Component then
- Expr := Selector_Name (Expr);
- end if;
-
- -- "Obj.Func" case
+ -- "Obj.Func" or "Obj.Func (Formal => Actual) case
- when N_Selected_Component =>
+ elsif Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
- when others => null;
- end case;
+ else
+ exit;
+ end if;
+ end loop;
return
- Nkind_In (Expr, N_Expanded_Name, N_Identifier)
+ Nkind (Expr) in N_Has_Entity
+ and then Present (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- 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- --
package body GNAT.Sockets.Thin is
use type C.unsigned;
- use type C.int;
WSAData_Dummy : array (1 .. 512) of C.int;
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
+ Pragma_Max_Queue_Length |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Elaboration_Code_All |
-- 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)
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
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
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 =>
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,
-- --
-- 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- --
(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
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;
-- --
-- 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- --
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.
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_
(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
-- --
-- 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- --
(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
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;
-- --
-- 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- --
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.
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;
Lo : Node_Id;
Hi : Node_Id);
-- If the type of the alternative has predicates, we must examine
- -- each subset of the predicate rather than the bounds of the
- -- type itself. This is relevant when the choice is a subtype mark
- -- or a subtype indication.
+ -- each subset of the predicate rather than the bounds of the type
+ -- itself. This is relevant when the choice is a subtype mark or a
+ -- subtype indication.
-----------
-- Check --
P := First (Static_Discrete_Predicate (Typ));
while Present (P) loop
- -- Check that part of the predicate choice is included in
- -- the given bounds.
+ -- Check that part of the predicate choice is included in the
+ -- given bounds.
if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
& "predicate as case alternative",
Choice, E, Suggest_Static => True);
- -- Static predicate case. The bounds are
- -- those of the given subtype.
+ -- Static predicate case. The bounds are those of
+ -- the given subtype.
else
Handle_Static_Predicate (E,
end if;
end if;
- if Has_Static_Predicate (E) then
-
-- Check applicable predicate values within the
-- bounds of the given range.
+ if Has_Static_Predicate (E) then
Handle_Static_Predicate (E, L, H);
else
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
Aspect_Implicit_Dereference |
Aspect_Initial_Condition |
Aspect_Initializes |
+ Aspect_Max_Queue_Length |
Aspect_Obsolescent |
Aspect_Part_Of |
Aspect_Post |
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 --
-----------------
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,
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 --
------------------------
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;
-- 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
-- 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
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
Pragma_Machine_Attribute,
Pragma_Main,
Pragma_Main_Storage,
+ Pragma_Max_Queue_Length,
Pragma_Memory_Size,
Pragma_No_Body,
Pragma_No_Elaboration_Code_All,
projects / gcc.git / commitdiff