summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2012-10-29 11:09:46 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2012-10-29 11:09:46 +0000
commit12e90c4403a80eb330785a31627c0aaf52141b0b (patch)
treec6f72c04618eb46b19778035ec894212166d8ea2
parent289e4204a7085dddb979dd2f27b34e463b29df13 (diff)
downloadgcc-12e90c4403a80eb330785a31627c0aaf52141b0b.tar.gz
2012-10-29 Tristan Gingold <gingold@adacore.com>
* gnat_rm.texi: Document implementation advice for Pragma Partition_Elaboration_Policy. 2012-10-29 Yannick Moy <moy@adacore.com> * s-bignum.adb (Div_Rem): Reference that Algorithm_D is from the second edition of TAOCP from Knuth, since the algo changed in the third edition. Also correct the definition of 'd' which could overflow. 2012-10-29 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch3.adb (Build_Initialization_Call): Create static strings which denote entry [family] names and associate them with the object's Protection_Entries or ATCB. (Build_Init_Statements): Remove local variable Names. Do not generate the entry [family] names inside the init proc because they are now static. * exp_ch9.adb (Build_Entry_Names): Reimplemented. The strings which denote entry [family] names are now generated statically and associated with the concurrent object's Protection_Entries or ATCB during initialization. * exp_ch9.ads (Build_Entry_Names): Change subprogram profile and associated comment on usage. * rtsfind.ads: Add the following entries to tables RE_Id and RE_Unit_Table: RE_Protected_Entry_Names_Array RE_Task_Entry_Names_Array RO_PE_Number_Of_Entries RO_PE_Set_Entry_Names RO_ST_Number_Of_Entries RO_ST_Set_Entry_Names Remove the following entries from tables RE_Id and RE_Unit_Table: RO_PE_Set_Entry_Name RO_TS_Set_Entry_Name * s-taskin.adb: Remove with clause for Ada.Unchecked_Deallocation. (Free_Entry_Names_Array): Removed. (Number_Of_Entries): New routine. (Set_Entry_Names): New routine. * s-taskin.ads: Rename type Entry_Names_Array to Task_Entry_Names_Array. Rename type Entry_Names_Array_Access to Task_Entry_Names_Access. Update the type of ACTB field Entry_Names and add a comment on its protection status. (Free_Entry_Names_Array): Removed. (Number_Of_Entries): New routine. (Set_Entry_Names): New routine. * s-tassta.adb (Create_Task): Remove formal parameter Build_Entry_Names. Do not allocate an array to hold the string names of entries and families. (Free_Entry_Names): Removed. (Free_Task): Remove the call to Free_Entry_Names. (Set_Entry_Name): Removed. (Vulnerable_Free_Task): Remove the call to Free_Entry_Names. * s-tassta.ads (Create_Task): Remove formal parameter Build_Entry_Names along with associated comment. (Set_Entry_Name): Removed. * s-tpoben.adb: Remove with clause for Ada.Unchecked_Deallocation. (Finalize): Remove the call to Free_Entry_Names. (Free_Entry_Names): Removed. (Initialize_Protection_Entries): Remove formal parameter Build_Entry_Names. Do not allocate an array to hold the string names of entries and families. (Number_Of_Entries): New routine. (Set_Entry_Name): Removed. (Set_Entry_Names): New routine. * s-tpoben.ads: Add types Protected_Entry_Names_Array and Protected_Entry_Names_Access. Update the type of Protection_Enties field Entry_Names. (Initialize_Protection_Entries): Remove formal parameter Build_Entry_Names along with associated comment. (Number_Of_Entries): New routine. (Set_Entry_Name): Removed. (Set_Entry_Names): New routine. 2012-10-29 Arnaud Charlet <charlet@adacore.com> * gnat_ugn.texi: Minor typo fix. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@192933 138bc75d-0d04-0410-961f-82ee72b054a4
-rw-r--r--gcc/ada/ChangeLog79
-rw-r--r--gcc/ada/exp_ch3.adb36
-rw-r--r--gcc/ada/exp_ch9.adb515
-rw-r--r--gcc/ada/exp_ch9.ads15
-rw-r--r--gcc/ada/gnat_rm.texi12
-rw-r--r--gcc/ada/gnat_ugn.texi2
-rw-r--r--gcc/ada/rtsfind.ads24
-rw-r--r--gcc/ada/s-bignum.adb17
-rw-r--r--gcc/ada/s-taskin.adb36
-rw-r--r--gcc/ada/s-taskin.ads25
-rw-r--r--gcc/ada/s-tassta.adb53
-rw-r--r--gcc/ada/s-tassta.ads14
-rw-r--r--gcc/ada/s-tpoben.adb79
-rw-r--r--gcc/ada/s-tpoben.ads38
14 files changed, 515 insertions, 430 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c200a06367c..f83800cb018 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,82 @@
+2012-10-29 Tristan Gingold <gingold@adacore.com>
+
+ * gnat_rm.texi: Document implementation advice for Pragma
+ Partition_Elaboration_Policy.
+
+2012-10-29 Yannick Moy <moy@adacore.com>
+
+ * s-bignum.adb (Div_Rem): Reference that Algorithm_D is from
+ the second edition of TAOCP from Knuth, since the algo changed
+ in the third edition. Also correct the definition of 'd' which
+ could overflow.
+
+2012-10-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Build_Initialization_Call): Create static strings
+ which denote entry [family] names and associate them with the
+ object's Protection_Entries or ATCB.
+ (Build_Init_Statements):
+ Remove local variable Names. Do not generate the entry [family]
+ names inside the init proc because they are now static.
+ * exp_ch9.adb (Build_Entry_Names): Reimplemented. The strings
+ which denote entry [family] names are now generated statically
+ and associated with the concurrent object's Protection_Entries
+ or ATCB during initialization.
+ * exp_ch9.ads (Build_Entry_Names): Change subprogram profile
+ and associated comment on usage.
+ * rtsfind.ads: Add the following entries to tables RE_Id and
+ RE_Unit_Table:
+
+ RE_Protected_Entry_Names_Array RE_Task_Entry_Names_Array
+ RO_PE_Number_Of_Entries RO_PE_Set_Entry_Names
+ RO_ST_Number_Of_Entries RO_ST_Set_Entry_Names
+
+ Remove the following entries from tables RE_Id and RE_Unit_Table:
+
+ RO_PE_Set_Entry_Name RO_TS_Set_Entry_Name
+
+ * s-taskin.adb: Remove with clause for Ada.Unchecked_Deallocation.
+ (Free_Entry_Names_Array): Removed.
+ (Number_Of_Entries): New routine.
+ (Set_Entry_Names): New routine.
+ * s-taskin.ads: Rename type Entry_Names_Array to
+ Task_Entry_Names_Array. Rename type Entry_Names_Array_Access
+ to Task_Entry_Names_Access. Update the type of ACTB field
+ Entry_Names and add a comment on its protection status.
+ (Free_Entry_Names_Array): Removed.
+ (Number_Of_Entries): New routine.
+ (Set_Entry_Names): New routine.
+ * s-tassta.adb (Create_Task): Remove formal parameter
+ Build_Entry_Names. Do not allocate an array to hold the
+ string names of entries and families.
+ (Free_Entry_Names): Removed.
+ (Free_Task): Remove the call to Free_Entry_Names.
+ (Set_Entry_Name): Removed.
+ (Vulnerable_Free_Task): Remove the call to Free_Entry_Names.
+ * s-tassta.ads (Create_Task): Remove formal parameter
+ Build_Entry_Names along with associated comment.
+ (Set_Entry_Name): Removed.
+ * s-tpoben.adb: Remove with clause for Ada.Unchecked_Deallocation.
+ (Finalize): Remove the call to Free_Entry_Names.
+ (Free_Entry_Names): Removed.
+ (Initialize_Protection_Entries):
+ Remove formal parameter Build_Entry_Names. Do not allocate
+ an array to hold the string names of entries and families.
+ (Number_Of_Entries): New routine.
+ (Set_Entry_Name): Removed.
+ (Set_Entry_Names): New routine.
+ * s-tpoben.ads: Add types Protected_Entry_Names_Array and
+ Protected_Entry_Names_Access. Update the type of Protection_Enties
+ field Entry_Names.
+ (Initialize_Protection_Entries): Remove
+ formal parameter Build_Entry_Names along with associated comment.
+ (Number_Of_Entries): New routine.
+ (Set_Entry_Name): Removed.
+ (Set_Entry_Names): New routine.
+
+2012-10-29 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat_ugn.texi: Minor typo fix.
2012-10-29 Yannick Moy <moy@adacore.com>
* debug.adb Associate debug switch -gnatd.V to extensions for
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 0e703da2237..fdf3185cede 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1704,6 +1704,18 @@ package body Exp_Ch3 is
end if;
end if;
+ -- When the object is either protected or a task, create static strings
+ -- which denote the names of entries and families. Associate the strings
+ -- with the concurrent object's Protection_Entries or ATCB. This is a
+ -- VMS Debug feature.
+
+ if OpenVMS_On_Target
+ and then Is_Concurrent_Type (Typ)
+ and then Entry_Names_OK
+ then
+ Build_Entry_Names (Id_Ref, Typ, Res);
+ end if;
+
return Res;
exception
@@ -2665,7 +2677,6 @@ package body Exp_Ch3 is
Decl : Node_Id;
Has_POC : Boolean;
Id : Entity_Id;
- Names : Node_Id;
Stmts : List_Id;
Typ : Entity_Id;
@@ -3009,17 +3020,6 @@ package body Exp_Ch3 is
Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
- -- Generate the statements which map a string entry name to a
- -- task entry index. Note that the task may not have entries.
-
- if Entry_Names_OK then
- Names := Build_Entry_Names (Rec_Type);
-
- if Present (Names) then
- Append_To (Stmts, Names);
- end if;
- end if;
-
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
@@ -3073,18 +3073,6 @@ package body Exp_Ch3 is
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Stmts,
Make_Initialize_Protection (Rec_Type));
-
- -- Generate the statements which map a string entry name to a
- -- protected entry index. Note that the protected type may not
- -- have entries.
-
- if Entry_Names_OK then
- Names := Build_Entry_Names (Rec_Type);
-
- if Present (Names) then
- Append_To (Stmts, Names);
- end if;
- end if;
end if;
-- Second pass: components with per-object constraints
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 8ce3870f002..77397c65927 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -1363,59 +1363,54 @@ package body Exp_Ch9 is
-- Build_Entry_Names --
-----------------------
- function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Conc_Typ);
- B_Decls : List_Id;
- B_Stmts : List_Id;
- Comp : Node_Id;
- Index : Entity_Id;
- Index_Typ : RE_Id;
- Typ : Entity_Id := Conc_Typ;
-
- procedure Build_Entry_Family_Name (Id : Entity_Id);
- -- Generate:
- -- for Lnn in Family_Low .. Family_High loop
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or> _init._task_id,
- -- Inn,
- -- new String ("<Entry name>(" & Lnn'Img & ")"));
- -- end loop;
- -- Note that the bounds of the range may reference discriminants. The
- -- above construct is added directly to the statements of the block.
-
- procedure Build_Entry_Name (Id : Entity_Id);
- -- Generate:
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or>_init._task_id,
- -- Inn,
- -- new String ("<Entry name>");
- -- The above construct is added directly to the statements of the block.
-
- function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
- -- Generate the call to the runtime routine Set_Entry_Name with actuals
- -- _init._task_id or _init._object, Inn and Arg3.
-
- procedure Increment_Index (Stmts : List_Id);
- -- Generate the following and add it to Stmts
- -- Inn := Inn + 1;
-
- -----------------------------
- -- Build_Entry_Family_Name --
- -----------------------------
-
- procedure Build_Entry_Family_Name (Id : Entity_Id) is
- Def : constant Node_Id :=
- Discrete_Subtype_Definition (Parent (Id));
- L_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
- L_Stmts : constant List_Id := New_List;
- Val : Node_Id;
+ procedure Build_Entry_Names
+ (Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id;
+ Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Ref);
+ Data : Entity_Id := Empty;
+ Index : Entity_Id := Empty;
+ Typ : Entity_Id := Obj_Typ;
+
+ procedure Build_Entry_Name (Comp_Id : Entity_Id);
+ -- Given an entry [family], create a static string which denotes the
+ -- name of Comp_Id and assign it to the underlying data structure which
+ -- contains the entry names of a concurrent object.
+
+ function Object_Reference return Node_Id;
+ -- Return a reference to field _object or _task_id depending on the
+ -- concurrent object being processed.
+
+ ----------------------
+ -- Build_Entry_Name --
+ ----------------------
+ procedure Build_Entry_Name (Comp_Id : Entity_Id) is
function Build_Range (Def : Node_Id) return Node_Id;
-- Given a discrete subtype definition of an entry family, generate a
-- range node which covers the range of Def's type.
+ procedure Create_Index_And_Data;
+ -- Generate the declarations of variables Index and Data. Subsequent
+ -- calls do nothing.
+
+ function Increment_Index return Node_Id;
+ -- Increment the index used in the assignment of string names to the
+ -- Data array.
+
+ function Name_Declaration (Def_Id : Entity_Id) return Node_Id;
+ -- Given the name of a temporary variable, create the following
+ -- declaration for it:
+ --
+ -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
+
+ function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id;
+ -- Given the name of a temporary variable, place it in the array of
+ -- string names. Generate:
+ --
+ -- Data (Index) := Def_Id'Unchecked_Access;
+
-----------------
-- Build_Range --
-----------------
@@ -1432,7 +1427,10 @@ package body Exp_Ch9 is
if Is_Entity_Name (Low)
and then Ekind (Entity (Low)) = E_Discriminant
then
- Low := Make_Identifier (Loc, Chars (Low));
+ Low :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Obj_Ref),
+ Selector_Name => Make_Identifier (Loc, Chars (Low)));
else
Low := New_Copy_Tree (Low);
end if;
@@ -1440,7 +1438,10 @@ package body Exp_Ch9 is
if Is_Entity_Name (High)
and then Ekind (Entity (High)) = E_Discriminant
then
- High := Make_Identifier (Loc, Chars (High));
+ High :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Obj_Ref),
+ Selector_Name => Make_Identifier (Loc, Chars (High)));
else
High := New_Copy_Tree (High);
end if;
@@ -1451,150 +1452,239 @@ package body Exp_Ch9 is
High_Bound => High);
end Build_Range;
- -- Start of processing for Build_Entry_Family_Name
+ ---------------------------
+ -- Create_Index_And_Data --
+ ---------------------------
- begin
- Get_Name_String (Chars (Id));
+ procedure Create_Index_And_Data is
+ begin
+ if No (Index) and then No (Data) then
+ declare
+ Count : RE_Id;
+ Data_Typ : RE_Id;
+ Index_Typ : RE_Id;
+ Size : Entity_Id;
- -- Add a leading '('
+ begin
+ if Is_Protected_Type (Typ) then
+ Count := RO_PE_Number_Of_Entries;
+ Data_Typ := RE_Protected_Entry_Names_Array;
+ Index_Typ := RE_Protected_Entry_Index;
+ else
+ Count := RO_ST_Number_Of_Entries;
+ Data_Typ := RE_Task_Entry_Names_Array;
+ Index_Typ := RE_Task_Entry_Index;
+ end if;
- Add_Char_To_Name_Buffer ('(');
+ -- Step 1: Generate the declaration of the index variable:
- -- Generate:
- -- new String'("<Entry name>(" & Lnn'Img & ")");
+ -- Index : <Index_Typ> := 1;
- -- This is an implicit heap allocation, and Comes_From_Source is
- -- False, which ensures that it will get flagged as a violation of
- -- No_Implicit_Heap_Allocations when that restriction applies.
+ Index := Make_Temporary (Loc, 'I');
- Val :=
- Make_Allocator (Loc,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (L_Id, Loc),
- Attribute_Name => Name_Img)),
- Right_Opnd =>
- Make_String_Literal (Loc,
- Strval => ")"))));
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index,
+ Object_Definition =>
+ New_Reference_To (RTE (Index_Typ), Loc),
+ Expression => Make_Integer_Literal (Loc, 1)));
- Increment_Index (L_Stmts);
- Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
+ -- Step 2: Generate the declaration of an array to house all
+ -- names:
- -- Generate:
- -- for Lnn in Family_Low .. Family_High loop
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or> _init._task_id, Inn, <Val>);
- -- end loop;
+ -- Size : constant <Index_Typ> := <Count> (Obj_Ref);
+ -- Data : aliased <Data_Typ> := (1 .. Size => null);
- Append_To (B_Stmts,
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => L_Id,
- Discrete_Subtype_Definition => Build_Range (Def))),
- Statements => L_Stmts,
- End_Label => Empty));
- end Build_Entry_Family_Name;
+ Size := Make_Temporary (Loc, 'S');
- ----------------------
- -- Build_Entry_Name --
- ----------------------
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (Index_Typ), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (Count), Loc),
+ Parameter_Associations =>
+ New_List (Object_Reference))));
+
+ Data := Make_Temporary (Loc, 'A');
+
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (Data_Typ), Loc),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => New_Reference_To (Size, Loc))),
+ Expression => Make_Null (Loc))))));
+ end;
+ end if;
+ end Create_Index_And_Data;
+
+ ---------------------
+ -- Increment_Index --
+ ---------------------
+
+ function Increment_Index return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Index, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Reference_To (Index, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end Increment_Index;
- procedure Build_Entry_Name (Id : Entity_Id) is
- Val : Node_Id;
+ ----------------------
+ -- Name_Declaration --
+ ----------------------
+
+ function Name_Declaration (Def_Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, String_From_Name_Buffer));
+ end Name_Declaration;
+
+ --------------------
+ -- Set_Entry_Name --
+ --------------------
+
+ function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Data, Loc),
+ Expressions => New_List (New_Reference_To (Index, Loc))),
+
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+ end Set_Entry_Name;
+
+ -- Local variables
+
+ Temp_Id : Entity_Id;
+ Subt_Def : Node_Id;
+
+ -- Start of processing for Build_Entry_Name
begin
- Get_Name_String (Chars (Id));
+ if Ekind (Comp_Id) = E_Entry_Family then
+ Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id));
- -- This is an implicit heap allocation, and Comes_From_Source is
- -- False, which ensures that it will get flagged as a violation of
- -- No_Implicit_Heap_Allocations when that restriction applies.
+ Create_Index_And_Data;
- Val :=
- Make_Allocator (Loc,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- String_From_Name_Buffer)));
+ -- Step 1: Create the string name of the entry family.
+ -- Generate:
+ -- Temp : aliased constant String := "name ()";
+
+ Temp_Id := Make_Temporary (Loc, 'S');
+ Get_Name_String (Chars (Comp_Id));
+ Add_Char_To_Name_Buffer (' ');
+ Add_Char_To_Name_Buffer ('(');
+ Add_Char_To_Name_Buffer (')');
+
+ Append_To (Stmts, Name_Declaration (Temp_Id));
+
+ -- Generate:
+ -- for Member in Family_Low .. Family_High loop
+ -- Set_Entry_Name (...);
+ -- Index := Index + 1;
+ -- end loop;
+
+ Append_To (Stmts,
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Temporary (Loc, 'L'),
+ Discrete_Subtype_Definition =>
+ Build_Range (Subt_Def))),
+
+ Statements => New_List (
+ Set_Entry_Name (Temp_Id),
+ Increment_Index),
+ End_Label => Empty));
+
+ -- Entry
+
+ else
+ Create_Index_And_Data;
+
+ -- Step 1: Create the string name of the entry. Generate:
+ -- Temp : aliased constant String := "name";
+
+ Temp_Id := Make_Temporary (Loc, 'S');
+ Get_Name_String (Chars (Comp_Id));
+
+ Append_To (Stmts, Name_Declaration (Temp_Id));
+
+ -- Step 2: Associate the string name with the underlying data
+ -- structure.
- Increment_Index (B_Stmts);
- Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
+ Append_To (Stmts, Set_Entry_Name (Temp_Id));
+ Append_To (Stmts, Increment_Index);
+ end if;
end Build_Entry_Name;
- -------------------------------
- -- Build_Set_Entry_Name_Call --
- -------------------------------
+ ----------------------
+ -- Object_Reference --
+ ----------------------
- function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
- Arg1 : Name_Id;
- Proc : RE_Id;
+ function Object_Reference return Node_Id is
+ Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ);
+ Field : Name_Id;
+ Ref : Node_Id;
begin
- -- Determine the proper name for the first argument and the RTS
- -- routine to call.
-
if Is_Protected_Type (Typ) then
- Arg1 := Name_uObject;
- Proc := RO_PE_Set_Entry_Name;
-
- else pragma Assert (Is_Task_Type (Typ));
- Arg1 := Name_uTask_Id;
- Proc := RO_TS_Set_Entry_Name;
+ Field := Name_uObject;
+ else
+ Field := Name_uTask_Id;
end if;
- -- Generate:
- -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
+ Ref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)),
+ Selector_Name => Make_Identifier (Loc, Field));
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (Proc), Loc),
- Parameter_Associations => New_List (
- Make_Selected_Component (Loc, -- _init._object
- Prefix => -- _init._task_id
- Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- Make_Identifier (Loc, Arg1)),
- New_Reference_To (Index, Loc), -- Inn
- Arg3)); -- Val
- end Build_Set_Entry_Name_Call;
+ if Is_Protected_Type (Typ) then
+ Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Ref,
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
- ---------------------
- -- Increment_Index --
- ---------------------
+ return Ref;
+ end Object_Reference;
- procedure Increment_Index (Stmts : List_Id) is
- begin
- -- Generate:
- -- Inn := Inn + 1;
+ -- Local variables
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Index, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- New_Reference_To (Index, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))));
- end Increment_Index;
+ Comp : Node_Id;
+ Proc : RE_Id;
-- Start of processing for Build_Entry_Names
@@ -1605,67 +1695,57 @@ package body Exp_Ch9 is
Typ := Corresponding_Concurrent_Type (Typ);
end if;
- pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
+ pragma Assert (Is_Concurrent_Type (Typ));
-- Nothing to do if the type has no entries
if not Has_Entries (Typ) then
- return Empty;
+ return;
end if;
-- Avoid generating entry names for a protected type with only one entry
if Is_Protected_Type (Typ)
- and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries)
+ and then Find_Protection_Type (Base_Type (Typ)) /=
+ RTE (RE_Protection_Entries)
then
- return Empty;
- end if;
-
- Index := Make_Temporary (Loc, 'I');
-
- -- Step 1: Generate the declaration of the index variable:
- -- Inn : Protected_Entry_Index := 0;
- -- or
- -- Inn : Task_Entry_Index := 0;
-
- if Is_Protected_Type (Typ) then
- Index_Typ := RE_Protected_Entry_Index;
- else
- Index_Typ := RE_Task_Entry_Index;
+ return;
end if;
- B_Decls := New_List;
- Append_To (B_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index,
- Object_Definition => New_Reference_To (RTE (Index_Typ), Loc),
- Expression => Make_Integer_Literal (Loc, 0)));
-
- B_Stmts := New_List;
-
- -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
- -- family member.
+ -- Step 1: Populate the array with statically generated strings denoting
+ -- entries and entry family names.
Comp := First_Entity (Typ);
while Present (Comp) loop
- if Ekind (Comp) = E_Entry then
+ if Comes_From_Source (Comp)
+ and then Ekind_In (Comp, E_Entry, E_Entry_Family)
+ then
Build_Entry_Name (Comp);
-
- elsif Ekind (Comp) = E_Entry_Family then
- Build_Entry_Family_Name (Comp);
end if;
Next_Entity (Comp);
end loop;
- -- Step 3: Wrap the statements in a block
+ -- Step 2: Associate the array with the related concurrent object:
- return
- Make_Block_Statement (Loc,
- Declarations => B_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => B_Stmts));
+ -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
+
+ if Present (Data) then
+ if Is_Protected_Type (Typ) then
+ Proc := RO_PE_Set_Entry_Names;
+ else
+ Proc := RO_ST_Set_Entry_Names;
+ end if;
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (Proc), Loc),
+ Parameter_Associations => New_List (
+ Object_Reference,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Data, Loc),
+ Attribute_Name => Name_Unchecked_Access))));
+ end if;
end Build_Entry_Names;
---------------------------
@@ -13505,20 +13585,6 @@ package body Exp_Ch9 is
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access));
-
- -- Build_Entry_Names generation flag. When set to true,
- -- the runtime will allocate an array to hold the string
- -- names of protected entries.
-
- if not Restricted_Profile then
- if Entry_Names_OK then
- Append_To (Args,
- New_Reference_To (Standard_True, Loc));
- else
- Append_To (Args,
- New_Reference_To (Standard_False, Loc));
- end if;
- end if;
end if;
elsif Pkg_Id =
@@ -13529,7 +13595,6 @@ package body Exp_Ch9 is
elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
Append_To (Args, Make_Null (Loc));
Append_To (Args, Make_Null (Loc));
- Append_To (Args, New_Reference_To (Standard_False, Loc));
end if;
Append_To (L,
@@ -13953,16 +14018,6 @@ package body Exp_Ch9 is
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
- -- Build_Entry_Names generation flag. When set to true, the runtime
- -- will allocate an array to hold the string names of task entries.
-
- if not Restricted_Profile then
- Append_To (Args,
- New_Reference_To
- (Boolean_Literals (Has_Entries (Ttyp) and then Entry_Names_OK),
- Loc));
- end if;
-
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
else
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index 3bbbf0dc719..65b0c195302 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -55,10 +55,15 @@ package Exp_Ch9 is
-- interface, ensure that the designated type has a _master and generate
-- a renaming of the said master to service the access type.
- function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
- -- Create the statements which populate the entry names array of a task or
- -- protected type. The statements are wrapped inside a block due to a local
- -- declaration.
+ procedure Build_Entry_Names
+ (Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id;
+ Stmts : List_Id);
+ -- Given a concurrent object, create static string names for all entries
+ -- and entry families. Associate each name with the Protection_Entries or
+ -- ATCB field of the object. Obj_Ref is a reference to the concurrent
+ -- object. Obj_Typ is the type of the object. Stmts is the list where all
+ -- generated code is attached.
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 36202bd84d3..c084b1cdcd4 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -9422,6 +9422,18 @@ accuracy in some portions of the domain.
@end cartouche
Followed.
+@cindex Sequential elaboration policy
+@unnumberedsec H.6(15/2): Pragma Partition_Elaboration_Policy
+
+@sp 1
+@cartouche
+If the partition elaboration policy is @code{Sequential} and the
+Environment task becomes permanently blocked during elaboration then the
+partition is deadlocked and it is recommended that the partition be
+immediately terminated.
+@end cartouche
+Not followed.
+
@c -----------------------------------------
@node Implementation Defined Characteristics
@chapter Implementation Defined Characteristics
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 1a38806f8c0..b1e723920c3 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19150,7 +19150,7 @@ only.
@item -fada-spec-parent=@var{unit}
@cindex -fada-spec-parent (@command{gcc})
-Specifies that all files generated by @option{-fdump-ada-spec-slim} are
+Specifies that all files generated by @option{-fdump-ada-spec*} are
to be child units of the specified parent unit.
@item -C
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 0ffaea3d9f8..63ff87cb33a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -1502,6 +1502,9 @@ package Rtsfind is
RE_Unspecified_Task_Info, -- System.Task_Info
RE_Task_Procedure_Access, -- System.Tasking
+ RE_Task_Entry_Names_Array, -- System.Tasking
+ RO_ST_Number_Of_Entries, -- System.Tasking
+ RO_ST_Set_Entry_Names, -- System.Tasking
RO_ST_Task_Id, -- System.Tasking
RO_ST_Null_Task, -- System.Tasking
@@ -1687,14 +1690,16 @@ package Rtsfind is
RE_Dispatching_Domain, -- Dispatching_Domains
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
+ RE_Protected_Entry_Names_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_Lock_Entries, -- Tasking.Protected_Objects.Entries
+ RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries
+ RO_PE_Number_Of_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries
- RO_PE_Set_Entry_Name, -- Tasking.Protected_Objects.Entries
- RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries
+ RO_PE_Set_Entry_Names, -- Tasking.Protected_Objects.Entries
RE_Communication_Block, -- Protected_Objects.Operations
RE_Protected_Entry_Call, -- Protected_Objects.Operations
@@ -1769,7 +1774,6 @@ package Rtsfind is
RE_Free_Task, -- System.Tasking.Stages
RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages
RE_Move_Activation_Chain, -- System_Tasking_Stages
- RO_TS_Set_Entry_Name, -- System.Tasking.Stages
RE_Terminated); -- System.Tasking.Stages
-- The following declarations build a table that is indexed by the RTE
@@ -2749,6 +2753,9 @@ package Rtsfind is
RE_Unspecified_Task_Info => System_Task_Info,
RE_Task_Procedure_Access => System_Tasking,
+ RE_Task_Entry_Names_Array => System_Tasking,
+ RO_ST_Number_Of_Entries => System_Tasking,
+ RO_ST_Set_Entry_Names => System_Tasking,
RO_ST_Task_Id => System_Tasking,
RO_ST_Null_Task => System_Tasking,
@@ -2937,6 +2944,8 @@ package Rtsfind is
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
+ RE_Protected_Entry_Names_Array =>
+ System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries_Access =>
@@ -2945,13 +2954,15 @@ package Rtsfind is
System_Tasking_Protected_Objects_Entries,
RE_Lock_Entries =>
System_Tasking_Protected_Objects_Entries,
+ RE_Unlock_Entries =>
+ System_Tasking_Protected_Objects_Entries,
RO_PE_Get_Ceiling =>
System_Tasking_Protected_Objects_Entries,
- RO_PE_Set_Ceiling =>
+ RO_PE_Number_Of_Entries =>
System_Tasking_Protected_Objects_Entries,
- RO_PE_Set_Entry_Name =>
+ RO_PE_Set_Ceiling =>
System_Tasking_Protected_Objects_Entries,
- RE_Unlock_Entries =>
+ RO_PE_Set_Entry_Names =>
System_Tasking_Protected_Objects_Entries,
RE_Communication_Block =>
@@ -3054,7 +3065,6 @@ package Rtsfind is
RE_Free_Task => System_Tasking_Stages,
RE_Expunge_Unactivated_Tasks => System_Tasking_Stages,
RE_Move_Activation_Chain => System_Tasking_Stages,
- RO_TS_Set_Entry_Name => System_Tasking_Stages,
RE_Terminated => System_Tasking_Stages);
--------------------------------
diff --git a/gcc/ada/s-bignum.adb b/gcc/ada/s-bignum.adb
index b3af4796136..955df4277c2 100644
--- a/gcc/ada/s-bignum.adb
+++ b/gcc/ada/s-bignum.adb
@@ -728,8 +728,9 @@ package body System.Bignums is
-- The complex full multi-precision case. We will employ algorithm
-- D defined in the section "The Classical Algorithms" (sec. 4.3.1)
- -- of Donald Knuth's "The Art of Computer Programming", Vol. 2. The
- -- terminology is adjusted for this section to match that reference.
+ -- of Donald Knuth's "The Art of Computer Programming", Vol. 2, 2nd
+ -- edition. The terminology is adjusted for this section to match that
+ -- reference.
-- We are dividing X.Len digits of X (called u here) by Y.Len digits
-- of Y (called v here), developing the quotient and remainder. The
@@ -775,12 +776,12 @@ package body System.Bignums is
v (J) := Y.D (J);
end loop;
- -- [Division of nonnegative integers]. Given nonnegative integers u
+ -- [Division of nonnegative integers.] Given nonnegative integers u
-- = (ul,u2..um+n) and v = (v1,v2..vn), where v1 /= 0 and n > 1, we
-- form the quotient u / v = (q0,ql..qm) and the remainder u mod v =
-- (r1,r2..rn).
- pragma Assert (v (1) /= 0);
+ pragma Assert (v1 /= 0);
pragma Assert (n > 1);
-- Dl. [Normalize.] Set d = b/(vl + 1). Then set (u0,u1,u2..um+n)
@@ -789,7 +790,7 @@ package body System.Bignums is
-- u0 at the left of u1; if d = 1 all we need to do in this step is
-- to set u0 = 0.
- d := b / DD (v1 + 1);
+ d := b / (DD (v1) + 1);
if d = 1 then
u0 := 0;
@@ -826,15 +827,15 @@ package body System.Bignums is
-- D2. [Initialize j.] Set j = 0. The loop on j, steps D2 through D7,
-- will be essentially a division of (uj, uj+1..uj+n) by (v1,v2..vn)
- -- to get a single quotient digit qj;
+ -- to get a single quotient digit qj.
j := 0;
-- Loop through digits
loop
- -- D3. [Calculate qhat] If uj = v1, set qhat to b-l; otherwise set
- -- qhat to (uj,uj+1)/v1.
+ -- D3. [Calculate qhat.] If uj = v1, set qhat to b-l; otherwise
+ -- set qhat to (uj,uj+1)/v1.
if u (j) = v1 then
qhat := -1;
diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb
index 519626cb9c4..00c54ed9e47 100644
--- a/gcc/ada/s-taskin.adb
+++ b/gcc/ada/s-taskin.adb
@@ -33,8 +33,6 @@ pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
-with Ada.Unchecked_Deallocation;
-
with System.Task_Primitives.Operations;
with System.Storage_Elements;
@@ -42,19 +40,6 @@ package body System.Tasking is
package STPO renames System.Task_Primitives.Operations;
- ----------------------------
- -- Free_Entry_Names_Array --
- ----------------------------
-
- procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is
- procedure Free_String is new
- Ada.Unchecked_Deallocation (String, String_Access);
- begin
- for Index in Obj'Range loop
- Free_String (Obj (Index));
- end loop;
- end Free_Entry_Names_Array;
-
---------------------
-- Detect_Blocking --
---------------------
@@ -70,6 +55,15 @@ package body System.Tasking is
return GL_Detect_Blocking = 1;
end Detect_Blocking;
+ -----------------------
+ -- Number_Of_Entries --
+ -----------------------
+
+ function Number_Of_Entries (Self_Id : Task_Id) return Task_Entry_Index is
+ begin
+ return Self_Id.Entry_Num;
+ end Number_Of_Entries;
+
----------
-- Self --
----------
@@ -257,4 +251,16 @@ package body System.Tasking is
T.Entry_Calls (1).Self := T;
end Initialize;
+ ---------------------
+ -- Set_Entry_Names --
+ ---------------------
+
+ procedure Set_Entry_Names
+ (Self_Id : Task_Id;
+ Names : Task_Entry_Names_Access)
+ is
+ begin
+ Self_Id.Entry_Names := Names;
+ end Set_Entry_Names;
+
end System.Tasking;
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
index d31313708f7..9584901d3e7 100644
--- a/gcc/ada/s-taskin.ads
+++ b/gcc/ada/s-taskin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -252,13 +252,10 @@ package System.Tasking is
type String_Access is access all String;
- type Entry_Names_Array is
- array (Entry_Index range <>) of String_Access;
+ type Task_Entry_Names_Array is
+ array (Task_Entry_Index range <>) of String_Access;
- type Entry_Names_Array_Access is access all Entry_Names_Array;
-
- procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array);
- -- Deallocate all string names contained in an entry names array
+ type Task_Entry_Names_Access is access all Task_Entry_Names_Array;
----------------------------------
-- Entry_Call_Record definition --
@@ -968,10 +965,13 @@ package System.Tasking is
-- associated with protected objects or task entries, and are protected
-- by the protected object lock or Acceptor.L, respectively.
- Entry_Names : Entry_Names_Array_Access := null;
+ Entry_Names : Task_Entry_Names_Access := null;
-- An array of string names which denotes entry [family member] names.
-- The structure is indexed by task entry index and contains Entry_Num
-- components.
+ --
+ -- Protection: The array is populated during task initialization, before
+ -- the task has been activated. No protection is required in this case.
New_Base_Priority : System.Any_Priority;
-- New value for Base_Priority (for dynamic priorities package)
@@ -1203,4 +1203,13 @@ private
-- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces
-- Activation_Chain to be a by-reference type; see RM-6.2(4).
+ function Number_Of_Entries (Self_Id : Task_Id) return Task_Entry_Index;
+ -- Given a task, return the number of entries it contains
+
+ procedure Set_Entry_Names
+ (Self_Id : Task_Id;
+ Names : Task_Entry_Names_Access);
+ -- Associate an array of string that denote entry [family] names with a
+ -- task.
+
end System.Tasking;
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index ab75b2337c5..cf63a304546 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -91,9 +91,6 @@ package body System.Tasking.Stages is
procedure Free is new
Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
- procedure Free_Entry_Names (T : Task_Id);
- -- Deallocate all string names associated with task entries
-
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
-- This procedure outputs the task specific message for exception
-- tracing purposes.
@@ -487,8 +484,7 @@ package body System.Tasking.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id;
- Build_Entry_Names : Boolean)
+ Created_Task : out Task_Id)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
@@ -706,14 +702,6 @@ package body System.Tasking.Stages is
Dispatching_Domain_Tasks (Base_CPU) + 1;
end if;
- -- Note: we should not call 'new' while holding locks since new may use
- -- locks (e.g. RTS_Lock under Windows) itself and cause a deadlock.
-
- if Build_Entry_Names then
- T.Entry_Names :=
- new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
- end if;
-
-- Create TSD as early as possible in the creation of a task, since it
-- may be used by the operation of Ada code within the task.
@@ -942,26 +930,6 @@ package body System.Tasking.Stages is
end Finalize_Global_Tasks;
- ----------------------
- -- Free_Entry_Names --
- ----------------------
-
- procedure Free_Entry_Names (T : Task_Id) is
- Names : Entry_Names_Array_Access := T.Entry_Names;
-
- procedure Free_Entry_Names_Array_Access is new
- Ada.Unchecked_Deallocation
- (Entry_Names_Array, Entry_Names_Array_Access);
-
- begin
- if Names = null then
- return;
- end if;
-
- Free_Entry_Names_Array (Names.all);
- Free_Entry_Names_Array_Access (Names);
- end Free_Entry_Names;
-
---------------
-- Free_Task --
---------------
@@ -983,7 +951,6 @@ package body System.Tasking.Stages is
Initialization.Task_Unlock (Self_Id);
- Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
else
@@ -1041,23 +1008,6 @@ package body System.Tasking.Stages is
Initialization.Undefer_Abort (Self_ID);
end Move_Activation_Chain;
- -- Compiler interface only. Do not call from within the RTS
-
- --------------------
- -- Set_Entry_Name --
- --------------------
-
- procedure Set_Entry_Name
- (T : Task_Id;
- Pos : Task_Entry_Index;
- Val : String_Access)
- is
- begin
- pragma Assert (T.Entry_Names /= null);
-
- T.Entry_Names (Entry_Index (Pos)) := Val;
- end Set_Entry_Name;
-
------------------
-- Task_Wrapper --
------------------
@@ -2119,7 +2069,6 @@ package body System.Tasking.Stages is
Unlock_RTS;
end if;
- Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads
index 9058d068a4a..e37fd59b665 100644
--- a/gcc/ada/s-tassta.ads
+++ b/gcc/ada/s-tassta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -180,8 +180,7 @@ package System.Tasking.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id;
- Build_Entry_Names : Boolean);
+ Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
@@ -212,8 +211,6 @@ package System.Tasking.Stages is
-- run time can store to ease the debugging and the
-- Ada.Task_Identification facility.
-- Created_Task is the resulting task.
- -- Build_Entry_Names is a flag which controls the allocation of the data
- -- structure which stores all entry names.
--
-- This procedure can raise Storage_Error if the task creation failed.
@@ -285,13 +282,6 @@ package System.Tasking.Stages is
-- that doesn't happen, they will never be activated, and will become
-- terminated on leaving the return statement.
- procedure Set_Entry_Name
- (T : Task_Id;
- Pos : Task_Entry_Index;
- Val : String_Access);
- -- This is called by the compiler to map a string which denotes an entry
- -- name to a task entry index.
-
function Terminated (T : Task_Id) return Boolean;
-- This is called by the compiler to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to synchronize
diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb
index 88527315e42..f535a067bf7 100644
--- a/gcc/ada/s-tpoben.adb
+++ b/gcc/ada/s-tpoben.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2012, 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- --
@@ -41,8 +41,6 @@
-- Note: the compiler generates direct calls to this interface, via Rtsfind
-with Ada.Unchecked_Deallocation;
-
with System.Task_Primitives.Operations;
with System.Restrictions;
with System.Parameters;
@@ -58,13 +56,6 @@ package body System.Tasking.Protected_Objects.Entries is
use Parameters;
use Task_Primitives.Operations;
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Free_Entry_Names (Object : Protection_Entries);
- -- Deallocate all string names associated with protected entries
-
----------------
-- Local Data --
----------------
@@ -141,8 +132,6 @@ package body System.Tasking.Protected_Objects.Entries is
end loop;
end loop;
- Free_Entry_Names (Object);
-
Object.Finalized := True;
if Single_Lock then
@@ -154,26 +143,6 @@ package body System.Tasking.Protected_Objects.Entries is
STPO.Finalize_Lock (Object.L'Unrestricted_Access);
end Finalize;
- ----------------------
- -- Free_Entry_Names --
- ----------------------
-
- procedure Free_Entry_Names (Object : Protection_Entries) is
- Names : Entry_Names_Array_Access := Object.Entry_Names;
-
- procedure Free_Entry_Names_Array_Access is new
- Ada.Unchecked_Deallocation
- (Entry_Names_Array, Entry_Names_Array_Access);
-
- begin
- if Names = null then
- return;
- end if;
-
- Free_Entry_Names_Array (Names.all);
- Free_Entry_Names_Array_Access (Names);
- end Free_Entry_Names;
-
-----------------
-- Get_Ceiling --
-----------------
@@ -202,12 +171,11 @@ package body System.Tasking.Protected_Objects.Entries is
-----------------------------------
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access;
- Build_Entry_Names : Boolean)
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Bodies : Protected_Entry_Body_Access;
+ Find_Body_Index : Find_Body_Index_Access)
is
Init_Priority : Integer := Ceiling_Priority;
Self_ID : constant Task_Id := STPO.Self;
@@ -250,11 +218,6 @@ package body System.Tasking.Protected_Objects.Entries is
Object.Entry_Queues (E).Head := null;
Object.Entry_Queues (E).Tail := null;
end loop;
-
- if Build_Entry_Names then
- Object.Entry_Names :=
- new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
- end if;
end Initialize_Protection_Entries;
------------------
@@ -391,6 +354,17 @@ package body System.Tasking.Protected_Objects.Entries is
end if;
end Lock_Read_Only_Entries;
+ -----------------------
+ -- Number_Of_Entries --
+ -----------------------
+
+ function Number_Of_Entries
+ (Object : Protection_Entries_Access) return Protected_Entry_Index
+ is
+ begin
+ return Object.Num_Entries;
+ end Number_Of_Entries;
+
-----------------
-- Set_Ceiling --
-----------------
@@ -402,20 +376,17 @@ package body System.Tasking.Protected_Objects.Entries is
Object.New_Ceiling := Prio;
end Set_Ceiling;
- --------------------
- -- Set_Entry_Name --
- --------------------
+ ---------------------
+ -- Set_Entry_Names --
+ ---------------------
- procedure Set_Entry_Name
- (Object : Protection_Entries'Class;
- Pos : Protected_Entry_Index;
- Val : String_Access)
+ procedure Set_Entry_Names
+ (Object : Protection_Entries_Access;
+ Names : Protected_Entry_Names_Access)
is
begin
- pragma Assert (Object.Entry_Names /= null);
-
- Object.Entry_Names (Entry_Index (Pos)) := Val;
- end Set_Entry_Name;
+ Object.Entry_Names := Names;
+ end Set_Entry_Names;
--------------------
-- Unlock_Entries --
diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads
index ce7045cf56e..acdf69fbee9 100644
--- a/gcc/ada/s-tpoben.ads
+++ b/gcc/ada/s-tpoben.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -67,6 +67,14 @@ package System.Tasking.Protected_Objects.Entries is
type Protected_Entry_Queue_Array is
array (Protected_Entry_Index range <>) of Entry_Queue;
+ -- A data structure which contains the string names of entries and entry
+ -- family members.
+
+ type Protected_Entry_Names_Array is
+ array (Protected_Entry_Index range <>) of String_Access;
+
+ type Protected_Entry_Names_Access is access all Protected_Entry_Names_Array;
+
-- This type contains the GNARL state of a protected object. The
-- application-defined portion of the state (i.e. private objects)
-- is maintained by the compiler-generated code.
@@ -136,7 +144,7 @@ package System.Tasking.Protected_Objects.Entries is
Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
- Entry_Names : Entry_Names_Array_Access := null;
+ 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_
-- Entries components.
@@ -167,12 +175,11 @@ package System.Tasking.Protected_Objects.Entries is
-- System.Tasking.Protected_Objects.Initialize_Protection.
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access;
- Build_Entry_Names : Boolean);
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ 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
-- to keep track of the runtime state of a protected object.
@@ -201,17 +208,20 @@ package System.Tasking.Protected_Objects.Entries is
-- possible future use. At the current time, everyone uses Lock for both
-- read and write locks.
+ function Number_Of_Entries
+ (Object : Protection_Entries_Access) return Protected_Entry_Index;
+ -- Return the number of entries of a protected object
+
procedure Set_Ceiling
(Object : Protection_Entries_Access;
Prio : System.Any_Priority);
-- Sets the new ceiling priority of the protected object
- procedure Set_Entry_Name
- (Object : Protection_Entries'Class;
- Pos : Protected_Entry_Index;
- Val : String_Access);
- -- This is called by the compiler to map a string which denotes an entry
- -- name to a protected entry index.
+ procedure Set_Entry_Names
+ (Object : Protection_Entries_Access;
+ Names : Protected_Entry_Names_Access);
+ -- Associate an array of string that denote entry [family] names with a
+ -- protected object.
procedure Unlock_Entries (Object : Protection_Entries_Access);
-- Relinquish ownership of the lock for the object represented by the