-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Itypes; use Itypes;
-- C : out Prim_Op_Kind
procedure Build_Common_Dispatching_Select_Statements
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Stmts : List_Id);
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ DT_Ptr : Entity_Id;
+ Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between
-- asynchronous, conditional and timed select expansion.
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
Typ : Entity_Id;
+ DT_Ptr : Entity_Id;
Stmts : List_Id)
is
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id := Typ;
-
begin
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
-
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
-
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
-
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
Make_Identifier (Loc, Name_uS)))));
-- Generate:
+
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
Get_Access_Level => RE_Get_Access_Level,
Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag,
+ Get_Offset_Index => RE_Get_Offset_Index,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_RC_Offset => RE_Get_RC_Offset,
Set_Entry_Index => RE_Set_Entry_Index,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
+ Set_Offset_Index => RE_Set_Offset_Index,
+ Set_OSD => RE_Set_OSD,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
Set_RC_Offset => RE_Set_RC_Offset,
Set_Remotely_Callable => RE_Set_Remotely_Callable,
+ Set_SSD => RE_Set_SSD,
Set_TSD => RE_Set_TSD,
TSD_Entry_Size => RE_TSD_Entry_Size,
TSD_Prologue_Size => RE_TSD_Prologue_Size);
Get_Access_Level => False,
Get_Entry_Index => False,
Get_External_Tag => False,
+ Get_Offset_Index => False,
Get_Prim_Op_Address => False,
Get_Prim_Op_Kind => False,
Get_Remotely_Callable => False,
Set_Entry_Index => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
+ Set_Offset_Index => True,
+ Set_OSD => True,
Set_Prim_Op_Address => True,
Set_Prim_Op_Kind => True,
Set_RC_Offset => True,
Set_Remotely_Callable => True,
+ Set_SSD => True,
Set_TSD => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
Get_Access_Level => 1,
Get_Entry_Index => 2,
Get_External_Tag => 1,
+ Get_Offset_Index => 2,
Get_Prim_Op_Address => 2,
Get_Prim_Op_Kind => 2,
Get_RC_Offset => 1,
Set_Entry_Index => 3,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
+ Set_Offset_Index => 3,
+ Set_OSD => 2,
Set_Prim_Op_Address => 3,
Set_Prim_Op_Kind => 3,
Set_RC_Offset => 2,
Set_Remotely_Callable => 2,
+ Set_SSD => 2,
Set_TSD => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
elsif TSS_Name = TSS_Deep_Finalize then
return Uint_10;
- elsif Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ elsif Ada_Version >= Ada_05 then
+ if Chars (E) = Name_uDisp_Asynchronous_Select then
+ return Uint_11;
- elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ elsif Chars (E) = Name_uDisp_Conditional_Select then
+ return Uint_12;
- elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
+ return Uint_13;
- elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_14;
+ elsif Chars (E) = Name_uDisp_Get_Task_Id then
+ return Uint_14;
- else
- raise Program_Error;
+ elsif Chars (E) = Name_uDisp_Timed_Select then
+ return Uint_15;
+ end if;
end if;
+
+ raise Program_Error;
end Default_Prim_Op_Position;
-----------------------------
(Etype (First_Entity (Target)),
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
-
end if;
Formal := Next (First (Formals));
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Obj);
-
begin
return Make_DT_Access_Action
(Typ => Etype (Obj),
AI : Elmt_Id;
begin
- -- No need to inherit primitives if it an abstract interface type
+ -- No need to inherit primitives if we have an abstract interface
+ -- type or a concurrent type.
- if Is_Interface (Typ) then
+ if Is_Interface (Typ) or else Is_Concurrent_Record_Type (Typ) then
return Result;
end if;
AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
while Present (AI) loop
+
-- All the secondary tables inherit the dispatch table entries
-- associated with predefined primitives.
return Result;
end Init_Predefined_Interface_Primitives;
- -------------
- -- Make_DT --
- -------------
-
- function Make_DT (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Result : constant List_Id := New_List;
- Elab_Code : constant List_Id := New_List;
-
- Tname : constant Name_Id := Chars (Typ);
- Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
- Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
- Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
- Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
- Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
-
- DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
- DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
- TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
- Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
- No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Body --
+ ----------------------------------------
- Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
- I_Depth : Int;
- Size_Expr_Node : Node_Id;
- Old_Tag1 : Node_Id;
- Old_Tag2 : Node_Id;
- Num_Ifaces : Int;
- Nb_Prim : Int;
- TSD_Num_Entries : Int;
- Typ_Copy : constant Entity_Id := New_Copy (Typ);
- AI : Elmt_Id;
+ function Make_Disp_Asynchronous_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : constant List_Id := New_List;
begin
- if not RTE_Available (RE_Tag) then
- Error_Msg_CRT ("tagged types", Typ);
- return New_List;
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
end if;
- -- Collect the full list of directly and indirectly implemented
- -- interfaces
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
- Set_Parent (Typ_Copy, Parent (Typ));
- Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
- Collect_All_Interfaces (Typ_Copy);
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- -- Calculate the number of entries required in the table of interfaces
+ if Present (Conc_Typ) then
- Num_Ifaces := 0;
- AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
- while Present (AI) loop
- Num_Ifaces := Num_Ifaces + 1;
- Next_Elmt (AI);
- end loop;
+ -- Generate:
+ -- I : Integer := get_entry_index (tag! (<type>VP), S);
- -- Count ancestors to compute the inheritance depth. For private
- -- extensions, always go to the full view in order to compute the real
- -- inheritance depth.
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
- declare
- Parent_Type : Entity_Id := Typ;
- P : Entity_Id;
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
- begin
- I_Depth := 0;
- loop
- P := Etype (Parent_Type);
+ if Ekind (Conc_Typ) = E_Protected_Type then
- if Is_Private_Type (P) then
- P := Full_View (Base_Type (P));
- end if;
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Asynchronous_Call,
+ -- B);
- exit when P = Parent_Type;
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and B is the name of the communication
+ -- block.
- I_Depth := I_Depth + 1;
- Parent_Type := P;
- end loop;
- end;
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
- -- Ada 2005 (AI-345): The size of the TSD is increased to accomodate
- -- the two tables used for dispatching in asynchronous, conditional
- -- and timed selects. The tables are solely generated for limited
- -- types that implement a limited interface.
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- if Ada_Version >= Ada_05
- and then not Is_Interface (Typ)
- and then not Is_Abstract (Typ)
- and then not Is_Controlled (Typ)
- and then Implements_Limited_Interface (Typ)
- then
- TSD_Num_Entries := I_Depth + Num_Ifaces + 1 +
- 2 * (Nb_Prim - Default_Prim_Op_Count);
- else
- TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
- end if;
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uB)))); -- comm block
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
- -- ----------------------------------------------------------------
- -- Dispatch table and related entities are allocated statically
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
- Set_Ekind (DT, E_Variable);
- Set_Is_Statically_Allocated (DT);
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
- Set_Ekind (DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (DT_Ptr);
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Set_Ekind (TSD, E_Variable);
- Set_Is_Statically_Allocated (TSD);
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
- Set_Ekind (Exname, E_Variable);
- Set_Is_Statically_Allocated (Exname);
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- Set_Ekind (No_Reg, E_Variable);
- Set_Is_Statically_Allocated (No_Reg);
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
- -- Generate code to create the storage for the Dispatch_Table object:
+ -- Implementation for limited tagged types
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
- Size_Expr_Node :=
- Make_Op_Add (Loc,
- Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
- Right_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Nb_Prim)));
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Asynchronous_Select_Body;
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node))))));
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Spec --
+ ----------------------------------------
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Reference_To (DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
+ function Make_Disp_Asynchronous_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Asynchronous_Select);
+ Params : constant List_Id := New_List;
- -- Generate code to create the pointer to the dispatch table
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "B" - Communication block
+ -- "F" - Status flag
- -- DT_Ptr : Tag := Tag!(DT'Address);
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_B (Loc, Params);
+ SEU.Build_F (Loc, Params);
- -- According to the C++ ABI, the base of the vtable is located after a
- -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
- -- down the pointer to the real base of the vtable
+ Set_Is_Internal (Def_Id);
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Generalized_Tag, Loc),
- Expression =>
- Unchecked_Convert_To (Generalized_Tag,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Attribute_Name => Name_Address)),
- Right_Opnd =>
- Make_DT_Access_Action (Typ,
- DT_Prologue_Size, No_List)))));
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Asynchronous_Select_Spec;
- -- Generate code to define the boolean that controls registration, in
- -- order to avoid multiple registrations for tagged types defined in
- -- multiple-called scopes.
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Body --
+ ---------------------------------------
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => No_Reg,
- Object_Definition => New_Reference_To (Standard_Boolean, Loc),
- Expression => New_Reference_To (Standard_True, Loc)));
+ function Make_Disp_Conditional_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Blk_Nam : Entity_Id;
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Stmts : constant List_Id := New_List;
- -- Set Access_Disp_Table field to be the dispatch table pointer
+ begin
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
- if not Present (Access_Disp_Table (Typ)) then
- Set_Access_Disp_Table (Typ, New_Elmt_List);
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
- Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- -- Generate code to create the storage for the type specific data object
- -- with enough space to store the tags of the ancestors plus the tags
- -- of all the implemented interfaces (as described in a-tags.adb).
- --
- -- TSD: Storage_Array
- -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
- -- for TSD'Alignment use Address'Alignment
+ if Present (Conc_Typ) then
- Size_Expr_Node :=
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
- Right_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
- Right_Opnd =>
- Make_Integer_Literal (Loc, TSD_Num_Entries)));
+ -- Generate:
+ -- I : Integer;
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => TSD,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node))))));
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Reference_To (TSD, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
- -- Generate code to put the Address of the TSD in the dispatch table
- -- Set_TSD (DT_Ptr, TSD);
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_TSD,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (TSD, Loc),
- Attribute_Name => Name_Address))));
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
- -- Generate: Exname : constant String := full_qualified_name (typ);
- -- The type itself may be an anonymous parent type, so use the first
- -- subtype to have a user-recognizable name.
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exname,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- Full_Qualified_Name (First_Subtype (Typ)))));
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- Bnn : Communication_Block;
+
+ -- where Bnn is the name of the communication block used in
+ -- the call to Protected_Entry_Call.
+
+ Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Nam,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+ -- Generate:
+ -- I := get_entry_index (tag! (<type>VP), S);
+
+ -- I is the entry index and S is the dispatch table slot
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- Bnn);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and Bnn is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ New_Reference_To ( -- Bnn
+ Blk_Nam, Loc))));
+
+ -- Generate:
+ -- F := not Cancelled (Bnn);
+
+ -- where F is the success flag. The status of Cancelled is negated
+ -- in order to match the behaviour of the version for task types.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uF),
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Blk_Nam, Loc))))));
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+
+ -- Implementation for limited tagged types
+
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Conditional_Select_Body;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Spec --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Conditional_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "C" - Call kind
+ -- "F" - Status flag
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
+
+ Set_Is_Internal (Def_Id);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Conditional_Select_Spec;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Body --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ DT_Ptr : Entity_Id;
+
+ begin
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Prim_Op_Kind,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))))));
+ end Make_Disp_Get_Prim_Op_Kind_Body;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Spec --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Get_Prim_Op_Kind);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "C" - Call kind
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_C (Loc, Params);
+
+ Set_Is_Internal (Def_Id);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Get_Prim_Op_Kind_Spec;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Body --
+ --------------------------------
+
+ function Make_Disp_Get_Task_Id_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Ret : Node_Id;
+
+ begin
+ if Is_Concurrent_Record_Type (Typ)
+ and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
+ then
+ Ret :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)));
+
+ -- A null body is constructed for non-task types
+
+ else
+ Ret :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ New_Reference_To (RTE (RO_ST_Null_Task), Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Task_Id_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Ret)));
+ end Make_Disp_Get_Task_Id_Body;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Spec --
+ --------------------------------
+
+ function Make_Disp_Get_Task_Id_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Get_Task_Id);
+
+ begin
+ Set_Is_Internal (Def_Id);
+
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc))),
+ Result_Definition =>
+ New_Reference_To (RTE (RO_ST_Task_Id), Loc));
+ end Make_Disp_Get_Task_Id_Spec;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Body --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Stmts : constant List_Id := New_List;
+
+ begin
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
- -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Expanded_Name,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
- -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
+ if Present (Conc_Typ) then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Access_Level,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
+ -- Generate:
+ -- I := get_entry_index (tag! (<type>VP), S);
- -- Generate:
- -- Set_Offset_To_Top (DT_Ptr, 0);
+ -- I is the entry index and S is the dispatch table slot
- Append_To (Elab_Code,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
- Make_Integer_Literal (Loc, Uint_0))));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
- if Typ = Etype (Typ)
- or else Is_CPP_Class (Etype (Typ))
- then
- Old_Tag1 :=
- Unchecked_Convert_To (Generalized_Tag,
- Make_Integer_Literal (Loc, 0));
- Old_Tag2 :=
- Unchecked_Convert_To (Generalized_Tag,
- Make_Integer_Literal (Loc, 0));
+ if Ekind (Conc_Typ) = E_Protected_Type then
- else
- Old_Tag1 :=
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
- Old_Tag2 :=
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
- end if;
+ -- Generate:
+ -- Timed_Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
- if Typ /= Etype (Typ)
- and then not Is_Interface (Typ)
- and then not Is_Interface (Etype (Typ))
- then
- -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Old_Tag1,
- Node2 => New_Reference_To (DT_Ptr, Loc),
- Node3 =>
- Make_Integer_Literal (Loc,
- DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- -- Inherit the secondary dispatch tables of the ancestor
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
- if not Is_CPP_Class (Etype (Typ)) then
- declare
- Sec_DT_Ancestor : Elmt_Id :=
- Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Etype (Typ))));
- Sec_DT_Typ : Elmt_Id :=
- Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Typ)));
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- procedure Copy_Secondary_DTs (Typ : Entity_Id);
- -- Local procedure required to climb through the ancestors and
- -- copy the contents of all their secondary dispatch tables.
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
- ------------------------
- -- Copy_Secondary_DTs --
- ------------------------
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
- procedure Copy_Secondary_DTs (Typ : Entity_Id) is
- E : Entity_Id;
+ -- Generate:
+ -- Timed_Task_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
- begin
- if Etype (Typ) /= Typ then
- Copy_Secondary_DTs (Etype (Typ));
- end if;
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
- if Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List
- (Abstract_Interfaces (Typ))
- then
- E := First_Entity (Typ);
- while Present (E)
- and then Present (Node (Sec_DT_Ancestor))
- loop
- if Is_Tag (E) and then Chars (E) /= Name_uTag then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Ancestor), Loc)),
- Node2 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Typ), Loc)),
- Node3 => Make_Integer_Literal (Loc,
- DT_Entry_Count (E)))));
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Next_Elmt (Sec_DT_Ancestor);
- Next_Elmt (Sec_DT_Typ);
- end if;
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
- Next_Entity (E);
- end loop;
- end if;
- end Copy_Secondary_DTs;
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- begin
- if Present (Node (Sec_DT_Ancestor)) then
- Copy_Secondary_DTs (Typ);
- end if;
- end;
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
- end if;
- -- Generate:
- -- Inherit_TSD (parent'tag, DT_Ptr);
+ -- Implementation for limited tagged types
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_TSD,
- Args => New_List (
- Node1 => Old_Tag2,
- Node2 => New_Reference_To (DT_Ptr, Loc))));
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
- -- For types with no controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, 0);
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Timed_Select_Body;
- -- For simple types with controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Spec --
+ ---------------------------------
- -- For complex types with controlled components where the position
- -- of the record controller is not statically computable, if there are
- -- controlled components at this level, generate:
- -- Set_RC_Offset (DT_Ptr, -1);
- -- to indicate that the _controller field is right after the _parent
+ function Make_Disp_Timed_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Timed_Select);
+ Params : constant List_Id := New_List;
- -- Or if there are no controlled components at this level, generate:
- -- Set_RC_Offset (DT_Ptr, -2);
- -- to indicate that we need to get the position from the parent.
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "D" - Delay
+ -- "M" - Delay Mode
+ -- "C" - Call kind
+ -- "F" - Status flag
- declare
- Position : Node_Id;
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
- begin
- if not Has_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, 0);
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uD),
+ Parameter_Type =>
+ New_Reference_To (Standard_Duration, Loc)));
- elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
- if Has_New_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, -1);
- else
- Position := Make_Integer_Literal (Loc, -2);
- end if;
- else
- Position :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Typ, Loc),
- Selector_Name =>
- New_Reference_To (Controller_Component (Typ), Loc)),
- Attribute_Name => Name_Position);
-
- -- This is not proper Ada code to use the attribute 'Position
- -- on something else than an object but this is supported by
- -- the back end (see comment on the Bit_Component attribute in
- -- sem_attr). So we avoid semantic checking here.
-
- -- Is this documented in sinfo.ads??? it should be!
-
- Set_Analyzed (Position);
- Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
- Set_Etype (Prefix (Prefix (Position)), Typ);
- Set_Etype (Selector_Name (Prefix (Position)),
- RTE (RE_Record_Controller));
- Set_Etype (Position, RTE (RE_Storage_Offset));
- end if;
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uM),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)));
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_RC_Offset,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => Position)));
- end;
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
- -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
- -- described in E.4 (18)
+ Set_Is_Internal (Def_Id);
- declare
- Status : Entity_Id;
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Timed_Select_Spec;
- begin
- Status :=
- Boolean_Literals
- (Is_Pure (Typ)
- or else Is_Shared_Passive (Typ)
- or else
- ((Is_Remote_Types (Typ)
- or else Is_Remote_Call_Interface (Typ))
- and then Original_View_In_Visible_Part (Typ))
- or else not Comes_From_Source (Typ));
+ -------------
+ -- Make_DT --
+ -------------
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Remotely_Callable,
- Args => New_List (
- New_Occurrence_Of (DT_Ptr, Loc),
- New_Occurrence_Of (Status, Loc))));
- end;
+ function Make_DT (Typ : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Result : constant List_Id := New_List;
+ Elab_Code : constant List_Id := New_List;
- -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
- -- Should be the external name not the qualified name???
+ Tname : constant Name_Id := Chars (Typ);
+ Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
+ Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
+ Name_SSD : constant Name_Id := New_External_Name (Tname, 'S');
+ Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
+ Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
+ Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
- if not Has_External_Tag_Rep_Clause (Typ) then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_External_Tag,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
+ DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
+ DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
+ SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD);
+ TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
+ Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
+ No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
- -- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only.
+ Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
+ I_Depth : Int;
+ Size_Expr_Node : Node_Id;
+ Old_Tag1 : Node_Id;
+ Old_Tag2 : Node_Id;
+ Num_Ifaces : Int;
+ Nb_Prim : Int;
+ TSD_Num_Entries : Int;
+ Typ_Copy : constant Entity_Id := New_Copy (Typ);
+ AI : Elmt_Id;
- -- Register_Tag (Dt_Ptr);
+ begin
+ if not RTE_Available (RE_Tag) then
+ Error_Msg_CRT ("tagged types", Typ);
+ return New_List;
+ end if;
- -- Skip this if routine not available, or in No_Run_Time mode
+ -- Collect full list of directly and indirectly implemented interfaces
- if RTE_Available (RE_Register_Tag)
- and then Is_RTE (Generalized_Tag, RE_Tag)
- and then not No_Run_Time_Mode
- then
- Append_To (Elab_Code,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
- Parameter_Associations =>
- New_List (New_Reference_To (DT_Ptr, Loc))));
- end if;
- end if;
+ Set_Parent (Typ_Copy, Parent (Typ));
+ Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
+ Collect_All_Interfaces (Typ_Copy);
- -- Generate:
- -- if No_Reg then
- -- <elab_code>
- -- No_Reg := False;
- -- end if;
+ -- Calculate the size of the DT and the TSD
- Append_To (Elab_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (No_Reg, Loc),
- Expression => New_Reference_To (Standard_False, Loc)));
+ if Is_Interface (Typ) then
+ -- Abstract interfaces need neither the DT nor the ancestors table.
+ -- We reserve a single entry for its DT because at run-time the
+ -- pointer to this dummy DT is the tag of this abstract interface
+ -- type.
- Append_To (Result,
- Make_Implicit_If_Statement (Typ,
- Condition => New_Reference_To (No_Reg, Loc),
- Then_Statements => Elab_Code));
+ Nb_Prim := 1;
+ TSD_Num_Entries := 0;
- -- Ada 2005 (AI-251): Register the tag of the interfaces into
- -- the table of implemented interfaces
+ else
+ -- Calculate the number of entries for the table of interfaces
- if Present (Abstract_Interfaces (Typ_Copy))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
- then
+ Num_Ifaces := 0;
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
+ Num_Ifaces := Num_Ifaces + 1;
+ Next_Elmt (AI);
+ end loop;
- -- Generate:
- -- Register_Interface (DT_Ptr, Interface'Tag);
+ -- Count ancestors to compute the inheritance depth. For private
+ -- extensions, always go to the full view in order to compute the
+ -- real inheritance depth.
- Append_To (Result,
- Make_DT_Access_Action (Typ,
- Action => Register_Interface_Tag,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 => New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table (Node (AI)))),
- Loc))));
+ declare
+ Parent_Type : Entity_Id := Typ;
+ P : Entity_Id;
- Next_Elmt (AI);
- end loop;
- end if;
+ begin
+ I_Depth := 0;
+ loop
+ P := Etype (Parent_Type);
- return Result;
- end Make_DT;
+ if Is_Private_Type (P) then
+ P := Full_View (Base_Type (P));
+ end if;
- --------------------------------
- -- Make_Abstract_Interface_DT --
- --------------------------------
+ exit when P = Parent_Type;
- procedure Make_Abstract_Interface_DT
- (AI_Tag : Entity_Id;
- Acc_Disp_Tables : in out Elist_Id;
- Result : out List_Id)
- is
- Loc : constant Source_Ptr := Sloc (AI_Tag);
- Name_DT : constant Name_Id := New_Internal_Name ('T');
- Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P');
+ I_Depth := I_Depth + 1;
+ Parent_Type := P;
+ end loop;
+ end;
- Iface_DT : constant Node_Id :=
- Make_Defining_Identifier (Loc, Name_DT);
- Iface_DT_Ptr : constant Node_Id :=
- Make_Defining_Identifier (Loc, Name_DT_Ptr);
+ TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
- Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
- Size_Expr_Node : Node_Id;
- Nb_Prim : Int;
+ -- If the number of primitives of Typ is less that the number of
+ -- predefined primitives, we must reserve at least enough space
+ -- for the predefined primitives.
- begin
- Result := New_List;
+ if Nb_Prim < Default_Prim_Op_Count then
+ Nb_Prim := Default_Prim_Op_Count;
+ end if;
+ end if;
-- Dispatch table and related entities are allocated statically
- Set_Ekind (Iface_DT, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT);
+ Set_Ekind (DT, E_Variable);
+ Set_Is_Statically_Allocated (DT);
- Set_Ekind (Iface_DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT_Ptr);
+ Set_Ekind (DT_Ptr, E_Variable);
+ Set_Is_Statically_Allocated (DT_Ptr);
- -- Generate code to create the storage for the Dispatch_Table object
+ Set_Ekind (SSD, E_Variable);
+ Set_Is_Statically_Allocated (SSD);
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ Set_Ekind (TSD, E_Variable);
+ Set_Is_Statically_Allocated (TSD);
- Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
+ Set_Ekind (Exname, E_Variable);
+ Set_Is_Statically_Allocated (Exname);
+
+ Set_Ekind (No_Reg, E_Variable);
+ Set_Is_Statically_Allocated (No_Reg);
+
+ -- Generate code to create the storage for the Dispatch_Table object:
+
+ -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+ -- for DT'Alignment use Address'Alignment
Size_Expr_Node :=
Make_Op_Add (Loc,
- Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
- DT_Prologue_Size,
- No_List),
+ Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
- Make_DT_Access_Action (Etype (AI_Tag),
- DT_Entry_Size,
- No_List),
+ Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc, Nb_Prim)));
Append_To (Result,
Make_Object_Declaration (Loc,
- Defining_Identifier => Iface_DT,
+ Defining_Identifier => DT,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+ Subtype_Mark => New_Reference_To
+ (RTE (RE_Storage_Array), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Size_Expr_Node)))),
-
- -- Initialize the signature of the interface tag. It is currently
- -- a sequence of four bytes located in the unused Typeinfo_Ptr
- -- field of the prologue). Its current value is the following
- -- sequence: (80, Nb_Prim, 0, 80)
-
- Expression =>
- Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
-
- -- -80, 0, 0, -80
-
- Choices => New_List (
- Make_Integer_Literal (Loc, Uint_5),
- Make_Integer_Literal (Loc, Uint_8)),
- Expression =>
- Make_Integer_Literal (Loc, Uint_80)),
-
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc, Uint_2)),
- Expression =>
- Make_Integer_Literal (Loc, Nb_Prim)),
-
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Others_Choice (Loc)),
- Expression => Make_Integer_Literal (Loc, Uint_0))))));
+ High_Bound => Size_Expr_Node))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
- Name => New_Reference_To (Iface_DT, Loc),
+ Name => New_Reference_To (DT, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
+ -- Initialize the signature of the interface tag. It is a sequence
+ -- two bytes located in the header of the dispatch table.
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Uint_1))),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Storage_Element),
+ New_Reference_To (RTE (RE_Valid_Signature), Loc))));
+
+ if not Is_Interface (Typ) then
+
+ -- The signature of a Primary Dispatch table is:
+ -- (Valid_Signature, Primary_DT)
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Uint_2))),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Storage_Element),
+ New_Reference_To (RTE (RE_Primary_DT), Loc))));
+
+ else
+ -- The signature of an abstract interface is:
+ -- (Valid_Signature, Abstract_Interface)
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Uint_2))),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Storage_Element),
+ New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
+ end if;
+
-- Generate code to create the pointer to the dispatch table
- -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+ -- DT_Ptr : Tag := Tag!(DT'Address);
- -- According to the C++ ABI, the base of the vtable is located
- -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
- -- Hence, move the pointer down to the real base of the vtable.
+ -- According to the C++ ABI, the base of the vtable is located after a
+ -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
+ -- down the pointer to the real base of the vtable
Append_To (Result,
Make_Object_Declaration (Loc,
- Defining_Identifier => Iface_DT_Ptr,
+ Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
+ Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
- Make_DT_Access_Action (Etype (AI_Tag),
+ Make_DT_Access_Action (Typ,
DT_Prologue_Size, No_List)))));
- -- Note: Offset_To_Top will be initialized by the init subprogram
-
- -- Set Access_Disp_Table field to be the dispatch table pointer
-
- if not (Present (Acc_Disp_Tables)) then
- Acc_Disp_Tables := New_Elmt_List;
- end if;
-
- Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
- end Make_Abstract_Interface_DT;
-
- ---------------------------
- -- Make_DT_Access_Action --
- ---------------------------
-
- function Make_DT_Access_Action
- (Typ : Entity_Id;
- Action : DT_Access_Action;
- Args : List_Id) return Node_Id
- is
- Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
- Loc : Source_Ptr;
-
- begin
- if No (Args) then
-
- -- This is a constant
-
- return New_Reference_To (Action_Name, Sloc (Typ));
- end if;
-
- pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
-
- Loc := Sloc (First (Args));
-
- if Action_Is_Proc (Action) then
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
-
- else
- return
- Make_Function_Call (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
- end if;
- end Make_DT_Access_Action;
+ -- Generate code to define the boolean that controls registration, in
+ -- order to avoid multiple registrations for tagged types defined in
+ -- multiple-called scopes.
- ----------------------------------------
- -- Make_Disp_Asynchronous_Select_Body --
- ----------------------------------------
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => No_Reg,
+ Object_Definition => New_Reference_To (Standard_Boolean, Loc),
+ Expression => New_Reference_To (Standard_True, Loc)));
- function Make_Disp_Asynchronous_Select_Body
- (Typ : Entity_Id) return Node_Id
- is
- Conc_Typ : Entity_Id := Empty;
- Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id;
- Loc : constant Source_Ptr := Sloc (Typ);
- Stmts : constant List_Id := New_List;
+ -- Set Access_Disp_Table field to be the dispatch table pointer
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ if not Present (Access_Disp_Table (Typ)) then
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
end if;
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ -- Generate code to create the storage for the type specific data object
+ -- with enough space to store the tags of the ancestors plus the tags
+ -- of all the implemented interfaces (as described in a-tags.adb).
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ -- TSD: Storage_Array
+ -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
+ -- for TSD'Alignment use Address'Alignment
- if Present (Conc_Typ) then
+ Size_Expr_Node :=
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, TSD_Num_Entries)));
- -- Generate:
- -- I : Integer := get_entry_index (tag! (<type>VP), S);
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => TSD,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Size_Expr_Node))))));
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (TSD, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ -- Generate code to put the Address of the TSD in the dispatch table
+ -- Set_TSD (DT_Ptr, TSD);
- if Ekind (Conc_Typ) = E_Protected_Type then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_TSD,
+ Args => New_List (
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Address))));
- -- Generate:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Asynchronous_Call,
- -- B);
+ -- Generate:
+ -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters and B is the name of the communication
- -- block.
+ if not Is_Interface (Typ) then
+ Append_To (Elab_Code,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Nb_Prim))));
+ end if;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Typ)
+ and then not Is_Abstract (Typ)
+ and then not Is_Controlled (Typ)
+ and then Implements_Interface (
+ Typ => Typ,
+ Kind => Any_Limited_Interface,
+ Check_Parent => True)
+ and then (Nb_Prim - Default_Prim_Op_Count) > 0
+ then
+ -- Generate the Select Specific Data table for tagged types that
+ -- implement a synchronized interface. The size of the table is
+ -- constrained by the number of non-predefined primitive operations.
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => SSD,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Select_Specific_Data), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc,
+ Nb_Prim - Default_Prim_Op_Count))))));
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ -- Set the pointer to the Select Specific Data table in the TSD
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
- Make_Identifier (Loc, Name_uB)))); -- comm block
- else
- pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_SSD,
+ Args => New_List (
+ New_Reference_To (DT_Ptr, Loc), -- DTptr
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Address))));
+ end if;
- -- Generate:
- -- Protected_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- F);
+ -- Generate: Exname : constant String := full_qualified_name (typ);
+ -- The type itself may be an anonymous parent type, so use the first
+ -- subtype to have a user-recognizable name.
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters and F is the status flag.
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Full_Qualified_Name (First_Subtype (Typ)))));
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Expanded_Name,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address))));
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ if not Is_Interface (Typ) then
+ -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Access_Level,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
+ end if;
- -- Null implementation for limited tagged types
+ if Typ = Etype (Typ)
+ or else Is_CPP_Class (Etype (Typ))
+ or else Is_Interface (Typ)
+ then
+ Old_Tag1 :=
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Integer_Literal (Loc, 0));
+ Old_Tag2 :=
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Integer_Literal (Loc, 0));
else
- Append_To (Stmts,
- Make_Null_Statement (Loc));
+ Old_Tag1 :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
+ Old_Tag2 :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Asynchronous_Select_Body;
+ if Typ /= Etype (Typ)
+ and then not Is_Interface (Typ)
+ then
+ -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
- ----------------------------------------
- -- Make_Disp_Asynchronous_Select_Spec --
- ----------------------------------------
+ if not Is_Interface (Etype (Typ)) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => Old_Tag1,
+ Node2 => New_Reference_To (DT_Ptr, Loc),
+ Node3 =>
+ Make_Integer_Literal (Loc,
+ DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
+ end if;
- function Make_Disp_Asynchronous_Select_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ -- Inherit the secondary dispatch tables of the ancestor
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "B" - Communication block
- -- "F" - Status flag
+ if not Is_CPP_Class (Etype (Typ)) then
+ declare
+ Sec_DT_Ancestor : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Etype (Typ))));
+ Sec_DT_Typ : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ)));
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id);
+ -- Local procedure required to climb through the ancestors and
+ -- copy the contents of all their secondary dispatch tables.
+
+ ------------------------
+ -- Copy_Secondary_DTs --
+ ------------------------
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_B (Loc, Params);
- SEU.Build_F (Loc, Params);
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
+ Iface : Elmt_Id;
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Asynchronous_Select_Spec;
+ begin
+ -- Climb to the ancestor (if any) handling private types
- ---------------------------------------
- -- Make_Disp_Conditional_Select_Body --
- ---------------------------------------
+ if Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Copy_Secondary_DTs (Full_View (Etype (Typ)));
+ end if;
- function Make_Disp_Conditional_Select_Body
- (Typ : Entity_Id) return Node_Id
- is
- Blk_Nam : Entity_Id;
- Conc_Typ : Entity_Id := Empty;
- Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id;
- Loc : constant Source_Ptr := Sloc (Typ);
- Stmts : constant List_Id := New_List;
+ elsif Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ Iface := First_Elmt (Abstract_Interfaces (Typ));
+ E := First_Entity (Typ);
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ while Present (E)
+ and then Present (Node (Sec_DT_Ancestor))
+ loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ if not Is_Interface (Etype (Typ)) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Ancestor),
+ Loc)),
+ Node2 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Typ), Loc)),
+ Node3 => Make_Integer_Literal (Loc,
+ DT_Entry_Count (E)))));
+ end if;
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+ Next_Elmt (Iface);
+ end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Copy_Secondary_DTs;
- if Present (Conc_Typ) then
- -- Generate:
- -- I : Integer;
+ begin
+ if Present (Node (Sec_DT_Ancestor)) then
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ -- Handle private types
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ if Present (Full_View (Typ)) then
+ Copy_Secondary_DTs (Full_View (Typ));
+ else
+ Copy_Secondary_DTs (Typ);
+ end if;
+ end if;
+ end;
+ end if;
end if;
-- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
-
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
-
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+ -- Inherit_TSD (parent'tag, DT_Ptr);
- if Present (Conc_Typ) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_TSD,
+ Args => New_List (
+ Node1 => Old_Tag2,
+ Node2 => New_Reference_To (DT_Ptr, Loc))));
- -- Generate:
- -- Bnn : Communication_Block;
+ -- For types with no controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, 0);
- -- where Bnn is the name of the communication block used in
- -- the call to Protected_Entry_Call.
+ -- For simple types with controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
- Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+ -- For complex types with controlled components where the position
+ -- of the record controller is not statically computable, if there are
+ -- controlled components at this level, generate:
+ -- Set_RC_Offset (DT_Ptr, -1);
+ -- to indicate that the _controller field is right after the _parent
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Blk_Nam,
- Object_Definition =>
- New_Reference_To (RTE (RE_Communication_Block), Loc)));
+ -- Or if there are no controlled components at this level, generate:
+ -- Set_RC_Offset (DT_Ptr, -2);
+ -- to indicate that we need to get the position from the parent.
- -- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ if not Is_Interface (Typ) then
+ declare
+ Position : Node_Id;
- -- where I is the entry index and S is the dispatch table slot.
+ begin
+ if not Has_Controlled_Component (Typ) then
+ Position := Make_Integer_Literal (Loc, 0);
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ elsif Etype (Typ) /= Typ
+ and then Has_Discriminants (Etype (Typ))
+ then
+ if Has_New_Controlled_Component (Typ) then
+ Position := Make_Integer_Literal (Loc, -1);
+ else
+ Position := Make_Integer_Literal (Loc, -2);
+ end if;
+ else
+ Position :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Selector_Name =>
+ New_Reference_To (Controller_Component (Typ), Loc)),
+ Attribute_Name => Name_Position);
+
+ -- This is not proper Ada code to use the attribute 'Position
+ -- on something else than an object but this is supported by
+ -- the back end (see comment on the Bit_Component attribute in
+ -- sem_attr). So we avoid semantic checking here.
+
+ -- Is this documented in sinfo.ads??? it should be!
+
+ Set_Analyzed (Position);
+ Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
+ Set_Etype (Prefix (Prefix (Position)), Typ);
+ Set_Etype (Selector_Name (Prefix (Position)),
+ RTE (RE_Record_Controller));
+ Set_Etype (Position, RTE (RE_Storage_Offset));
+ end if;
- if Ekind (Conc_Typ) = E_Protected_Type then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_RC_Offset,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => Position)));
+ end;
- -- Generate:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- Bnn);
+ -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
+ -- described in E.4 (18)
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters and Bnn is the name of the communication
- -- block.
+ declare
+ Status : Entity_Id;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ begin
+ Status :=
+ Boolean_Literals
+ (Is_Pure (Typ)
+ or else Is_Shared_Passive (Typ)
+ or else
+ ((Is_Remote_Types (Typ)
+ or else Is_Remote_Call_Interface (Typ))
+ and then Original_View_In_Visible_Part (Typ))
+ or else not Comes_From_Source (Typ));
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Remotely_Callable,
+ Args => New_List (
+ New_Occurrence_Of (DT_Ptr, Loc),
+ New_Occurrence_Of (Status, Loc))));
+ end;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ -- Generate:
+ -- Set_Offset_To_Top (DT_Ptr, 0);
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Conditional_Call
- RTE (RE_Conditional_Call), Loc),
- New_Reference_To ( -- Bnn
- Blk_Nam, Loc))));
+ Append_To (Elab_Code,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Uint_0))));
+ end if;
- -- Generate:
- -- F := not Cancelled (Bnn);
+ -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
+ -- Should be the external name not the qualified name???
- -- where F is the success flag. The status of Cancelled is negated
- -- in order to match the behaviour of the version for task types.
+ if not Has_External_Tag_Rep_Clause (Typ) then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_External_Tag,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address))));
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uF),
- Expression =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Cancelled), Loc),
- Parameter_Associations =>
- New_List (
- New_Reference_To (Blk_Nam, Loc))))));
- else
- pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ -- Generate code to register the Tag in the External_Tag hash
+ -- table for the pure Ada type only.
- -- Generate:
- -- Protected_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- F);
+ -- Register_Tag (Dt_Ptr);
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters and F is the status flag.
+ -- Skip this if routine not available, or in No_Run_Time mode
+ -- or Typ is an abstract interface type (because the table to
+ -- register it is not available in the abstract type but in
+ -- types implementing this interface)
- Append_To (Stmts,
+ if not No_Run_Time_Mode
+ and then RTE_Available (RE_Register_Tag)
+ and then Is_RTE (Generalized_Tag, RE_Tag)
+ and then not Is_Interface (Typ)
+ then
+ Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
- New_List (
+ New_List (New_Reference_To (DT_Ptr, Loc))));
+ end if;
+ end if;
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ -- Generate:
+ -- if No_Reg then
+ -- <elab_code>
+ -- No_Reg := False;
+ -- end if;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Append_To (Elab_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (No_Reg, Loc),
+ Expression => New_Reference_To (Standard_False, Loc)));
+
+ Append_To (Result,
+ Make_Implicit_If_Statement (Typ,
+ Condition => New_Reference_To (No_Reg, Loc),
+ Then_Statements => Elab_Code));
+
+ -- Ada 2005 (AI-251): Register the tag of the interfaces into
+ -- the table of implemented interfaces and ...
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Conditional_Call
- RTE (RE_Conditional_Call), Loc),
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ if not Is_Interface (Typ)
+ and then Present (Abstract_Interfaces (Typ_Copy))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
+ then
+ AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
+ while Present (AI) loop
- -- Null implementation for limited tagged types
+ -- Generate:
+ -- Register_Interface (DT_Ptr, Interface'Tag);
- else
- Append_To (Stmts,
- Make_Null_Statement (Loc));
+ Append_To (Result,
+ Make_DT_Access_Action (Typ,
+ Action => Register_Interface_Tag,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Node (AI)))),
+ Loc))));
+
+ Next_Elmt (AI);
+ end loop;
end if;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Conditional_Select_Body;
+ return Result;
+ end Make_DT;
- ---------------------------------------
- -- Make_Disp_Conditional_Select_Spec --
- ---------------------------------------
+ ---------------------------
+ -- Make_DT_Access_Action --
+ ---------------------------
- function Make_Disp_Conditional_Select_Spec
- (Typ : Entity_Id) return Node_Id
+ function Make_DT_Access_Action
+ (Typ : Entity_Id;
+ Action : DT_Access_Action;
+ Args : List_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
+ Loc : Source_Ptr;
begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "C" - Call kind
- -- "F" - Status flag
+ if No (Args) then
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- This is a constant
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Conditional_Select_Spec;
+ return New_Reference_To (Action_Name, Sloc (Typ));
+ end if;
- -------------------------------------
- -- Make_Disp_Get_Prim_Op_Kind_Body --
- -------------------------------------
+ pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
- function Make_Disp_Get_Prim_Op_Kind_Body
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id;
+ Loc := Sloc (First (Args));
- begin
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ if Action_Is_Proc (Action) then
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Action_Name, Loc),
+ Parameter_Associations => Args);
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Action_Name, Loc),
+ Parameter_Associations => Args);
+ end if;
+ end Make_DT_Access_Action;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ -----------------------
+ -- Make_Secondary_DT --
+ -----------------------
- -- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ procedure Make_Secondary_DT
+ (Typ : Entity_Id;
+ Ancestor_Typ : Entity_Id;
+ Suffix_Index : Int;
+ Iface : Entity_Id;
+ AI_Tag : Entity_Id;
+ Acc_Disp_Tables : in out Elist_Id;
+ Result : out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (AI_Tag);
+ Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
+ Name_DT : constant Name_Id := New_Internal_Name ('T');
+ Iface_DT : Node_Id;
+ Iface_DT_Ptr : Node_Id;
+ Name_DT_Ptr : Name_Id;
+ Nb_Prim : Int;
+ OSD : Entity_Id;
+ Size_Expr_Node : Node_Id;
+ Tname : Name_Id;
- -- where C is the out parameter capturing the call kind and S is the
- -- dispatch table slot number.
+ begin
+ Result := New_List;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
- Declarations =>
- No_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uC),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Prim_Op_Kind,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))))));
- end Make_Disp_Get_Prim_Op_Kind_Body;
+ -- Generate a unique external name associated with the secondary
+ -- dispatch table. This external name will be used to declare an
+ -- access to this secondary dispatch table, value that will be used
+ -- for the elaboration of Typ's objects and also for the elaboration
+ -- of objects of any derivation of Typ that do not override any
+ -- primitive operation of Typ.
- -------------------------------------
- -- Make_Disp_Get_Prim_Op_Kind_Spec --
- -------------------------------------
+ Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);
- function Make_Disp_Get_Prim_Op_Kind_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ Tname := Name_Find;
+ Name_DT_Ptr := New_External_Name (Tname, "P");
+ Iface_DT := Make_Defining_Identifier (Loc, Name_DT);
+ Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "C" - Call kind
+ -- Dispatch table and related entities are allocated statically
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_C (Loc, Params);
+ Set_Ekind (Iface_DT, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT);
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Get_Prim_Op_Kind_Spec;
+ Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr);
- -----------------------------
- -- Make_Disp_Select_Tables --
- -----------------------------
+ -- Generate code to create the storage for the Dispatch_Table object.
+ -- If the number of primitives of Typ is less that the number of
+ -- predefined primitives, we must reserve at least enough space
+ -- for the predefined primitives.
- function Make_Disp_Select_Tables
- (Typ : Entity_Id) return List_Id
- is
- Assignments : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id;
- Index : Uint := Uint_1;
- Loc : constant Source_Ptr := Sloc (Typ);
- Prim : Entity_Id;
- Prim_Als : Entity_Id;
- Prim_Elmt : Elmt_Id;
- Prim_Pos : Uint;
+ Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
- begin
- pragma Assert (Present (Primitive_Operations (Typ)));
+ if Nb_Prim < Default_Prim_Op_Count then
+ Nb_Prim := Default_Prim_Op_Count;
+ end if;
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+ -- for DT'Alignment use Address'Alignment
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ Size_Expr_Node :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Prologue_Size,
+ No_List),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Entry_Size,
+ No_List),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Nb_Prim)));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Size_Expr_Node))))));
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Iface_DT, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
- -- Retrieve the root of the alias chain
+ -- Initialize the signature of the interface tag. It is a sequence of
+ -- two bytes located in the header of the dispatch table. The signature
+ -- of a Secondary Dispatch Table is (Valid_Signature, Secondary_DT).
- if Present (Alias (Prim)) then
- Prim_Als := Prim;
- while Present (Alias (Prim_Als)) loop
- Prim_Als := Alias (Prim_Als);
- end loop;
- else
- Prim_Als := Empty;
- end if;
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Iface_DT, Loc),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Uint_1))),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Storage_Element),
+ New_Reference_To (RTE (RE_Valid_Signature), Loc))));
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Iface_DT, Loc),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Uint_2))),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Storage_Element),
+ New_Reference_To (RTE (RE_Secondary_DT), Loc))));
- -- We either have a procedure or a wrapper. Set the primitive
- -- operation kind for both cases and set the entry index for
- -- wrappers.
+ -- Generate code to create the pointer to the dispatch table
- if Ekind (Prim) = E_Procedure
- and then Present (Prim_Als)
- and then Is_Primitive_Wrapper (Prim_Als)
- then
- Prim_Pos := DT_Position (Prim);
+ -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
- -- Generate:
- -- set_prim_op_kind (<tag>, <position>, <kind>);
+ -- According to the C++ ABI, the base of the vtable is located
+ -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
+ -- Hence, move the pointer down to the real base of the vtable.
- Append_To (Assignments,
- Make_DT_Access_Action (Typ,
- Action =>
- Set_Prim_Op_Kind,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Integer_Literal (Loc, Prim_Pos),
- Prim_Op_Kind (Prim, Typ))));
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Generalized_Tag, Loc),
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Attribute_Name => Name_Address)),
+ Right_Opnd =>
+ Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Prologue_Size, No_List)))));
- -- The wrapped entity of the alias is an entry
+ -- Note: Offset_To_Top will be initialized by the init subprogram
- if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
- -- Generate:
- -- set_entry_index (<tag>, <position>, <index>);
+ -- Set Access_Disp_Table field to be the dispatch table pointer
- Append_To (Assignments,
- Make_DT_Access_Action (Typ,
- Action =>
- Set_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Integer_Literal (Loc, Prim_Pos),
- Make_Integer_Literal (Loc, Index))));
+ if not (Present (Acc_Disp_Tables)) then
+ Acc_Disp_Tables := New_Elmt_List;
+ end if;
- Index := Index + 1;
- end if;
- end if;
+ Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
- Next_Elmt (Prim_Elmt);
- end loop;
+ -- Step 1: Generate an Object Specific Data (OSD) table
- return Assignments;
- end Make_Disp_Select_Tables;
+ OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+ -- Generate:
+ -- OSD : Ada.Tags.Object_Specific_Data
+ -- (Nb_Prims - Default_Prim_Op_Count);
+ -- where the constraint is used to allocate space for the
+ -- non-predefined primitive operations only.
- ---------------------------------
- -- Make_Disp_Timed_Select_Body --
- ---------------------------------
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => OSD,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Object_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc,
+ Nb_Prim - Default_Prim_Op_Count))))));
- function Make_Disp_Timed_Select_Body
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Conc_Typ : Entity_Id := Empty;
- Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
- DT_Ptr_Typ : Entity_Id;
- Stmts : constant List_Id := New_List;
+ -- Generate:
+ -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
+ Append_To (Result,
+ Make_DT_Access_Action (Typ,
+ Action => Set_OSD,
+ Args => New_List (
+ New_Reference_To (Iface_DT_Ptr, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (OSD, Loc),
+ Attribute_Name => Name_Address))));
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ -- Offset table creation
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ if not Is_Interface (Typ)
+ and then not Is_Abstract (Typ)
+ and then not Is_Controlled (Typ)
+ and then Implements_Interface
+ (Typ => Typ,
+ Kind => Any_Limited_Interface,
+ Check_Parent => True)
+ and then (Nb_Prim - Default_Prim_Op_Count) > 0
+ then
+ declare
+ Prim : Entity_Id;
+ Prim_Alias : Entity_Id;
+ Prim_Elmt : Elmt_Id;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ begin
+ -- Step 2: Populate the OSD table
- if Present (Conc_Typ) then
+ Prim_Alias := Empty;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- Generate:
- -- I : Integer;
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Prim_Alias := Abstract_Interface_Alias (Prim);
+ end if;
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ if Present (Prim_Alias)
+ and then Present (First_Entity (Prim_Alias))
+ and then Etype (First_Entity (Prim_Alias)) = Iface
+ then
+ -- Generate:
+ -- Ada.Tags.Set_Offset_Index (
+ -- Iface_DT_Ptr, secondary_DT_Pos, primary_DT_pos);
+
+ Append_To (Result,
+ Make_DT_Access_Action (Iface,
+ Action => Set_Offset_Index,
+ Args => New_List (
+ New_Reference_To (Iface_DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, DT_Position (Prim_Alias)),
+ Make_Integer_Literal (Loc, DT_Position (Prim)))));
+
+ Prim_Alias := Empty;
+ end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
end if;
-- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Iface_DT_Ptr, Loc)),
+ Make_Integer_Literal (Loc, Nb_Prim))));
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+ end Make_Secondary_DT;
- if Present (Conc_Typ) then
+ -------------------------------------
+ -- Make_Select_Specific_Data_Table --
+ -------------------------------------
- -- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ function Make_Select_Specific_Data_Table
+ (Typ : Entity_Id) return List_Id
+ is
+ Assignments : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
- -- where I is the entry index and S is the dispatch table slot.
+ Conc_Typ : Entity_Id;
+ Decls : List_Id;
+ DT_Ptr : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Als : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Uint;
+ Nb_Prim : Int := 0;
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ type Examined_Array is array (Int range <>) of Boolean;
- if Ekind (Conc_Typ) = E_Protected_Type then
+ function Find_Entry_Index (E : Entity_Id) return Uint;
+ -- Given an entry, find its index in the visible declarations of the
+ -- corresponding concurrent type of Typ.
- -- Generate:
- -- Timed_Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ ----------------------
+ -- Find_Entry_Index --
+ ----------------------
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters, D is the delay amount, M is the delay
- -- mode and F is the status flag.
+ function Find_Entry_Index (E : Entity_Id) return Uint is
+ Index : Uint := Uint_1;
+ Subp_Decl : Entity_Id;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ begin
+ if Present (Decls)
+ and then not Is_Empty_List (Decls)
+ then
+ Subp_Decl := First (Decls);
+ while Present (Subp_Decl) loop
+ if Nkind (Subp_Decl) = N_Entry_Declaration then
+ if Defining_Identifier (Subp_Decl) = E then
+ return Index;
+ end if;
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ Index := Index + 1;
+ end if;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Next (Subp_Decl);
+ end loop;
+ end if;
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
+ return Uint_0;
+ end Find_Entry_Index;
+
+ -- Start of processing for Make_Select_Specific_Data_Table
+ begin
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Present (Corresponding_Concurrent_Type (Typ)) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+ Decls := Visible_Declarations (Protected_Definition (
+ Parent (Conc_Typ)));
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ Decls := Visible_Declarations (Task_Definition (
+ Parent (Conc_Typ)));
+ end if;
+ end if;
- -- Generate:
- -- Timed_Task_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ -- Count the non-predefined primitive operations
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters, D is the delay amount, M is the delay
- -- mode and F is the status flag.
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
+ Nb_Prim := Nb_Prim + 1;
+ end if;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Next_Elmt (Prim_Elmt);
+ end loop;
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ declare
+ Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count;
+ Examined : Examined_Array (1 .. Examined_Size) := (others => False);
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Prim_Pos := DT_Position (Prim);
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size);
- -- Null implementation for limited tagged types
+ if Examined (UI_To_Int (Prim_Pos)) then
+ goto Continue;
+ else
+ Examined (UI_To_Int (Prim_Pos)) := True;
+ end if;
- else
- Append_To (Stmts,
- Make_Null_Statement (Loc));
- end if;
+ -- The current primitive overrides an interface-level subprogram
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Timed_Select_Body;
+ if Present (Abstract_Interface_Alias (Prim)) then
- ---------------------------------
- -- Make_Disp_Timed_Select_Spec --
- ---------------------------------
+ -- Set the primitive operation kind regardless of subprogram
+ -- type. Generate:
+ -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
- function Make_Disp_Timed_Select_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ Append_To (Assignments,
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Set_Prim_Op_Kind,
+ Args =>
+ New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Prim_Op_Kind (Prim, Typ))));
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "D" - Delay
- -- "M" - Delay Mode
- -- "C" - Call kind
- -- "F" - Status flag
+ -- Retrieve the root of the alias chain if one is present
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
+ if Present (Alias (Prim)) then
+ Prim_Als := Prim;
+ while Present (Alias (Prim_Als)) loop
+ Prim_Als := Alias (Prim_Als);
+ end loop;
+ else
+ Prim_Als := Empty;
+ end if;
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uD),
- Parameter_Type =>
- New_Reference_To (Standard_Duration, Loc)));
+ -- In the case of an entry wrapper, set the entry index
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uM),
- Parameter_Type =>
- New_Reference_To (Standard_Integer, Loc)));
+ if Ekind (Prim) = E_Procedure
+ and then Present (Prim_Als)
+ and then Is_Primitive_Wrapper (Prim_Als)
+ and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
+ then
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- Generate:
+ -- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>);
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Timed_Select_Spec;
+ Append_To (Assignments,
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Set_Entry_Index,
+ Args =>
+ New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Make_Integer_Literal (Loc,
+ Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
+ end if;
+ end if;
+
+ <<Continue>>
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ return Assignments;
+ end Make_Select_Specific_Data_Table;
-----------------------------------
-- Original_View_In_Visible_Part --
if Ekind (Full_Typ) = E_Protected_Type then
return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
+ -- Task function
+
+ elsif Ekind (Full_Typ) = E_Task_Type then
+ return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
+
-- Regular function
else
-- Ada 2005 (AI-251)
- if Present (Abstract_Interface_Alias (Prim)) then
+ if Present (Abstract_Interface_Alias (Prim))
+ and then Is_Interface (Scope (DTC_Entity
+ (Abstract_Interface_Alias (Prim))))
+ then
Set_DTC_Entity (Prim,
Find_Interface_Tag
(T => Typ,
projects / gcc.git / blobdiff