[multiple changes]
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. From-SVN: r192933
This commit is contained in:
Arnaud Charlet
parent
8d9ef58eb8
commit
b9820f7b84
14 changed files with 513 additions and 428 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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_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_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 (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.
|
||||
|
||||
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 Object_Reference return Node_Id;
|
||||
-- Return a reference to field _object or _task_id depending on the
|
||||
-- concurrent object being processed.
|
||||
|
||||
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;
|
||||
----------------------
|
||||
-- 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 --
|
||||
---------------------------
|
||||
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
-- Step 1: Generate the declaration of the index variable:
|
||||
|
||||
-- Index : <Index_Typ> := 1;
|
||||
|
||||
Index := Make_Temporary (Loc, 'I');
|
||||
|
||||
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)));
|
||||
|
||||
-- Step 2: Generate the declaration of an array to house all
|
||||
-- names:
|
||||
|
||||
-- Size : constant <Index_Typ> := <Count> (Obj_Ref);
|
||||
-- Data : aliased <Data_Typ> := (1 .. Size => null);
|
||||
|
||||
Size := Make_Temporary (Loc, 'S');
|
||||
|
||||
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;
|
||||
|
||||
----------------------
|
||||
-- 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));
|
||||
|
||||
-- Add a leading '('
|
||||
Create_Index_And_Data;
|
||||
|
||||
Add_Char_To_Name_Buffer ('(');
|
||||
-- Step 1: Create the string name of the entry family.
|
||||
-- Generate:
|
||||
-- Temp : aliased constant String := "name ()";
|
||||
|
||||
-- Generate:
|
||||
-- new String'("<Entry name>(" & Lnn'Img & ")");
|
||||
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 (')');
|
||||
|
||||
-- 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.
|
||||
Append_To (Stmts, Name_Declaration (Temp_Id));
|
||||
|
||||
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 => ")"))));
|
||||
-- Generate:
|
||||
-- for Member in Family_Low .. Family_High loop
|
||||
-- Set_Entry_Name (...);
|
||||
-- Index := Index + 1;
|
||||
-- end loop;
|
||||
|
||||
Increment_Index (L_Stmts);
|
||||
Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
|
||||
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))),
|
||||
|
||||
-- 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;
|
||||
Statements => New_List (
|
||||
Set_Entry_Name (Temp_Id),
|
||||
Increment_Index),
|
||||
End_Label => Empty));
|
||||
|
||||
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;
|
||||
-- Entry
|
||||
|
||||
----------------------
|
||||
-- Build_Entry_Name --
|
||||
----------------------
|
||||
else
|
||||
Create_Index_And_Data;
|
||||
|
||||
procedure Build_Entry_Name (Id : Entity_Id) is
|
||||
Val : Node_Id;
|
||||
-- Step 1: Create the string name of the entry. Generate:
|
||||
-- Temp : aliased constant String := "name";
|
||||
|
||||
begin
|
||||
Get_Name_String (Chars (Id));
|
||||
Temp_Id := Make_Temporary (Loc, 'S');
|
||||
Get_Name_String (Chars (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.
|
||||
Append_To (Stmts, Name_Declaration (Temp_Id));
|
||||
|
||||
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 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;
|
||||
return;
|
||||
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;
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
RO_PE_Get_Ceiling, -- 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_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_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_Number_Of_Entries =>
|
||||
System_Tasking_Protected_Objects_Entries,
|
||||
RO_PE_Set_Ceiling =>
|
||||
System_Tasking_Protected_Objects_Entries,
|
||||
RO_PE_Set_Entry_Name =>
|
||||
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);
|
||||
|
||||
--------------------------------
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue