-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Elists; use Elists;
with Errout; use Errout;
with Exp_Atag; use Exp_Atag;
-with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch6; use Exp_Ch6;
with Exp_CG; use Exp_CG;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with SCIL_LL; use SCIL_LL;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+ -- Find specific type of a class-wide type, and handle the case of an
+ -- incomplete type coming either from a limited_with clause or from an
+ -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems
+ -- like a general purpose semantic routine ???
+
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
+ and then VM_Target = No_VM
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
end Build_Static_Dispatch_Tables;
------------------------------
+ -- Convert_Tag_To_Interface --
+ ------------------------------
+
+ function Convert_Tag_To_Interface
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Anon_Type : Entity_Id;
+ Result : Node_Id;
+
+ begin
+ pragma Assert (Is_Class_Wide_Type (Typ)
+ and then Is_Interface (Typ)
+ and then
+ ((Nkind (Expr) = N_Selected_Component
+ and then Is_Tag (Entity (Selector_Name (Expr))))
+ or else
+ (Nkind (Expr) = N_Function_Call
+ and then RTE_Available (RE_Displace)
+ and then Entity (Name (Expr)) = RTE (RE_Displace))));
+
+ Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
+ Set_Directly_Designated_Type (Anon_Type, Typ);
+ Set_Etype (Anon_Type, Anon_Type);
+ Set_Can_Never_Be_Null (Anon_Type);
+
+ -- Decorate the size and alignment attributes of the anonymous access
+ -- type, as required by gigi.
+
+ Layout_Type (Anon_Type);
+
+ if Nkind (Expr) = N_Selected_Component
+ and then Is_Tag (Entity (Selector_Name (Expr)))
+ then
+ Result :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Anon_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix => Expr,
+ Attribute_Name => Name_Address)));
+ else
+ Result :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Anon_Type, Expr));
+ end if;
+
+ return Result;
+ end Convert_Tag_To_Interface;
+
+ -------------------
+ -- CPP_Num_Prims --
+ -------------------
+
+ function CPP_Num_Prims (Typ : Entity_Id) return Nat is
+ CPP_Typ : Entity_Id;
+ Tag_Comp : Entity_Id;
+
+ begin
+ if not Is_Tagged_Type (Typ)
+ or else not Is_CPP_Class (Root_Type (Typ))
+ then
+ return 0;
+
+ else
+ CPP_Typ := Enclosing_CPP_Parent (Typ);
+ Tag_Comp := First_Tag_Component (CPP_Typ);
+
+ -- If the number of primitives is already set in the tag component
+ -- then use it
+
+ if Present (Tag_Comp)
+ and then DT_Entry_Count (Tag_Comp) /= No_Uint
+ then
+ return UI_To_Int (DT_Entry_Count (Tag_Comp));
+
+ -- Otherwise, count the primitives of the enclosing CPP type
+
+ else
+ declare
+ Count : Nat := 0;
+ Elmt : Elmt_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
+ while Present (Elmt) loop
+ Count := Count + 1;
+ Next_Elmt (Elmt);
+ end loop;
+
+ return Count;
+ end;
+ end if;
+ end if;
+ end CPP_Num_Prims;
+
+ ------------------------------
-- Default_Prim_Op_Position --
------------------------------
if Chars (E) = Name_uSize then
return Uint_1;
- elsif Chars (E) = Name_uAlignment then
+ elsif TSS_Name = TSS_Stream_Read then
return Uint_2;
- elsif TSS_Name = TSS_Stream_Read then
+ elsif TSS_Name = TSS_Stream_Write then
return Uint_3;
- elsif TSS_Name = TSS_Stream_Write then
+ elsif TSS_Name = TSS_Stream_Input then
return Uint_4;
- elsif TSS_Name = TSS_Stream_Input then
+ elsif TSS_Name = TSS_Stream_Output then
return Uint_5;
- elsif TSS_Name = TSS_Stream_Output then
+ elsif Chars (E) = Name_Op_Eq then
return Uint_6;
- elsif Chars (E) = Name_Op_Eq then
+ elsif Chars (E) = Name_uAssign then
return Uint_7;
- elsif Chars (E) = Name_uAssign then
+ elsif TSS_Name = TSS_Deep_Adjust then
return Uint_8;
- elsif TSS_Name = TSS_Deep_Adjust then
+ elsif TSS_Name = TSS_Deep_Finalize then
return Uint_9;
- elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
+ -- In VM targets unconditionally allow obtaining the position associated
+ -- with predefined interface primitives since in these platforms any
+ -- tagged type has these primitives.
- elsif Ada_Version >= Ada_05 then
+ elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_15;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_16;
+ return Uint_15;
end if;
end if;
-- Local variables
- New_Node : Node_Id;
- SCIL_Node : Node_Id;
+ New_Node : Node_Id;
+ SCIL_Node : Node_Id;
+ SCIL_Related_Node : Node_Id := Call_Node;
-- Start of processing for Expand_Dispatching_Call
end if;
-- Expand_Dispatching_Call is called directly from the semantics,
- -- so we need a check to see whether expansion is active before
- -- proceeding. In addition, there is no need to expand the call
- -- if we are compiling under restriction No_Dispatching_Calls;
- -- the semantic analyzer has previously notified the violation
- -- of this restriction.
+ -- so we only proceed if the expander is active.
+
+ if not Full_Expander_Active
+
+ -- And there is no need to expand the call if we are compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
- if not Expander_Active
or else Restriction_Active (No_Dispatching_Calls)
then
return;
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
-
- -- Generate the SCIL node for this dispatching call. The SCIL node for a
- -- dispatching call is inserted in the tree before the call is rewriten
- -- and expanded because the SCIL node must be found by the SCIL backend
- -- BEFORE the expanded nodes associated with the call node are found.
-
- if Generate_SCIL then
- SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
- Set_SCIL_Related_Node (SCIL_Node, Call_Node);
- Set_SCIL_Entity (SCIL_Node, Typ);
- Set_SCIL_Target_Prim (SCIL_Node, Subp);
- Insert_Action (Call_Node, SCIL_Node);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
+ Set_Convention (Subp_Typ, Convention (Subp));
+
+ -- Notify gigi that the designated type is a dispatching primitive
+
+ Set_Is_Dispatch_Table_Entity (Subp_Typ);
-- Create a new list of parameters which is a copy of the old formal
-- list including the creation of a new set of matching entities.
else
Build_Get_Prim_Op_Address (Loc,
- Typ => Find_Dispatching_Type (Subp),
+ Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
- -- Complete decoration of SCIL dispatching node. It must be done after
- -- the new call name is built to reference the nodes that will see the
- -- SCIL backend (because Build_Get_Prim_Op_Address generates an
- -- unchecked type conversion which relocates the controlling tag node).
+ -- Generate the SCIL node for this dispatching call. Done now because
+ -- attribute SCIL_Controlling_Tag must be set after the new call name
+ -- is built to reference the nodes that will see the SCIL backend
+ -- (because Build_Get_Prim_Op_Address generates an unchecked type
+ -- conversion which relocates the controlling tag node).
if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
+ Set_SCIL_Entity (SCIL_Node, Typ);
+ Set_SCIL_Target_Prim (SCIL_Node, Subp);
-- Common case: the controlling tag is the tag of an object
-- (for example, obj.tag)
Parent (Entity (Prefix (Controlling_Tag))));
-- For a direct reference of the tag of the type the SCIL node
- -- references the the internal object declaration containing the tag
+ -- references the internal object declaration containing the tag
-- of the type.
elsif Nkind (Controlling_Tag) = N_Attribute_Reference
-- we generate: x.tag = y.tag and then x = y
if Subp = Eq_Prim_Op then
-
- -- Adjust the node referenced by the SCIL node to skip the tags
- -- comparison because it is the information needed by the SCIL
- -- backend to process this dispatching call
-
- if Generate_SCIL then
- Set_SCIL_Related_Node (SCIL_Node, New_Call);
- end if;
-
Param := First_Actual (Call_Node);
New_Call :=
Make_And_Then (Loc,
New_Reference_To
(First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
+
+ SCIL_Related_Node := Right_Opnd (New_Call);
end if;
else
Rewrite (Call_Node, New_Call);
+ -- Associate the SCIL node of this dispatching call
+
+ if Generate_SCIL then
+ Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
+ end if;
+
-- Suppress all checks during the analysis of the expanded code
-- to avoid the generation of spurious warnings under ZFP run-time.
Iface_Typ := Corresponding_Record_Type (Iface_Typ);
end if;
+ -- Handle private types
+
+ Iface_Typ := Underlying_Type (Iface_Typ);
+
-- Freeze the entity associated with the target interface to have
-- available the attribute Access_Disp_Table.
and then Is_Interface (Iface_Typ)));
if not Tagged_Type_Expansion then
+ if VM_Target /= No_VM then
+ if Is_Access_Type (Operand_Typ) then
+ Operand_Typ := Designated_Type (Operand_Typ);
+ end if;
- -- For VM, just do a conversion ???
+ if Is_Class_Wide_Type (Operand_Typ) then
+ Operand_Typ := Root_Type (Operand_Typ);
+ end if;
+
+ if not Is_Static
+ and then Operand_Typ /= Iface_Typ
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Check_Interface_Conversion), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Expression (N)),
+ Attribute_Name => Name_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface_Typ, Loc),
+ Attribute_Name => Name_Tag))));
+ end if;
+
+ -- Just do a conversion ???
+
+ Rewrite (N, Unchecked_Convert_To (Etype (N), N));
+ Analyze (N);
+ end if;
- Rewrite (N, Unchecked_Convert_To (Etype (N), N));
- Analyze (N);
return;
end if;
pragma Assert (Iface_Tag /= Empty);
-- Keep separate access types to interfaces because one internal
- -- function is used to handle the null value (see following comment)
+ -- function is used to handle the null value (see following comments)
if not Is_Access_Type (Etype (N)) then
+
+ -- Statically displace the pointer to the object to reference
+ -- the component containing the secondary dispatch table.
+
Rewrite (N,
- Unchecked_Convert_To (Etype (N),
+ Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)),
- Selector_Name =>
- New_Occurrence_Of (Iface_Tag, Loc))));
+ Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
else
-- Build internal function to handle the case in which the
and then Is_Class_Wide_Type (Formal_Typ)
then
-- No need to displace the pointer if the type of the actual
- -- coindices with the type of the formal.
+ -- coincides with the type of the formal.
if Actual_Typ = Formal_Typ then
null;
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
+ elsif Is_Ancestor (Formal_Typ, Actual_Typ,
+ Use_Full_View => True)
+ then
null;
-- Implicit conversion to the class-wide formal type to force
-- the displacement of the pointer.
else
+ -- Normally, expansion of actuals for calls to build-in-place
+ -- functions happens as part of Expand_Actuals, but in this
+ -- case the call will be wrapped in a conversion and soon after
+ -- expanded further to handle the displacement for a class-wide
+ -- interface conversion, so if this is a BIP call then we need
+ -- to handle it now.
+
+ if Ada_Version >= Ada_2005
+ and then Is_Build_In_Place_Function_Call (Actual)
+ then
+ Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
+ end if;
+
Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
+ elsif Is_Ancestor (Formal_DDT, Actual_DDT,
+ Use_Full_View => True)
+ then
null;
else
Thunk_Id := Make_Temporary (Loc, 'T');
Set_Is_Thunk (Thunk_Id);
+ Set_Convention (Thunk_Id, Convention (Prim));
-- Procedure case
end if;
end Expand_Interface_Thunk;
+ ------------------------
+ -- Find_Specific_Type --
+ ------------------------
+
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Root_Type (CW);
+
+ begin
+ if Ekind (Typ) = E_Incomplete_Type then
+ if From_With_Type (Typ) then
+ Typ := Non_Limited_View (Typ);
+ else
+ Typ := Full_View (Typ);
+ end if;
+ end if;
+
+ return Typ;
+ end Find_Specific_Type;
+
+ --------------------------
+ -- Has_CPP_Constructors --
+ --------------------------
+
+ function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ -- Look for the constructor entities
+
+ E := Next_Entity (Typ);
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ return True;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return False;
+ end Has_CPP_Constructors;
+
------------
-- Has_DT --
------------
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
or else TSS_Name = TSS_Stream_Output
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
begin
- return Ada_Version >= Ada_05
+ -- In VM targets we don't restrict the functionality of this test to
+ -- compiling in Ada 2005 mode since in VM targets any tagged type has
+ -- these primitives
+
+ return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
Chars (E) = Name_uDisp_Conditional_Select or else
Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Asynchronous_Select;
-- For protected types, generate:
Com_Block : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- New_List,
+ 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))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To
- (RTE (RE_Protected_Entry_Index), Loc),
+ (RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
+ New_Reference_To -- Asynchronous_Call
+ (RTE (RE_Asynchronous_Call), Loc),
New_Reference_To (Com_Block, Loc)))); -- comm block
Obj_Ref,
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uP),
+ Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Reference_To
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uB),
+ Name => Make_Identifier (Loc, Name_uB),
Expression =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
Expression =>
New_Reference_To (Com_Block, Loc))));
+ -- Generate:
+ -- F := False;
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
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)),
+ 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)),
+ Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
+ New_Reference_To -- Asynchronous_Call
+ (RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
else
-- Ensure that the statements list is non-empty
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Asynchronous_Select_Body;
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Conditional_Select;
-- For protected types, generate:
Blk_Nam : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- return;
-- end if;
- Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+ Build_Common_Dispatching_Select_Statements (Typ, Stmts);
-- Generate:
-- Bnn : Communication_Block;
-- I is the entry index and S is the dispatch table slot
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
+ Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
Obj_Ref,
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uP),
+ Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Reference_To
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression =>
Make_Op_Not (Loc,
Right_Opnd =>
New_List (
Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_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)),
+ 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 -- Conditional_Call
+ (RTE (RE_Conditional_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Conditional_Select_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;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
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.
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
return
Make_Subprogram_Body (Loc,
Specification =>
Name =>
New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))))));
+ Tag_Node,
+ Make_Identifier (Loc, Name_uS)))))));
end Make_Disp_Get_Prim_Op_Kind_Body;
-------------------------------------
New_Reference_To (RTE (RE_Address), Loc),
Expression =>
Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id))));
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
-- A null body is constructed for non-task types
else
Append_To (Stmts,
Make_If_Statement (Loc,
- Condition =>
- Make_Identifier (Loc, Name_uF),
+ Condition => Make_Identifier (Loc, Name_uF),
Then_Statements =>
New_List (
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Make_Identifier (Loc, Name_uO),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Subtype_Mark =>
New_Reference_To (
RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
Append_To (Stmts,
Make_If_Statement (Loc,
- Condition =>
- Make_Identifier (Loc, Name_uF),
+ Condition => Make_Identifier (Loc, Name_uF),
- Then_Statements =>
- New_List (
+ Then_Statements => New_List (
- -- Call to Requeue_Protected_To_Task_Entry
+ -- Call to Requeue_Protected_To_Task_Entry
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (
- RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
+
+ Parameter_Associations => New_List (
- Parameter_Associations =>
- New_List (
+ Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
+ Subtype_Mark =>
+ New_Reference_To
+ (RTE (RE_Protection_Entries_Access), Loc),
+ Expression => Make_Identifier (Loc, Name_uP)),
- Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
- Subtype_Mark =>
- New_Reference_To (
- RTE (RE_Protection_Entries_Access), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uP)),
+ Make_Selected_Component (Loc, -- O._task_id
+ Prefix => Make_Identifier (Loc, Name_uO),
+ Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Selected_Component (Loc, -- O._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uO),
- 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_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_uA)))), -- abort status
- Make_Identifier (Loc, Name_uA)))), -- abort status
+ Else_Statements => New_List (
- Else_Statements =>
- New_List (
+ -- Call to Requeue_Task_Entry
- -- Call to Requeue_Task_Entry
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
-
- Parameter_Associations =>
- New_List (
-
- Make_Selected_Component (Loc, -- O._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uO),
- 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_uA)))))); -- abort status
+ Parameter_Associations => New_List (
+
+ Make_Selected_Component (Loc, -- O._task_id
+ Prefix => Make_Identifier (Loc, Name_uO),
+ 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_uA)))))); -- abort status
end if;
-- Even though no declarations are needed in both cases, we allocate
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Timed_Select;
-- For protected types, generate:
-- P,
-- D,
-- M,
- -- D);
+ -- F);
-- end _Disp_Time_Select;
function Make_Disp_Timed_Select_Body
Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition => New_Reference_To (Standard_Integer, Loc)));
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
-- return;
-- end if;
- Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+ Build_Common_Dispatching_Select_Statements (Typ, Stmts);
-- Generate:
-- I := Get_Entry_Index (tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
+ Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
-- Protected case
New_List (
Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_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)),
+ Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
+ 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;
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id);
-- Verify that all non-tagged types in the profile of a subprogram
-- are frozen at the point the subprogram is frozen. This enforces
-- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
-- Typical violation of the rule involves an object declaration that
-- freezes a tagged type, when one of its primitive operations has a
-- type in its profile whose full view has not been analyzed yet.
+ -- More complex cases involve composite types that have one private
+ -- unfrozen subcomponent.
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- calls through interface types; the latter secondary table is
-- generated when Build_Thunks is False, and provides support for
-- Generic Dispatching Constructors that dispatch calls through
- -- interface types. When constructing this latter table the value
- -- of Suffix_Index is -1 to indicate that there is no need to export
- -- such table when building statically allocated dispatch tables; a
- -- positive value of Suffix_Index must match the Suffix_Index value
- -- assigned to this secondary dispatch table by Make_Tags when its
- -- unique external name was generated.
+ -- interface types. When constructing this latter table the value of
+ -- Suffix_Index is -1 to indicate that there is no need to export such
+ -- table when building statically allocated dispatch tables; a positive
+ -- value of Suffix_Index must match the Suffix_Index value assigned to
+ -- this secondary dispatch table by Make_Tags when its unique external
+ -- name was generated.
------------------------------
-- Check_Premature_Freezing --
------------------------------
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
- begin
- if Present (N)
- and then Is_Private_Type (Typ)
- and then No (Full_View (Typ))
- and then not Is_Generic_Type (Typ)
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id)
+ is
+ Comp : Entity_Id;
+
+ function Is_Actual_For_Formal_Incomplete_Type
+ (T : Entity_Id) return Boolean;
+ -- In Ada 2012, if a nested generic has an incomplete formal type,
+ -- the actual may be (and usually is) a private type whose completion
+ -- appears later. It is safe to build the dispatch table in this
+ -- case, gigi will have full views available.
+
+ ------------------------------------------
+ -- Is_Actual_For_Formal_Incomplete_Type --
+ ------------------------------------------
+
+ function Is_Actual_For_Formal_Incomplete_Type
+ (T : Entity_Id) return Boolean
+ is
+ Gen_Par : Entity_Id;
+ F : Node_Id;
+
+ begin
+ if not Is_Generic_Instance (Current_Scope)
+ or else not Used_As_Generic_Actual (T)
+ then
+ return False;
+
+ else
+ Gen_Par := Generic_Parent (Parent (Current_Scope));
+ end if;
+
+ F :=
+ First
+ (Generic_Formal_Declarations
+ (Unit_Declaration_Node (Gen_Par)));
+ while Present (F) loop
+ if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
+ return True;
+ end if;
+
+ Next (F);
+ end loop;
+
+ return False;
+ end Is_Actual_For_Formal_Incomplete_Type;
+
+ -- Start of processing for Check_Premature_Freezing
+
+ begin
+ -- Note that if the type is a (subtype of) a generic actual, the
+ -- actual will have been frozen by the instantiation.
+
+ if Present (N)
+ and then Is_Private_Type (Typ)
+ and then No (Full_View (Typ))
+ and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
+ and then not Is_Generic_Actual_Type (Typ)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_NE
("declaration must appear after completion of type &", N, Typ);
Error_Msg_NE
("\which is an untagged type in the profile of"
- & " primitive operation & declared#",
- N, Subp);
+ & " primitive operation & declared#", N, Subp);
+
+ else
+ Comp := Private_Component (Typ);
+
+ if not Is_Tagged_Type (Typ)
+ and then Present (Comp)
+ and then not Is_Frozen (Comp)
+ and then
+ not Is_Actual_For_Formal_Incomplete_Type (Comp)
+ then
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_Node_2 := Subp;
+ Error_Msg_Name_1 := Chars (Tagged_Type);
+ Error_Msg_NE
+ ("declaration must appear after completion of type &",
+ N, Comp);
+ Error_Msg_NE
+ ("\which is a component of untagged type& in the profile of"
+ & " primitive & of type % that is frozen by the declaration ",
+ N, Typ);
+ end if;
end if;
end Check_Premature_Freezing;
-- Calculate the number of slots of the dispatch table. If the number
-- of primitives of Typ is 0 we reserve a dummy single entry for its
- -- DT because at run-time the pointer to this dummy entry will be
+ -- DT because at run time the pointer to this dummy entry will be
-- used as the tag.
if Num_Iface_Prims = 0 then
else
declare
- Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
- Pos : Nat;
- Thunk_Code : Node_Id;
- Thunk_Id : Entity_Id;
+ CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+ E : Entity_Id;
+ Prim_Pos : Nat;
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ Thunk_Code : Node_Id;
+ Thunk_Id : Entity_Id;
begin
Prim_Table := (others => Empty);
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ Prim := Node (Prim_Elmt);
+ E := Ultimate_Alias (Prim);
+ Prim_Pos := UI_To_Int (DT_Position (E));
- -- Do not reference predefined primitives because they
- -- are located in a separate dispatch table; skip also
- -- abstract and eliminated primitives.
+ -- Do not reference predefined primitives because they are
+ -- located in a separate dispatch table; skip abstract and
+ -- eliminated primitives; skip primitives located in the C++
+ -- part of the dispatch table because their slot is set by
+ -- the IC routine.
if not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (Alias (Prim))
and then not Is_Eliminated (Alias (Prim))
+ and then (not Is_CPP_Class (Root_Type (Typ))
+ or else Prim_Pos > CPP_Nb_Prims)
and then Find_Dispatching_Type
(Interface_Alias (Prim)) = Iface
-- Generate the code of the thunk only if the abstract
-- interface type is not an immediate ancestor of
- -- Tagged_Type; otherwise the DT associated with the
+ -- Tagged_Type. Otherwise the DT associated with the
-- interface is the primary DT.
- and then not Is_Ancestor (Iface, Typ)
+ and then not Is_Ancestor (Iface, Typ,
+ Use_Full_View => True)
then
if not Build_Thunks then
- Pos :=
+ Prim_Pos :=
UI_To_Int (DT_Position (Interface_Alias (Prim)));
- Prim_Table (Pos) := Alias (Prim);
+ Prim_Table (Prim_Pos) := Alias (Prim);
+
else
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
- Pos :=
+ Prim_Pos :=
UI_To_Int (DT_Position (Interface_Alias (Prim)));
- Prim_Table (Pos) := Thunk_Id;
+ Prim_Table (Prim_Pos) := Thunk_Id;
Append_To (Result, Thunk_Code);
end if;
end if;
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
+
else
New_Node := Make_Null (Loc);
end if;
if Has_Dispatch_Table (Typ)
or else No (Access_Disp_Table (Typ))
or else Is_CPP_Class (Typ)
+ or else Convention (Typ) = Convention_CIL
+ or else Convention (Typ) = Convention_Java
then
return Result;
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 10 under configurable runtime or 16
+ -- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 16 then
+ if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
- if Max_Predef_Prims /= 10 then
+ if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
-- register the primitives in the slots will be generated later --- when
-- each primitive is frozen (see Freeze_Subprogram).
- if Building_Static_DT (Typ)
- and then not Is_CPP_Class (Typ)
- then
+ if Building_Static_DT (Typ) then
declare
Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
Prim : Entity_Id;
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- Frnodes := Freeze_Entity (Prim, Loc);
+ Frnodes := Freeze_Entity (Prim, Typ);
declare
F : Entity_Id;
begin
F := First_Formal (Prim);
while Present (F) loop
- Check_Premature_Freezing (Prim, Etype (F));
+ Check_Premature_Freezing (Prim, Typ, Etype (F));
Next_Formal (F);
end loop;
- Check_Premature_Freezing (Prim, Etype (Prim));
+ Check_Premature_Freezing (Prim, Typ, Etype (Prim));
end;
if Present (Frnodes) then
AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
-- Build the secondary table containing pointers to thunks
Build_Thunks => True,
Result => Result);
- -- Skip secondary dispatch table and secondary dispatch table of
- -- predefined primitives
+ -- Skip secondary dispatch table referencing thunks to predefined
+ -- primitives.
Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
+
+ -- Secondary dispatch table referencing user-defined primitives
+ -- covered by this interface.
+
Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
-- Build the secondary table containing pointers to primitives
-- (used to give support to Generic Dispatching Constructors).
Make_Secondary_DT
- (Typ => Typ,
- Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
- Suffix_Index => -1,
- Num_Iface_Prims => UI_To_Int
- (DT_Entry_Count (Node (AI_Tag_Comp))),
- Iface_DT_Ptr => Node (AI_Tag_Elmt),
- Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
- Build_Thunks => False,
- Result => Result);
+ (Typ => Typ,
+ Iface => Base_Type
+ (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => -1,
+ Num_Iface_Prims => UI_To_Int
+ (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Iface_DT_Ptr => Node (AI_Tag_Elmt),
+ Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
+ Build_Thunks => False,
+ Result => Result);
+
+ -- Skip secondary dispatch table referencing predefined primitives
- -- Skip secondary dispatch table and secondary dispatch table of
- -- predefined primitives
-
- Next_Elmt (AI_Tag_Elmt);
Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
Suffix_Index := Suffix_Index + 1;
+ Next_Elmt (AI_Tag_Elmt);
Next_Elmt (AI_Tag_Comp);
end loop;
end if;
- -- Get the _tag entity and the number of primitives of its dispatch
- -- table.
+ -- Get the _tag entity and number of primitives of its dispatch table
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
New_Reference_To
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
- -- Generate a SCIL node for the previous object declaration
- -- because it has a null dispatch table.
-
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
- end if;
-
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+
-- Generate the SCIL node for the previous object declaration
-- because it has a tag initialization.
if Generate_SCIL then
New_Node :=
Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
+ Set_SCIL_Node (Last (Result), New_Node);
end if;
-- Generate:
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
- -- Generate the SCIL node for the previous object declaration
- -- because it contains a dispatch table.
-
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
- end if;
-
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+
-- Generate the SCIL node for the previous object declaration
-- because it has a tag initialization.
if Generate_SCIL then
New_Node :=
Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
+ Set_SCIL_Node (Last (Result), New_Node);
end if;
Append_To (Result,
Object_Definition => New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Full_Qualified_Name (First_Subtype (Typ)))));
+ Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
- -- RC_Offset => <<integer-value>>,
- -- [ Size_Func => Size_Prim'Access ]
- -- [ Interfaces_Table => <<access-value>> ]
+ -- Type_Is_Abstract => <<boolean-value>>,
+ -- Needs_Finalization => <<boolean-value>>,
+ -- [ Size_Func => Size_Prim'Access, ]
+ -- [ Interfaces_Table => <<access-value>>, ]
-- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field.
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- Expanded_Name
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
+ Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address)));
-- External_Tag of a local tagged type
New_External_Name (Tname, 'A'));
Full_Name : constant String_Id :=
- Full_Qualified_Name (First_Subtype (Typ));
+ Fully_Qualified_Name_String (First_Subtype (Typ));
Str1_Id : String_Id;
Str2_Id : String_Id;
New_Occurrence_Of (Transportable, Loc));
end;
- -- RC_Offset: These are the valid values and their meaning:
+ -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
+ -- not available in the HIE runtime.
- -- >0: For simple types with controlled components is
- -- type._record_controller'position
+ if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
+ declare
+ Type_Is_Abstract : Entity_Id;
- -- 0: For types with no controlled components
+ begin
+ Type_Is_Abstract :=
+ Boolean_Literals (Is_Abstract_Type (Typ));
- -- -1: For complex types with controlled components where the position
- -- of the record controller is not statically computable but there
- -- are controlled components at this level. The _Controller field
- -- is available right after the _parent.
+ Append_To (TSD_Aggr_List,
+ New_Occurrence_Of (Type_Is_Abstract, Loc));
+ end;
+ end if;
- -- -2: There are no controlled components at this level. We need to
- -- get the position from the parent.
+ -- Needs_Finalization: Set if the type is controlled or has controlled
+ -- components.
declare
- RC_Offset_Node : Node_Id;
+ Needs_Fin : Entity_Id;
begin
- if not Has_Controlled_Component (Typ) then
- RC_Offset_Node := Make_Integer_Literal (Loc, 0);
-
- elsif Etype (Typ) /= Typ
- and then Has_Discriminants (Parent_Typ)
- then
- if Has_New_Controlled_Component (Typ) then
- RC_Offset_Node := Make_Integer_Literal (Loc, -1);
- else
- RC_Offset_Node := Make_Integer_Literal (Loc, -2);
- end if;
- else
- RC_Offset_Node :=
- 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 (RC_Offset_Node);
- Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
- Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
- Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
- RTE (RE_Record_Controller));
- Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
- end if;
-
- Append_To (TSD_Aggr_List, RC_Offset_Node);
+ Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
+ Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
end;
-- Size_Func
if RTE_Record_Component_Available (RE_Size_Func) then
- if not Building_Static_DT (Typ)
- or else Is_Interface (Typ)
- then
+
+ -- Initialize this field to Null_Address if we are not building
+ -- static dispatch tables static or if the size function is not
+ -- available. In the former case we cannot initialize this field
+ -- until the function is frozen and registered in the dispatch
+ -- table (see Register_Primitive).
+
+ if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Size_Ptr),
New_Reference_To (RTE (RE_Null_Address), Loc)));
declare
Prim_Elmt : Elmt_Id;
Prim : Entity_Id;
+ Size_Comp : Node_Id;
begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
Prim := Ultimate_Alias (Prim);
if Is_Abstract_Subprogram (Prim) then
- Append_To (TSD_Aggr_List,
+ Size_Comp :=
Unchecked_Convert_To (RTE (RE_Size_Ptr),
- New_Reference_To (RTE (RE_Null_Address), Loc)));
+ New_Reference_To (RTE (RE_Null_Address), Loc));
else
- Append_To (TSD_Aggr_List,
+ Size_Comp :=
Unchecked_Convert_To (RTE (RE_Size_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Unrestricted_Access)));
+ Attribute_Name => Name_Unrestricted_Access));
end if;
exit;
Next_Elmt (Prim_Elmt);
end loop;
+
+ pragma Assert (Present (Size_Comp));
+ Append_To (TSD_Aggr_List, Size_Comp);
end;
end if;
end if;
begin
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
- if Is_Ancestor (Node (AI), Typ) then
+ if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc);
else
(Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
pragma Assert (Has_Thunks (Node (Elmt)));
- while Ekind (Node (Elmt)) = E_Constant
+ while Is_Tag (Node (Elmt))
and then not
- Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
+ Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
+ Use_Full_View => True)
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
Is_Library_Level_Tagged_Type (Typ));
-- The table of interfaces is not constant; its slots are
- -- filled at run-time by the IP routine using attribute
+ -- filled at run time by the IP routine using attribute
-- 'Position to know the location of the tag components
-- (and this attribute cannot be safely used before the
-- object is initialized).
-- constrained by the number of non-predefined primitive operations.
if RTE_Record_Component_Available (RE_SSD) then
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Has_DT (Typ)
and then Is_Concurrent_Record_Type (Typ)
and then Has_Interfaces (Typ)
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
- -- Generate the SCIL node for the previous object declaration
- -- because it has a null dispatch table.
-
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
- end if;
-
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
else
declare
- Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
- E : Entity_Id;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
+ CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+ E : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Nat;
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
begin
Prim_Table := (others => Empty);
-- Retrieve the ultimate alias of the primitive for proper
-- handling of renamings and eliminated primitives.
- E := Ultimate_Alias (Prim);
+ E := Ultimate_Alias (Prim);
+ Prim_Pos := UI_To_Int (DT_Position (E));
-- Do not reference predefined primitives because they are
-- located in a separate dispatch table; skip entities with
-- attribute Interface_Alias because they are only required
- -- to build secondary dispatch tables; skip also abstract
- -- and eliminated primitives.
+ -- to build secondary dispatch tables; skip abstract and
+ -- eliminated primitives; for derivations of CPP types skip
+ -- primitives located in the C++ part of the dispatch table
+ -- because their slot is initialized by the IC routine.
if not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Operation (E)
and then not Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (E)
and then not Is_Eliminated (E)
+ and then (not Is_CPP_Class (Root_Type (Typ))
+ or else Prim_Pos > CPP_Nb_Prims)
then
pragma Assert
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
- -- Generate the SCIL node for the previous object declaration
- -- because it contains a dispatch table.
-
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
- end if;
-
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
end if;
end if;
+ -- If the type has a representation clause which specifies its external
+ -- tag then generate code to check if the external tag of this type is
+ -- the same as the external tag of some other declaration.
+
+ -- Check_TSD (TSD'Unrestricted_Access);
+
+ -- This check is a consequence of AI05-0113-1/06, so it officially
+ -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
+ -- a desirable check to add in Ada 95 mode, but we hesitate to make
+ -- this change, as it would be incompatible, and could conceivably
+ -- cause a problem in existing Aa 95 code.
+
+ -- We check for No_Run_Time_Mode here, because we do not want to pick
+ -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
+
+ if not No_Run_Time_Mode
+ and then Ada_Version >= Ada_2005
+ and then Has_External_Tag_Rep_Clause (Typ)
+ and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
+ then
+ Append_To (Elab_Code,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Unchecked_Access))));
+ end if;
+
-- Generate code to register the Tag in the External_Tag hash table for
-- the pure Ada type only.
-- a limited interface. Skip this step in Ravenscar profile or when
-- general dispatching is forbidden.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Concurrent_Record_Type (Typ)
and then Has_Interfaces (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
-- Mark entities containing dispatch tables. Required by the backend to
-- handle them properly.
- if not Is_Interface (Typ) then
+ if Has_DT (Typ) then
declare
Elmt : Elmt_Id;
return Result;
end Make_DT;
- -------------------------------------
- -- Make_Select_Specific_Data_Table --
- -------------------------------------
-
- 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);
-
- 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 : Nat := 0;
+ -----------------
+ -- Make_VM_TSD --
+ -----------------
- type Examined_Array is array (Int range <>) of Boolean;
+ function Make_VM_TSD (Typ : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Result : constant List_Id := New_List;
- 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.
+ function Count_Primitives (Typ : Entity_Id) return Nat;
+ -- Count the non-predefined primitive operations of Typ
----------------------
- -- Find_Entry_Index --
+ -- Count_Primitives --
----------------------
- function Find_Entry_Index (E : Entity_Id) return Uint is
- Index : Uint := Uint_1;
- Subp_Decl : Entity_Id;
+ function Count_Primitives (Typ : Entity_Id) return Nat is
+ Nb_Prim : Nat;
+ Prim_Elmt : Elmt_Id;
+ Prim : Entity_Id;
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;
-
- Index := Index + 1;
- end if;
+ Nb_Prim := 0;
- Next (Subp_Decl);
- end loop;
- end if;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- return Uint_0;
- end Find_Entry_Index;
+ if Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim)
+ then
+ null;
- -- Start of processing for Make_Select_Specific_Data_Table
+ elsif Present (Interface_Alias (Prim)) then
+ null;
- begin
- pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+ else
+ Nb_Prim := Nb_Prim + 1;
+ end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ Next_Elmt (Prim_Elmt);
+ end loop;
- if Present (Corresponding_Concurrent_Type (Typ)) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ return Nb_Prim;
+ end Count_Primitives;
- if Present (Full_View (Conc_Typ)) then
- Conc_Typ := Full_View (Conc_Typ);
- end if;
+ --------------
+ -- Make_OSD --
+ --------------
- 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;
+ function Make_OSD (Iface : Entity_Id) return Node_Id;
+ -- Generate the Object Specific Data table required to dispatch calls
+ -- through synchronized interfaces. Returns a node that references the
+ -- generated OSD object.
- -- Count the non-predefined primitive operations
+ function Make_OSD (Iface : Entity_Id) return Node_Id is
+ Nb_Prim : constant Nat := Count_Primitives (Iface);
+ OSD : Entity_Id;
+ OSD_Aggr_List : List_Id;
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ begin
+ -- Generate
+ -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
+ -- (OSD_Table => (1 => <value>,
+ -- ...
+ -- N => <value>));
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ if Nb_Prim = 0
+ or else Is_Abstract_Type (Typ)
+ or else Is_Controlled (Typ)
+ or else Restriction_Active (No_Dispatching_Calls)
+ or else not Is_Limited_Type (Typ)
+ or else not Has_Interfaces (Typ)
+ or else not RTE_Record_Component_Available (RE_OSD_Table)
then
- Nb_Prim := Nb_Prim + 1;
- end if;
+ -- No OSD table required
- Next_Elmt (Prim_Elmt);
- end loop;
+ return Make_Null (Loc);
- declare
- Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
+ else
+ OSD_Aggr_List := New_List;
- begin
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ Prim : Entity_Id;
+ Prim_Alias : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ E : Entity_Id;
+ Count : Nat := 0;
+ Pos : Nat;
- -- Look for primitive overriding an abstract interface subprogram
+ begin
+ Prim_Table := (others => Empty);
+ Prim_Alias := Empty;
- if Present (Interface_Alias (Prim))
- and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
- then
- Prim_Pos := DT_Position (Alias (Prim));
- pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
- Examined (UI_To_Int (Prim_Pos)) := True;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Present (Interface_Alias (Prim))
+ and then Find_Dispatching_Type
+ (Interface_Alias (Prim)) = Iface
+ then
+ Prim_Alias := Interface_Alias (Prim);
+ E := Ultimate_Alias (Prim);
+ Pos := UI_To_Int (DT_Position (Prim_Alias));
+
+ if Present (Prim_Table (Pos)) then
+ pragma Assert (Prim_Table (Pos) = E);
+ null;
+
+ else
+ Prim_Table (Pos) := E;
+
+ Append_To (OSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc,
+ DT_Position (Prim_Alias))),
+ Expression =>
+ Make_Integer_Literal (Loc,
+ DT_Position (Alias (Prim)))));
+
+ Count := Count + 1;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ pragma Assert (Count = Nb_Prim);
+ end;
+
+ OSD := Make_Temporary (Loc, 'I');
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => OSD,
+ Aliased_Present => True,
+ Constant_Present => True,
+ 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)))),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
+ Expression =>
+ Make_Integer_Literal (Loc, Nb_Prim)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_OSD_Table), Loc)),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => OSD_Aggr_List))))));
+
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (OSD, Loc),
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
+ end Make_OSD;
+
+ -- Local variables
+
+ Nb_Prim : constant Nat := Count_Primitives (Typ);
+ AI : Elmt_Id;
+ I_Depth : Nat;
+ Iface_Table_Node : Node_Id;
+ Num_Ifaces : Nat;
+ TSD_Aggr_List : List_Id;
+ Typ_Ifaces : Elist_Id;
+ TSD_Tags_List : List_Id;
+
+ Tname : constant Name_Id := Chars (Typ);
+ Name_SSD : constant Name_Id :=
+ New_External_Name (Tname, 'S', Suffix_Index => -1);
+ Name_TSD : constant Name_Id :=
+ New_External_Name (Tname, 'B', Suffix_Index => -1);
+ SSD : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_SSD);
+ TSD : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_TSD);
+ begin
+ -- 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.ads).
+
+ -- TSD : Type_Specific_Data (I_Depth) :=
+ -- (Idepth => I_Depth,
+ -- Tag_Kind => <tag_kind-value>,
+ -- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
+ -- HT_Link => null,
+ -- Type_Is_Abstract => <<boolean-value>>,
+ -- Type_Is_Library_Level => <<boolean-value>>,
+ -- Interfaces_Table => <<access-value>>
+ -- SSD => SSD_Table'Address
+ -- Tags_Table => (0 => Typ'Tag,
+ -- 1 => Parent'Tag
+ -- ...));
+
+ TSD_Aggr_List := New_List;
+
+ -- Idepth: Count ancestors to compute the inheritance depth. For private
+ -- extensions, always go to the full view in order to compute the real
+ -- inheritance depth.
+
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+
+ begin
+ I_Depth := 0;
+ Current_Typ := Typ;
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ exit when Parent_Typ = Current_Typ;
+
+ I_Depth := I_Depth + 1;
+ Current_Typ := Parent_Typ;
+ end loop;
+ end;
+
+ -- I_Depth
+
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, I_Depth));
+
+ -- Tag_Kind
+
+ Append_To (TSD_Aggr_List, Tagged_Kind (Typ));
+
+ -- Access_Level
+
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field. Why not???
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
+ -- HT_Link
+
+ Append_To (TSD_Aggr_List,
+ Make_Null (Loc));
+
+ -- Type_Is_Abstract (Ada 2012: AI05-0173)
+
+ declare
+ Type_Is_Abstract : Entity_Id;
+
+ begin
+ Type_Is_Abstract :=
+ Boolean_Literals (Is_Abstract_Type (Typ));
+
+ Append_To (TSD_Aggr_List,
+ New_Occurrence_Of (Type_Is_Abstract, Loc));
+ end;
+
+ -- Type_Is_Library_Level
+
+ declare
+ Type_Is_Library_Level : Entity_Id;
+ begin
+ Type_Is_Library_Level :=
+ Boolean_Literals (Is_Library_Level_Entity (Typ));
+ Append_To (TSD_Aggr_List,
+ New_Occurrence_Of (Type_Is_Library_Level, Loc));
+ end;
+
+ -- Interfaces_Table (required for AI-405)
+
+ if RTE_Record_Component_Available (RE_Interfaces_Table) then
+
+ -- Count the number of interface types implemented by Typ
+
+ Collect_Interfaces (Typ, Typ_Ifaces);
+
+ Num_Ifaces := 0;
+ AI := First_Elmt (Typ_Ifaces);
+ while Present (AI) loop
+ Num_Ifaces := Num_Ifaces + 1;
+ Next_Elmt (AI);
+ end loop;
+
+ if Num_Ifaces = 0 then
+ Iface_Table_Node := Make_Null (Loc);
+
+ -- Generate the Interface_Table object
+
+ else
+ declare
+ TSD_Ifaces_List : constant List_Id := New_List;
+ Iface : Entity_Id;
+ ITable : Node_Id;
+
+ begin
+ AI := First_Elmt (Typ_Ifaces);
+ while Present (AI) loop
+ Iface := Node (AI);
+
+ Append_To (TSD_Ifaces_List,
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+
+ -- Iface_Tag
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface, Loc),
+ Attribute_Name => Name_Tag),
+
+ -- OSD
+
+ Make_OSD (Iface))));
+
+ Next_Elmt (AI);
+ end loop;
+
+ ITable := Make_Temporary (Loc, 'I');
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => ITable,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Interface_Data), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint
+ (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces)))),
+
+ Expression => Make_Aggregate (Loc,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces),
+ Make_Aggregate (Loc,
+ Expressions => TSD_Ifaces_List)))));
+
+ Iface_Table_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (ITable, Loc),
+ Attribute_Name => Name_Unchecked_Access);
+ end;
+ end if;
+
+ Append_To (TSD_Aggr_List, Iface_Table_Node);
+ end if;
+
+ -- Generate the Select Specific Data table for synchronized types that
+ -- implement synchronized interfaces. The size of the table is
+ -- constrained by the number of non-predefined primitive operations.
+
+ if RTE_Record_Component_Available (RE_SSD) then
+ if Ada_Version >= Ada_2005
+ and then Has_DT (Typ)
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then Nb_Prim > 0
+ and then not Is_Abstract_Type (Typ)
+ and then not Is_Controlled (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ 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))))));
+
+ -- This table is initialized by Make_Select_Specific_Data_Table,
+ -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
+
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+ else
+ Append_To (TSD_Aggr_List, Make_Null (Loc));
+ end if;
+ end if;
+
+ -- Initialize the table of ancestor tags. In case of interface types
+ -- this table is not needed.
+
+ TSD_Tags_List := New_List;
+
+ -- Fill position 0 with Typ'Tag
+
+ Append_To (TSD_Tags_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag));
+
+ -- Fill the rest of the table with the tags of the ancestors
+
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+ Pos : Nat;
+
+ begin
+ Pos := 1;
+ Current_Typ := Typ;
+
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ exit when Parent_Typ = Current_Typ;
+
+ Append_To (TSD_Tags_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Parent_Typ, Loc),
+ Attribute_Name => Name_Tag));
+
+ Pos := Pos + 1;
+ Current_Typ := Parent_Typ;
+ end loop;
+
+ pragma Assert (Pos = I_Depth + 1);
+ end;
+
+ Append_To (TSD_Aggr_List,
+ Make_Aggregate (Loc,
+ Expressions => TSD_Tags_List));
+
+ -- Build the TSD object
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => TSD,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Type_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, I_Depth)))),
+
+ Expression => Make_Aggregate (Loc,
+ Expressions => TSD_Aggr_List)));
+
+ -- Generate:
+ -- Check_TSD
+ -- (TSD => TSD'Unrestricted_Access);
+
+ if Ada_Version >= Ada_2005
+ and then Is_Library_Level_Entity (Typ)
+ and then Has_External_Tag_Rep_Clause (Typ)
+ and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
+ then
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
+
+ -- Generate:
+ -- Register_TSD (TSD'Unrestricted_Access);
+
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Register_TSD), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+
+ -- Populate the two auxiliary tables used for dispatching asynchronous,
+ -- conditional and timed selects for synchronized types that implement
+ -- a limited interface. Skip this step in Ravenscar profile or when
+ -- general dispatching is forbidden.
+
+ if Ada_Version >= Ada_2005
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ Append_List_To (Result,
+ Make_Select_Specific_Data_Table (Typ));
+ end if;
+
+ return Result;
+ end Make_VM_TSD;
+
+ -------------------------------------
+ -- Make_Select_Specific_Data_Table --
+ -------------------------------------
+
+ 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);
+
+ Conc_Typ : Entity_Id;
+ Decls : List_Id;
+ Prim : Entity_Id;
+ Prim_Als : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Uint;
+ Nb_Prim : Nat := 0;
+
+ type Examined_Array is array (Int range <>) of Boolean;
+
+ 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.
+
+ ----------------------
+ -- Find_Entry_Index --
+ ----------------------
+
+ function Find_Entry_Index (E : Entity_Id) return Uint is
+ Index : Uint := Uint_1;
+ Subp_Decl : Entity_Id;
+
+ 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;
+
+ Index := Index + 1;
+ end if;
+
+ Next (Subp_Decl);
+ end loop;
+ end if;
+
+ return Uint_0;
+ end Find_Entry_Index;
+
+ -- Local variables
+
+ Tag_Node : Node_Id;
+
+ -- Start of processing for Make_Select_Specific_Data_Table
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ if Present (Corresponding_Concurrent_Type (Typ)) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ if Present (Full_View (Conc_Typ)) then
+ Conc_Typ := Full_View (Conc_Typ);
+ end if;
+
+ 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;
+
+ -- Count the non-predefined primitive operations
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Nb_Prim := Nb_Prim + 1;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ declare
+ Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Look for primitive overriding an abstract interface subprogram
+
+ if Present (Interface_Alias (Prim))
+ and then not
+ Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
+ and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
+ then
+ Prim_Pos := DT_Position (Alias (Prim));
+ pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
+ Examined (UI_To_Int (Prim_Pos)) := True;
-- Set the primitive operation kind regardless of subprogram
-- type. Generate:
-- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Assignments,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
+ Tag_Node,
Make_Integer_Literal (Loc, Prim_Pos),
Prim_Op_Kind (Alias (Prim), Typ))));
-- Ada.Tags.Set_Entry_Index
-- (DT_Ptr, <position>, <index>);
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Assignments,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
+ Tag_Node,
Make_Integer_Literal (Loc, Prim_Pos),
Make_Integer_Literal (Loc,
Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
-- Import the dispatch table DT of tagged type Tag_Typ. Required to
-- generate forward references and statically allocate the table. For
-- primary dispatch tables that require no dispatch table generate:
+
-- DT : static aliased constant Non_Dispatch_Table_Wrapper;
- -- $pragma import (ada, DT);
+ -- pragma Import (Ada, DT);
+
-- Otherwise generate:
+
-- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
- -- $pragma import (ada, DT);
+ -- pragma Import (Ada, DT);
---------------
-- Import_DT --
Get_External_Name (DT, True);
Set_Interface_Name (DT,
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
+ Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
-- Ensure proper Sprint output of this implicit importation
-- No dispatch table required
- if not Is_Secondary_DT
- and then not Has_DT (Tag_Typ)
- then
+ if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Nb_Prim :=
UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
- -- If the tagged type has no primitives we add a dummy slot
- -- whose address will be the tag of this type.
+ -- If the tagged type has no primitives we add a dummy slot whose
+ -- address will be the tag of this type.
if Nb_Prim = 0 then
DT_Constr_List :=
-- Start of processing for Make_Tags
begin
- -- 1) Generate the primary and secondary tag entities
-
- -- Collect the components associated with secondary dispatch tables
-
- if Has_Interfaces (Typ) then
- Collect_Interface_Components (Typ, Typ_Comps);
- end if;
+ pragma Assert (No (Access_Disp_Table (Typ)));
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
-- 1) Generate the primary tag entities
-- Primary dispatch table containing user-defined primitives
- DT_Ptr := Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'P'));
- Set_Etype (DT_Ptr, RTE (RE_Tag));
-
- -- Primary dispatch table containing predefined primitives
-
- Predef_Prims_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'Y'));
- Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-
- -- Import the forward declaration of the Dispatch Table wrapper record
- -- (Make_DT will take care of its exportation)
+ DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
+ Set_Etype (DT_Ptr, RTE (RE_Tag));
+ Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- if Building_Static_DT (Typ) then
- Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+ -- Minimum decoration
- DT :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'T'));
+ Set_Ekind (DT_Ptr, E_Variable);
+ Set_Related_Type (DT_Ptr, Typ);
- Import_DT (Typ, DT, Is_Secondary_DT => False);
+ -- For CPP types there is no need to build the dispatch tables since
+ -- they are imported from the C++ side. If the CPP type has an IP then
+ -- we declare now the variable that will store the copy of the C++ tag.
+ -- If the CPP type is an interface, we need the variable as well because
+ -- it becomes the pointer to the corresponding secondary table.
- if Has_DT (Typ) then
+ if Is_CPP_Class (Typ) then
+ if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
- Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
- -- Generate the SCIL node for the previous object declaration
- -- because it has a tag initialization.
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ end if;
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
- end if;
+ -- Ada types
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Predef_Prims_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To
- (RTE (RE_Address), Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
- Attribute_Name => Name_Address)));
+ else
+ -- Primary dispatch table containing predefined primitives
- -- No dispatch table required
+ Predef_Prims_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'Y'));
+ Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+ Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
- else
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
+ -- Import the forward declaration of the Dispatch Table wrapper
+ -- record (Make_DT will take care of exporting it).
+
+ if Building_Static_DT (Typ) then
+ Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+
+ DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'T'));
+
+ Import_DT (Typ, DT, Is_Secondary_DT => False);
+
+ if Has_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Entity (New_Node, Typ);
+ Set_SCIL_Node (Last (Result), New_Node);
+ end if;
- -- Generate the SCIL node for the previous object declaration
- -- because it has a tag initialization.
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims_Ptr,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Attribute_Name => Name_Address)));
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
- Set_SCIL_Related_Node (New_Node, Last (Result));
- Set_SCIL_Entity (New_Node, Typ);
- Insert_Before (Last (Result), New_Node);
+ -- No dispatch table required
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr),
+ Loc)),
+ Attribute_Name => Name_Address))));
end if;
- end if;
- Set_Is_True_Constant (DT_Ptr);
- Set_Is_Statically_Allocated (DT_Ptr);
+ Set_Is_True_Constant (DT_Ptr);
+ Set_Is_Statically_Allocated (DT_Ptr);
+ end if;
end if;
- pragma Assert (No (Access_Disp_Table (Typ)));
- Set_Access_Disp_Table (Typ, New_Elmt_List);
- Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
-
-- 2) Generate the secondary tag entities
+ -- Collect the components associated with secondary dispatch tables
+
if Has_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
- -- Note: The following value of Suffix_Index must be in sync with
- -- the Suffix_Index values of secondary dispatch tables generated
- -- by Make_DT.
+ -- For each interface type we build a unique external name associated
+ -- with its secondary dispatch table. This name is used to declare an
+ -- object that references this secondary dispatch table, whose value
+ -- will be used for the elaboration of Typ objects, and also for the
+ -- elaboration of objects of types derived from Typ that do not
+ -- override the primitives of this interface type.
Suffix_Index := 1;
- -- For each interface type we build an unique external name
- -- associated with its corresponding secondary dispatch table.
- -- This external name will be used to declare an object that
- -- references this secondary dispatch table, value that will be
- -- used for the elaboration of Typ's objects and also for the
- -- elaboration of objects of derivations of Typ that do not
- -- override the primitive operation of this interface type.
+ -- Note: The value of Suffix_Index must be in sync with the
+ -- Suffix_Index values of secondary dispatch tables generated
+ -- by Make_DT.
- AI_Tag_Comp := First_Elmt (Typ_Comps);
- while Present (AI_Tag_Comp) loop
- Get_Secondary_DT_External_Name
- (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
- Typ_Name := Name_Find;
+ if Is_CPP_Class (Typ) then
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Get_Secondary_DT_External_Name
+ (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+ Typ_Name := Name_Find;
- if Building_Static_DT (Typ) then
- Iface_DT :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name
- (Typ_Name, 'T', Suffix_Index => -1));
- Import_DT
- (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
- DT => Iface_DT,
- Is_Secondary_DT => True);
- end if;
+ -- Declare variables that will store the copy of the C++
+ -- secondary tags.
- -- Secondary dispatch table referencing thunks to user-defined
- -- primitives covered by this interface.
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'P'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Set_Is_Tag (Iface_DT_Ptr);
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'P'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Has_Thunks (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
- if Building_Static_DT (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT_Ptr,
- Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Interface_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
- end if;
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
- -- Secondary dispatch table referencing thunks to predefined
- -- primitives.
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'Y'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Has_Thunks (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
- -- Secondary dispatch table referencing user-defined primitives
- -- covered by this interface.
+ -- This is not a CPP_Class type
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'D'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ else
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Get_Secondary_DT_External_Name
+ (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+ Typ_Name := Name_Find;
- -- Secondary dispatch table referencing predefined primitives
+ if Building_Static_DT (Typ) then
+ Iface_DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name
+ (Typ_Name, 'T', Suffix_Index => -1));
+ Import_DT
+ (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+ DT => Iface_DT,
+ Is_Secondary_DT => True);
+ end if;
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'Z'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ -- Secondary dispatch table referencing thunks to user-defined
+ -- primitives covered by this interface.
- Next_Elmt (AI_Tag_Comp);
- end loop;
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'P'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ if Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Interface_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr),
+ Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+
+ -- Secondary dispatch table referencing thunks to predefined
+ -- primitives.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Y'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing user-defined primitives
+ -- covered by this interface.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'D'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing predefined primitives
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Z'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
end if;
-- 3) At the end of Access_Disp_Table, if the type has user-defined
-- to simplify the expansion associated with dispatching calls.
Analyze_List (Result);
- Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+ Set_Suppress_Initialization (Base_Type (DT_Prims));
+
+ -- Disable backend optimizations based on assumptions about the
+ -- aliasing status of objects designated by the access to the
+ -- dispatch table. Required to handle dispatch tables imported
+ -- from C++.
+
+ Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
+
+ -- Add the freezing nodes of these declarations; required to avoid
+ -- generating these freezing nodes in wrong scopes (for example in
+ -- the IC routine of a derivation of Typ).
+ -- What is an "IC routine"? Is "init_proc" meant here???
+
+ Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
+ Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
-- Mark entity of dispatch table. Required by the back end to
-- handle them properly.
end;
end if;
- -- Mark entities of dispatch table. Required by the back end to
- -- handle them properly.
+ -- Mark entities of dispatch table. Required by the back end to handle
+ -- them properly.
if Present (DT) then
Set_Is_Dispatch_Table_Entity (DT);
Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
end if;
- Set_Ekind (DT_Ptr, E_Constant);
+ if Is_CPP_Class (Root_Type (Typ)) then
+ Set_Ekind (DT_Ptr, E_Variable);
+ else
+ Set_Ekind (DT_Ptr, E_Constant);
+ end if;
+
Set_Is_Tag (DT_Ptr);
Set_Related_Type (DT_Ptr, Typ);
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+ pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Register copy of the pointer to the 'size primitive in the TSD
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Append_To (L,
- Build_Set_Prim_Op_Address (Loc,
- Typ => Tag_Typ,
- Tag_Node => New_Reference_To (DT_Ptr, Loc),
- Position => Pos,
- Address_Node =>
- Unchecked_Convert_To (RTE (RE_Prim_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Unrestricted_Access))));
+ -- Skip registration of primitives located in the C++ part of the
+ -- dispatch table. Their slot is set by the IC routine.
+
+ if not Is_CPP_Class (Root_Type (Tag_Typ))
+ or else Pos > CPP_Num_Prims (Tag_Typ)
+ then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+ Append_To (L,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Tag_Typ,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
end if;
-- Ada 2005 (AI-251): Primitive associated with an interface type
pragma Assert (Is_Interface (Iface_Typ));
+ -- No action needed for interfaces that are ancestors of Typ because
+ -- their primitives are located in the primary dispatch table.
+
+ if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
+ return L;
+
+ -- No action needed for primitives located in the C++ part of the
+ -- dispatch table. Their slot is set by the IC routine.
+
+ elsif Is_CPP_Class (Root_Type (Tag_Typ))
+ and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
+ and then not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Alias (Prim)
+ then
+ return L;
+ end if;
+
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
- if not Is_Ancestor (Iface_Typ, Tag_Typ)
+ if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
and then Present (Thunk_Code)
then
-- Generate the code necessary to fill the appropriate entry of
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
else
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
procedure Set_All_DT_Position (Typ : Entity_Id) is
+ function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
+ -- Returns True if Prim is located in the dispatch table of
+ -- predefined primitives
+
procedure Validate_Position (Prim : Entity_Id);
-- Check that the position assigned to Prim is completely safe
-- (it has not been assigned to a previously defined primitive
-- operation of Typ)
+ ------------------------
+ -- In_Predef_Prims_DT --
+ ------------------------
+
+ function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ -- Predefined primitives
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return True;
+
+ -- Renamings of predefined primitives
+
+ elsif Present (Alias (Prim))
+ and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
+ then
+ if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
+ return True;
+
+ -- User-defined renamings of predefined equality have their own
+ -- slot in the primary dispatch table
+
+ else
+ E := Prim;
+ while Present (Alias (E)) loop
+ if Comes_From_Source (E) then
+ return False;
+ end if;
+
+ E := Alias (E);
+ end loop;
+
+ return not Comes_From_Source (E);
+ end if;
+
+ -- User-defined primitives
+
+ else
+ return False;
+ end if;
+ end In_Predef_Prims_DT;
+
-----------------------
-- Validate_Position --
-----------------------
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
- Adjusted : Boolean := False;
- Finalized : Boolean := False;
+ Adjusted : Boolean := False;
+ Finalized : Boolean := False;
Count_Prim : Nat;
DT_Length : Nat;
-- Predefined primitives have a separate dispatch table
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else
- Is_Predefined_Dispatching_Alias (Prim))
- then
+ if not In_Predef_Prims_DT (Prim) then
Count_Prim := Count_Prim + 1;
end if;
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration
and then Is_Generic_Type (Typ)))
and then In_Open_Scopes (Scope (Etype (Typ)))
- and then Typ = Base_Type (Typ)
+ and then Is_Base_Type (Typ)
then
Handle_Inherited_Private_Subprograms (Typ);
end if;
-- Predefined primitives have a separate table and all its
-- entries are at predefined fixed positions.
- if Is_Predefined_Dispatching_Operation (Prim) then
- Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
+ if In_Predef_Prims_DT (Prim) then
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- elsif Is_Predefined_Dispatching_Alias (Prim) then
- Set_DT_Position (Prim,
- Default_Prim_Op_Position (Ultimate_Alias (Prim)));
+ else pragma Assert (Present (Alias (Prim)));
+ Set_DT_Position (Prim,
+ Default_Prim_Op_Position (Ultimate_Alias (Prim)));
+ end if;
-- Overriding primitives of ancestor abstract interfaces
elsif Present (Interface_Alias (Prim))
and then Is_Ancestor
- (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
then
pragma Assert (DT_Position (Prim) = No_Uint
and then Present (DTC_Entity (Interface_Alias (Prim))));
and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Ancestor
- (Find_Dispatching_Type (Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Alias (Prim)), Typ,
+ Use_Full_View => True)
and then Present (DTC_Entity (Alias (Prim)))
then
E := Alias (Prim);
Next_Elmt (Prim_Elmt);
end loop;
- -- Third stage: Fix the position of all the new primitives
+ -- Third stage: Fix the position of all the new primitives.
-- Entries associated with primitives covering interfaces
-- are handled in a latter round.
-- Check if this entry will be placed in the primary DT
if Is_Ancestor
- (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+ Use_Full_View => True)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
-- Calculate real size of the dispatch table
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ if not In_Predef_Prims_DT (Prim)
and then UI_To_Int (DT_Position (Prim)) > DT_Length
then
DT_Length := UI_To_Int (DT_Position (Prim));
-- Ensure that the assigned position to non-predefined
-- dispatching operations in the dispatch table is correct.
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Alias (Prim)
then
Validate_Position (Prim);
end if;
-- excluded from this check because interfaces must be visible in
-- the public and private part (RM 7.3 (7.3/2))
- if Is_Abstract_Type (Typ)
+ -- We disable this check in CodePeer mode, to accommodate legacy
+ -- Ada code.
+
+ if not CodePeer_Mode
+ and then Is_Abstract_Type (Typ)
and then Is_Abstract_Subprogram (Prim)
and then Present (Alias (Prim))
and then not Is_Interface
--------------------------
procedure Set_CPP_Constructors (Typ : Entity_Id) is
+
+ procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
+ -- For backward compatibility this routine handles CPP constructors
+ -- of non-tagged types.
+
+ procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
+ Loc : Source_Ptr;
+ Init : Entity_Id;
+ E : Entity_Id;
+ Found : Boolean := False;
+ P : Node_Id;
+ Parms : List_Id;
+
+ begin
+ -- Look for the constructor entities
+
+ E := Next_Entity (Typ);
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ -- Create the init procedure
+
+ Found := True;
+ Loc := Sloc (E);
+ Init := Make_Defining_Identifier (Loc,
+ Make_Init_Proc_Name (Typ));
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Discard_Node (
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Init,
+ Parameter_Specifications => Parms)));
+
+ Set_Init_Proc (Typ, Init);
+ Set_Is_Imported (Init);
+ Set_Is_Constructor (Init);
+ Set_Interface_Name (Init, Interface_Name (E));
+ Set_Convention (Init, Convention_CPP);
+ Set_Is_Public (Init);
+ Set_Has_Completion (Init);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- If there are no constructors, mark the type as abstract since we
+ -- won't be able to declare objects of that type.
+
+ if not Found then
+ Set_Is_Abstract_Type (Typ);
+ end if;
+ end Set_CPP_Constructors_Old;
+
+ -- Local variables
+
Loc : Source_Ptr;
- Init : Entity_Id;
E : Entity_Id;
Found : Boolean := False;
P : Node_Id;
Parms : List_Id;
+ Constructor_Decl_Node : Node_Id;
+ Constructor_Id : Entity_Id;
+ Wrapper_Id : Entity_Id;
+ Wrapper_Body_Node : Node_Id;
+ Actuals : List_Id;
+ Body_Stmts : List_Id;
+ Init_Tags_List : List_Id;
+
begin
+ pragma Assert (Is_CPP_Class (Typ));
+
+ -- For backward compatibility the compiler accepts C++ classes
+ -- imported through non-tagged record types. In such case the
+ -- wrapper of the C++ constructor is useless because the _tag
+ -- component is not available.
+
+ -- Example:
+ -- type Root is limited record ...
+ -- pragma Import (CPP, Root);
+ -- function New_Root return Root;
+ -- pragma CPP_Constructor (New_Root, ... );
+
+ if not Is_Tagged_Type (Typ) then
+ Set_CPP_Constructors_Old (Typ);
+ return;
+ end if;
+
-- Look for the constructor entities
E := Next_Entity (Typ);
if Ekind (E) = E_Function
and then Is_Constructor (E)
then
- -- Create the init procedure
-
Found := True;
Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+
+ -- Generate the declaration of the imported C++ constructor
+
Parms :=
New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_X),
+ Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type =>
New_Reference_To (Typ, Loc)));
end loop;
end if;
- Discard_Node (
+ Constructor_Id := Make_Temporary (Loc, 'P');
+
+ Constructor_Decl_Node :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Init,
- Parameter_Specifications => Parms)));
-
- Set_Init_Proc (Typ, Init);
- Set_Is_Imported (Init);
- Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
- Set_Is_Public (Init);
- Set_Has_Completion (Init);
+ Defining_Unit_Name => Constructor_Id,
+ Parameter_Specifications => Parms));
+
+ Set_Is_Imported (Constructor_Id);
+ Set_Is_Constructor (Constructor_Id);
+ Set_Interface_Name (Constructor_Id, Interface_Name (E));
+ Set_Convention (Constructor_Id, Convention_CPP);
+ Set_Is_Public (Constructor_Id);
+ Set_Has_Completion (Constructor_Id);
+
+ -- Build the wrapper of this constructor
+
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uInit),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Body_Stmts := New_List;
+
+ -- Invoke the C++ constructor
+
+ Actuals := New_List;
+
+ P := First (Parms);
+ while Present (P) loop
+ Append_To (Actuals,
+ New_Reference_To (Defining_Identifier (P), Loc));
+ Next (P);
+ end loop;
+
+ Append_To (Body_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Constructor_Id, Loc),
+ Parameter_Associations => Actuals));
+
+ -- Initialize copies of C++ primary and secondary tags
+
+ Init_Tags_List := New_List;
+
+ declare
+ Tag_Elmt : Elmt_Id;
+ Tag_Comp : Node_Id;
+
+ begin
+ Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
+ Tag_Comp := First_Tag_Component (Typ);
+
+ while Present (Tag_Elmt)
+ and then Is_Tag (Node (Tag_Elmt))
+ loop
+ -- Skip the following assertion with primary tags because
+ -- Related_Type is not set on primary tag components
+
+ pragma Assert (Tag_Comp = First_Tag_Component (Typ)
+ or else Related_Type (Node (Tag_Elmt))
+ = Related_Type (Tag_Comp));
+
+ Append_To (Init_Tags_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Node (Tag_Elmt), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc))));
+
+ Tag_Comp := Next_Tag_Component (Tag_Comp);
+ Next_Elmt (Tag_Elmt);
+ end loop;
+ end;
+
+ Append_To (Body_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))),
+ Loc),
+ Right_Opnd =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))),
+ Then_Statements => Init_Tags_List));
+
+ Wrapper_Id := Make_Defining_Identifier (Loc,
+ Make_Init_Proc_Name (Typ));
+
+ Wrapper_Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => Parms),
+ Declarations => New_List (Constructor_Decl_Node),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts,
+ Exception_Handlers => No_List));
+
+ Discard_Node (Wrapper_Body_Node);
+ Set_Init_Proc (Typ, Wrapper_Id);
end if;
Next_Entity (E);
if not Found then
Set_Is_Abstract_Type (Typ);
end if;
+
+ -- If the CPP type has constructors then it must import also the default
+ -- C++ constructor. It is required for default initialization of objects
+ -- of the type. It is also required to elaborate objects of Ada types
+ -- that are defined as derivations of this CPP type.
+
+ if Has_CPP_Constructors (Typ)
+ and then No (Init_Proc (Typ))
+ then
+ Error_Msg_N ("?default constructor must be imported from C++", Typ);
+ end if;
end Set_CPP_Constructors;
--------------------------
Write_Str ("(predefined) ");
end if;
+ -- Prefix the name of the primitive with its corresponding tagged
+ -- type to facilitate seeing inherited primitives.
+
+ if Present (Alias (Prim)) then
+ Write_Name
+ (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
+ else
+ Write_Name (Chars (Typ));
+ end if;
+
+ Write_Str (".");
Write_Name (Chars (Prim));
-- Indicate if this primitive has an aliased primitive
Write_Int (Int (Alias (Prim)));
-- If the DTC_Entity attribute is already set we can also output
- -- the name of the interface covered by this primitive (if any)
+ -- the name of the interface covered by this primitive (if any).
if Present (DTC_Entity (Alias (Prim)))
and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
+
+ if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
+ Write_Str ("null primitive ");
+ end if;
+
Write_Name
(Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');
Write_Str (" (eliminated)");
end if;
+ if Is_Imported (Prim)
+ and then Convention (Prim) = Convention_CPP
+ then
+ Write_Str (" (C++)");
+ end if;
+
Write_Eol;
Next_Elmt (Elmt);
OSDN Git Service
