with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
return Ecount;
end Build_Entry_Count_Expression;
- -----------------------
- -- Build_Entry_Names --
- -----------------------
-
- 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 --
- -----------------
-
- function Build_Range (Def : Node_Id) return Node_Id is
- High : Node_Id := Type_High_Bound (Etype (Def));
- Low : Node_Id := Type_Low_Bound (Etype (Def));
-
- begin
- -- If a bound references a discriminant, generate an identifier
- -- with the same name. Resolution will map it to the formals of
- -- the init proc.
-
- if Is_Entity_Name (Low)
- and then Ekind (Entity (Low)) = E_Discriminant
- then
- 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;
-
- if Is_Entity_Name (High)
- and then Ekind (Entity (High)) = E_Discriminant
- then
- 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;
-
- return
- Make_Range (Loc,
- Low_Bound => Low,
- High_Bound => High);
- end Build_Range;
-
- ---------------------------
- -- 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;
- Size : Entity_Id;
-
- begin
- if Is_Protected_Type (Typ) then
- Count := RO_PE_Number_Of_Entries;
- Data_Typ := RE_Protected_Entry_Names_Array;
- else
- Count := RO_ST_Number_Of_Entries;
- Data_Typ := RE_Task_Entry_Names_Array;
- end if;
-
- -- Step 1: Generate the declaration of the index variable:
-
- -- Index : Entry_Index := 1;
-
- Index := Make_Temporary (Loc, 'I');
-
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Entry_Index), Loc),
- Expression => Make_Integer_Literal (Loc, 1)));
-
- -- Step 2: Generate the declaration of an array to house all
- -- names:
-
- -- Size : constant Entry_Index := <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_Occurrence_Of (RTE (RE_Entry_Index), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (Index, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (Data, Loc),
- Expressions => New_List (New_Occurrence_Of (Index, Loc))),
-
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (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
- if Ekind (Comp_Id) = E_Entry_Family then
- Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id));
-
- Create_Index_And_Data;
-
- -- 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.
-
- Append_To (Stmts, Set_Entry_Name (Temp_Id));
- Append_To (Stmts, Increment_Index);
- end if;
- end Build_Entry_Name;
-
- ----------------------
- -- Object_Reference --
- ----------------------
-
- function Object_Reference return Node_Id is
- Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ);
- Field : Name_Id;
- Ref : Node_Id;
-
- begin
- if Is_Protected_Type (Typ) then
- Field := Name_uObject;
- else
- Field := Name_uTask_Id;
- end if;
-
- Ref :=
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)),
- Selector_Name => Make_Identifier (Loc, Field));
-
- if Is_Protected_Type (Typ) then
- Ref :=
- Make_Attribute_Reference (Loc,
- Prefix => Ref,
- Attribute_Name => Name_Unchecked_Access);
- end if;
-
- return Ref;
- end Object_Reference;
-
- -- Local variables
-
- Comp : Node_Id;
- Proc : RE_Id;
-
- -- Start of processing for Build_Entry_Names
-
- begin
- -- Retrieve the original concurrent type
-
- if Is_Concurrent_Record_Type (Typ) then
- Typ := Corresponding_Concurrent_Type (Typ);
- end if;
-
- pragma Assert (Is_Concurrent_Type (Typ));
-
- -- Nothing to do if the type has no entries
-
- if not Has_Entries (Typ) then
- 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 (Base_Type (Typ)) /=
- RTE (RE_Protection_Entries)
- then
- return;
- end if;
-
- -- Step 1: Populate the array with statically generated strings denoting
- -- entries and entry family names.
-
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Comes_From_Source (Comp)
- and then Ekind_In (Comp, E_Entry, E_Entry_Family)
- then
- Build_Entry_Name (Comp);
- end if;
-
- Next_Entity (Comp);
- end loop;
-
- -- Step 2: Associate the array with the related concurrent object:
-
- -- 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_Occurrence_Of (RTE (Proc), Loc),
- Parameter_Associations => New_List (
- Object_Reference,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Data, Loc),
- Attribute_Name => Name_Unchecked_Access))));
- end if;
- end Build_Entry_Names;
-
---------------------------
-- Build_Parameter_Block --
---------------------------
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
RE_Dispatching_Domain, -- Multiprocessors.Dispatching_Domains
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
- RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries
RE_Protected_Entry_Queue_Max_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
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
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,
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
- RE_Protected_Entry_Names_Array =>
- System_Tasking_Protected_Objects_Entries,
RE_Protected_Entry_Queue_Max_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
RO_PE_Set_Ceiling =>
System_Tasking_Protected_Objects_Entries,
- RO_PE_Set_Entry_Names =>
- System_Tasking_Protected_Objects_Entries,
RE_Communication_Block =>
System_Tasking_Protected_Objects_Operations,
projects / gcc.git / commitdiff