Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
- ADT : Elmt_Id;
- Aux_N : Node_Id;
- Aux_Comp : Node_Id;
-
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
-- Build a assignment statement node which assigns to record
-- component its default expression if defined. The left hand side
Record_Extension_Node : Node_Id;
Init_Tag : Node_Id;
+ procedure Init_Secondary_Tags (Typ : Entity_Id);
+ -- Ada 2005 (AI-251): Initialize the tags of all the secondary
+ -- tables associated with abstract interface types
+
+ -------------------------
+ -- Init_Secondary_Tags --
+ -------------------------
+
+ procedure Init_Secondary_Tags (Typ : Entity_Id) is
+ ADT : Elmt_Id;
+
+ procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the root type
+
+ ----------------------------------
+ -- Init_Secondary_Tags_Internal --
+ ----------------------------------
+
+ procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
+ E : Entity_Id;
+ Aux_N : Node_Id;
+
+ begin
+ if not Is_Interface (Typ)
+ and then Etype (Typ) /= Typ
+ then
+ Init_Secondary_Tags_Internal (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+ while Present (E) loop
+ if Is_Tag (E)
+ and then Chars (E) /= Name_uTag
+ then
+ Aux_N := Node (ADT);
+ pragma Assert (Present (Aux_N));
+
+ -- Initialize the pointer to the secondary DT
+ -- associated with the interface
+
+ Append_To (Body_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To (E, Loc)),
+ Expression =>
+ New_Reference_To (Aux_N, Loc)));
+
+ -- Generate:
+ -- Set_Offset_To_Top (DT_Ptr, n);
+
+ Append_To (Body_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Set_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Aux_N, Loc)),
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc,
+ Name_uInit),
+ Selector_Name => New_Reference_To
+ (E, Loc)),
+ Attribute_Name => Name_Position)))));
+
+ Next_Elmt (ADT);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Init_Secondary_Tags_Internal;
+
+ -- Start of processing for Init_Secondary_Tags
+
+ begin
+ -- Skip the first _Tag, which is the main tag of the
+ -- tagged type. Following tags correspond with abstract
+ -- interfaces.
+
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ Init_Secondary_Tags_Internal (Typ);
+ end Init_Secondary_Tags;
+
+ -- Start of processing for Build_Init_Procedure
+
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
-- Ada 2005 (AI-251): Initialization of all the tags
-- corresponding with abstract interfaces
- if Present (First_Tag_Component (Rec_Type)) then
-
- -- Skip the first _Tag, which is the main tag of the
- -- tagged type. Following tags correspond with abstract
- -- interfaces.
-
- Aux_Comp :=
- Next_Tag_Component (First_Tag_Component (Rec_Type));
-
- ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
- while Present (ADT) loop
- Aux_N := Node (ADT);
-
- -- Initialize the pointer to the secondary DT associated
- -- with the interface
-
- Append_To (Body_Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Reference_To (Aux_Comp, Loc)),
- Expression =>
- New_Reference_To (Aux_N, Loc)));
-
- -- Generate:
- -- Set_Offset_To_Top (DT_Ptr, n);
-
- Append_To (Body_Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Offset_To_Top),
- Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Aux_N, Loc)),
- Unchecked_Convert_To (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc,
- Name_uInit),
- Selector_Name => New_Reference_To
- (Aux_Comp, Loc)),
- Attribute_Name => Name_Position)))));
-
- Aux_Comp := Next_Tag_Component (Aux_Comp);
- Next_Elmt (ADT);
- end loop;
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ then
+ Init_Secondary_Tags (Rec_Type);
end if;
else
Expand_Tagged_Root (Def_Id);
end if;
- -- Build the secondary tables
-
- if not Java_VM
- and then Present (Abstract_Interfaces (Def_Id))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id))
- then
- declare
- E : Entity_Id;
- Result : List_Id;
- ADT : Elist_Id := Access_Disp_Table (Def_Id);
-
- begin
- E := First_Entity (Def_Id);
- while Present (E) loop
- if Is_Tag (E) and then Chars (E) /= Name_uTag then
- Make_Abstract_Interface_DT
- (AI_Tag => E,
- Acc_Disp_Tables => ADT,
- Result => Result);
-
- Append_Freeze_Actions (Def_Id, Result);
- end if;
-
- Next_Entity (E);
- end loop;
-
- Set_Access_Disp_Table (Def_Id, ADT);
- end;
- end if;
-
-- Unfreeze momentarily the type to add the predefined primitives
-- operations. The reason we unfreeze is so that these predefined
-- operations will indeed end up as primitive operations (which
-- dispatching mechanism is handled internally by the JVM.
if not Java_VM then
- Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+
+ -- Ada 2005 (AI-251): Build the secondary dispatch tables
+
+ declare
+ ADT : Elist_Id := Access_Disp_Table (Def_Id);
+
+ procedure Add_Secondary_Tables (Typ : Entity_Id);
+ -- Comment required ???
+
+ --------------------------
+ -- Add_Secondary_Tables --
+ --------------------------
+
+ procedure Add_Secondary_Tables (Typ : Entity_Id) is
+ E : Entity_Id;
+ Result : List_Id;
+
+ begin
+ if Etype (Typ) /= Typ then
+ Add_Secondary_Tables (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+ while Present (E) loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ Make_Abstract_Interface_DT
+ (AI_Tag => E,
+ Acc_Disp_Tables => ADT,
+ Result => Result);
+
+ Append_Freeze_Actions (Def_Id, Result);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Add_Secondary_Tables;
+
+ -- Start of processing to build secondary dispatch tables
+
+ begin
+ Add_Secondary_Tables (Def_Id);
+ Set_Access_Disp_Table (Def_Id, ADT);
+ Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+ end;
end if;
-- Make sure that the primitives Initialize, Adjust and Finalize
Ret_Type => Standard_Integer));
- -- Specs for dispatching stream attributes.
+ -- Specs for dispatching stream attributes
declare
Stream_Op_TSS_Names :
procedure Freeze_Subprogram (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
- Thunk_Id : Entity_Id;
- Iface_Tag : Entity_Id;
- New_Thunk : Node_Id;
- begin
- -- When a primitive is frozen, enter its name in the corresponding
- -- dispatch table. If the DTC_Entity field is not set this is an
- -- overridden primitive that can be ignored. We suppress the
- -- initialization of the dispatch table entry when Java_VM because
- -- the dispatching mechanism is handled internally by the JVM.
+ procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
+ -- (Ada 2005): Check if the primitive E covers some interface already
+ -- implemented by some ancestor of the tagged-type associated with E
+
+ procedure Register_Interface_DT_Entry
+ (Prim : Entity_Id;
+ Ancestor_Iface_Prim : Entity_Id := Empty);
+ -- (Ada 2005): Register an interface primitive in a secondary dispatch
+ -- table. If Prim overrides an ancestor primitive of its associated
+ -- tagged-type then Ancestor_Iface_Prim indicates the entity of that
+ -- immediate ancestor associated with the interface; otherwise Prim and
+ -- Ancestor_Iface_Prim have the same info.
+
+ -------------------------------------------
+ -- Check_Overriding_Inherited_Interfaces --
+ -------------------------------------------
+
+ procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is
+ Typ : Entity_Id;
+ Elmt : Elmt_Id;
+ Prim_Op : Entity_Id;
+ Overriden_Op : Entity_Id := Empty;
- if Is_Dispatching_Operation (E)
- and then not Is_Abstract (E)
- and then Present (DTC_Entity (E))
- and then not Is_CPP_Class (Scope (DTC_Entity (E)))
- and then not Java_VM
- then
- Check_Overriding_Operation (E);
+ begin
+ if Ada_Version < Ada_05
+ or else not Is_Overriding_Operation (E)
+ or else Is_Predefined_Dispatching_Operation (E)
+ or else Present (Alias (E))
+ then
+ return;
+ end if;
+
+ -- Get the entity associated with this primitive operation
+
+ Typ := Scope (DTC_Entity (E));
+ while Etype (Typ) /= Typ loop
+
+ -- Climb to the immediate ancestor
+
+ Typ := Etype (Typ);
- -- Common case: Primitive subprogram
+ if Present (Abstract_Interfaces (Typ)) then
- if not Present (Abstract_Interface_Alias (E)) then
- Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+ -- Look for the overriden subprogram in the primary dispatch
+ -- table of the ancestor.
- -- Ada 2005 (AI-251): Primitive subprogram that covers an interface
+ Overriden_Op := Empty;
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim_Op := Node (Elmt);
+
+ if DT_Position (Prim_Op) = DT_Position (E)
+ and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
+ and then not Present (Abstract_Interface_Alias (Prim_Op))
+ then
+ if Overriden_Op /= Empty then
+ raise Program_Error;
+ end if;
+
+ Overriden_Op := Prim_Op;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- if not found this is the first overriding of some
+ -- abstract interface
+
+ if Overriden_Op /= Empty then
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+
+ -- Find the entries associated with interfaces that are
+ -- alias of this primitive operation in the ancestor
+
+ while Present (Elmt) loop
+ Prim_Op := Node (Elmt);
+
+ if Present (Abstract_Interface_Alias (Prim_Op))
+ and then Alias (Prim_Op) = Overriden_Op
+ then
+ Register_Interface_DT_Entry (E, Prim_Op);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end if;
+ end loop;
+ end Check_Overriding_Inherited_Interfaces;
+
+ ---------------------------------
+ -- Register_Interface_DT_Entry --
+ ---------------------------------
+
+ procedure Register_Interface_DT_Entry
+ (Prim : Entity_Id;
+ Ancestor_Iface_Prim : Entity_Id := Empty)
+ is
+ Prim_Typ : Entity_Id;
+ Prim_Op : Entity_Id;
+ Iface_Typ : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Iface_Tag : Entity_Id;
+ New_Thunk : Node_Id;
+ Thunk_Id : Entity_Id;
+
+ begin
+ if not Present (Ancestor_Iface_Prim) then
+ Prim_Typ := Scope (DTC_Entity (Alias (Prim)));
+ Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
+ Iface_Tag := Find_Interface_Tag
+ (T => Prim_Typ,
+ Iface => Iface_Typ);
+
+ -- Generate the code of the thunk only when this primitive
+ -- operation is associated with a secondary dispatch table
+
+ if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+ Thunk_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T'));
+ New_Thunk :=
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Alias (Prim),
+ Thunk_Id => Thunk_Id,
+ Iface_Tag => Iface_Tag);
+
+ Insert_After (N, New_Thunk);
+
+ Iface_DT_Ptr :=
+ Find_Interface_ADT
+ (T => Prim_Typ,
+ Iface => Iface_Typ);
+
+ Insert_After (New_Thunk,
+ Fill_Secondary_DT_Entry (Sloc (Prim),
+ Prim => Prim,
+ Iface_DT_Ptr => Iface_DT_Ptr,
+ Thunk_Id => Thunk_Id));
+ end if;
else
+ Iface_Typ :=
+ Scope (DTC_Entity (Abstract_Interface_Alias
+ (Ancestor_Iface_Prim)));
+
Iface_Tag :=
Find_Interface_Tag
- (T => Scope (DTC_Entity (Alias (E))), -- Formal Type
- Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E))));
+ (T => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))),
+ Iface => Iface_Typ);
-- Generate the thunk only if the associated tag is an interface
-- tag. The case in which the associated tag is the primary tag
Thunk_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
- New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag);
+ if Present (Alias (Prim)) then
+ Prim_Op := Alias (Prim);
+ else
+ Prim_Op := Prim;
+ end if;
+
+ New_Thunk :=
+ Expand_Interface_Thunk
+ (N => Ancestor_Iface_Prim,
+ Thunk_Alias => Prim_Op,
+ Thunk_Id => Thunk_Id,
+ Iface_Tag => Iface_Tag);
+
+ Insert_After (N, New_Thunk);
+
+ Iface_DT_Ptr :=
+ Find_Interface_ADT
+ (T => Scope (DTC_Entity (Prim_Op)),
+ Iface => Iface_Typ);
Insert_After (New_Thunk,
- Fill_DT_Entry (Sloc (N),
- Prim => E,
- Thunk_Id => Thunk_Id));
+ Fill_Secondary_DT_Entry (Sloc (Prim),
+ Prim => Ancestor_Iface_Prim,
+ Iface_DT_Ptr => Iface_DT_Ptr,
+ Thunk_Id => Thunk_Id));
+ end if;
+ end if;
+ end Register_Interface_DT_Entry;
+
+ -- Start of processing for Freeze_Subprogram
+
+ begin
+ -- When a primitive is frozen, enter its name in the corresponding
+ -- dispatch table. If the DTC_Entity field is not set this is an
+ -- overridden primitive that can be ignored. We suppress the
+ -- initialization of the dispatch table entry when Java_VM because
+ -- the dispatching mechanism is handled internally by the JVM.
+
+ if Is_Dispatching_Operation (E)
+ and then not Is_Abstract (E)
+ and then Present (DTC_Entity (E))
+ and then not Java_VM
+ and then not Is_CPP_Class (Scope (DTC_Entity (E)))
+ then
+ Check_Overriding_Operation (E);
+
+ if Ada_Version < Ada_05 then
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
+
+ else
+ -- Ada 2005 (AI-251): Check if this entry corresponds with
+ -- a subprogram that covers an abstract interface type
+
+ if Present (Abstract_Interface_Alias (E)) then
+ Register_Interface_DT_Entry (E);
+
+ -- Common case: Primitive subprogram
+
+ else
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
+ Check_Overriding_Inherited_Interfaces (E);
end if;
end if;
end if;
function Expand_Interface_Thunk
(N : Node_Id;
+ Thunk_Alias : Entity_Id;
Thunk_Id : Entity_Id;
Iface_Tag : Entity_Id) return Node_Id
is
Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List;
Thunk_Tag : constant Node_Id := Iface_Tag;
- Thunk_Alias : constant Entity_Id := Alias (Entity (N));
Target : Entity_Id;
New_Code : Node_Id;
Formal : Node_Id;
if Is_Controlling_Formal (Formal) then
Set_Parameter_Type (New_Formal,
- New_Reference_To (Etype (First_Entity (Entity (N))), Loc));
-
- -- Why is this line silently commented out ???
-
- -- New_Reference_To (Etype (Formal), Loc));
+ New_Reference_To (Etype (First_Entity (N)), Loc));
end if;
Append_To (Formals, New_Formal);
end if;
Analyze (New_Code);
- Insert_After (N, New_Code);
return New_Code;
end Expand_Interface_Thunk;
- -------------
- -- Fill_DT --
- -------------
+ -------------------
+ -- Fill_DT_Entry --
+ -------------------
function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id;
- Thunk_Id : Entity_Id := Empty) return Node_Id
+ (Loc : Source_Ptr;
+ Prim : Entity_Id) return Node_Id
is
Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
- DT_Ptr : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ)));
- Target : Entity_Id;
- Tag : Entity_Id := First_Tag_Component (Typ);
- Prim_Op : Entity_Id := Prim;
+ DT_Ptr : constant Entity_Id :=
+ Node (First_Elmt (Access_Disp_Table (Typ)));
+ Pos : constant Uint := DT_Position (Prim);
+ Tag : constant Entity_Id := First_Tag_Component (Typ);
begin
- -- Ada 2005 (AI-251): If we have a thunk available then generate code
- -- that saves its address in the secondary dispatch table of its
- -- abstract interface; otherwise save the address of the primitive
- -- subprogram in the main virtual table.
-
- if Thunk_Id /= Empty then
- Target := Thunk_Id;
- else
- Target := Prim;
+ if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
+ raise Program_Error;
end if;
- -- Ada 2005 (AI-251): If the subprogram is the alias of an abstract
- -- interface subprogram then find the correct dispatch table pointer
+ return
+ Make_DT_Access_Action (Typ,
+ Action => Set_Prim_Op_Address,
+ Args => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)), -- DTptr
- if Present (Abstract_Interface_Alias (Prim)) then
- Prim_Op := Abstract_Interface_Alias (Prim);
+ Make_Integer_Literal (Loc, Pos), -- Position
- DT_Ptr := Find_Interface_ADT
- (T => Typ,
- Iface => Scope (DTC_Entity (Prim_Op)));
+ Make_Attribute_Reference (Loc, -- Value
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Address)));
+ end Fill_DT_Entry;
- Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op)));
- end if;
+ -----------------------------
+ -- Fill_Secondary_DT_Entry --
+ -----------------------------
- pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag));
- pragma Assert (DT_Position (Prim_Op) > Uint_0);
+ function Fill_Secondary_DT_Entry
+ (Loc : Source_Ptr;
+ Prim : Entity_Id;
+ Thunk_Id : Entity_Id;
+ Iface_DT_Ptr : Entity_Id) return Node_Id
+ is
+ Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
+ Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
+ Pos : constant Uint := DT_Position (Iface_Prim);
+ Tag : constant Entity_Id :=
+ First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
+
+ begin
+ if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
+ raise Program_Error;
+ end if;
return
Make_DT_Access_Action (Typ,
Action => Set_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)), -- DTptr
+ New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
- Make_Integer_Literal (Loc, DT_Position (Prim_Op)), -- Position
+ Make_Integer_Literal (Loc, Pos), -- Position
Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Target, Loc),
+ Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
- end Fill_DT_Entry;
+ end Fill_Secondary_DT_Entry;
---------------------------
-- Get_Remotely_Callable --
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
-- ----------------------------------------------------------------
-
-- Dispatch table and related entities are allocated statically
Set_Ekind (DT, E_Variable);
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
+ -- Inherit the secondary dispatch tables of the ancestor
+
+ if not Is_CPP_Class (Etype (Typ)) then
+ declare
+ Sec_DT_Ancestor : Elmt_Id :=
+ Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ))));
+ Sec_DT_Typ : Elmt_Id :=
+ Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id);
+ -- ??? comment required
+
+ ------------------------
+ -- Copy_Secondary_DTs --
+ ------------------------
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ if Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+
+ while Present (E)
+ and then Present (Node (Sec_DT_Ancestor))
+ loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Ancestor), Loc)),
+ Node2 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Typ), Loc)),
+ Node3 => Make_Integer_Literal (Loc,
+ DT_Entry_Count (E)))));
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Copy_Secondary_DTs;
+
+ begin
+ if Present (Node (Sec_DT_Ancestor)) then
+ Copy_Secondary_DTs (Typ);
+ end if;
+ end;
+ end if;
+
-- Generate: Inherit_TSD (parent'tag, DT_Ptr);
Append_To (Elab_Code,
Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
- -- for types with no controlled components
- -- Generate: Set_RC_Offset (DT_Ptr, 0);
- -- for simple types with controlled components
- -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
- -- for complex types with controlled components where the position
+ -- For types with no controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, 0);
+
+ -- For simple types with controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
+
+ -- For complex types with controlled components where the position
-- of the record controller is not statically computable, if there are
- -- controlled components at this level
- -- Generate: Set_RC_Offset (DT_Ptr, -1);
- -- to indicate that the _controller field is right after the _parent or
- -- if there are no controlled components at this level,
- -- Generate: Set_RC_Offset (DT_Ptr, -2);
+ -- controlled components at this level, generate:
+ -- Set_RC_Offset (DT_Ptr, -1);
+ -- to indicate that the _controller field is right after the _parent
+
+ -- Or if there are no controlled components at this level, generate:
+ -- Set_RC_Offset (DT_Ptr, -2);
-- to indicate that we need to get the position from the parent.
declare
-- the back end (see comment on the Bit_Component attribute in
-- sem_attr). So we avoid semantic checking here.
+ -- Is this documented in sinfo.ads??? it should be!
+
Set_Analyzed (Position);
Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
Set_Etype (Prefix (Prefix (Position)), Typ);
Node2 => Position)));
end;
- -- Generate: Set_Remotely_Callable (DT_Ptr, Status);
- -- where Status is described in E.4 (18)
+ -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
+ -- described in E.4 (18)
declare
Status : Entity_Id;
-- Ada 2005 (AI-251): Register the tag of the interfaces into
-- the table of implemented interfaces
- if Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ if Present (Abstract_Interfaces (Typ_Copy))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
then
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
Result : out List_Id)
is
Loc : constant Source_Ptr := Sloc (AI_Tag);
- Tname : constant Name_Id := Chars (AI_Tag);
- Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
- Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
+ Name_DT : constant Name_Id := New_Internal_Name ('T');
+ Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P');
Iface_DT : constant Node_Id :=
Make_Defining_Identifier (Loc, Name_DT);
end if;
Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
-
end Make_Abstract_Interface_DT;
---------------------------
Prim_Elmt := First_Prim;
Count_Prim := 0;
+
while Present (Prim_Elmt) loop
Count_Prim := Count_Prim + 1;
Prim := Node (Prim_Elmt);
TSD_Prologue_Size);
function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id;
- Thunk_Id : Entity_Id := Empty) return Node_Id;
+ (Loc : Source_Ptr;
+ Prim : Entity_Id) return Node_Id;
-- Generate the code necessary to fill the appropriate entry of the
-- dispatch table of Prim's controlling type with Prim's address.
+ function Fill_Secondary_DT_Entry
+ (Loc : Source_Ptr;
+ Prim : Entity_Id;
+ Thunk_Id : Entity_Id;
+ Iface_DT_Ptr : Entity_Id) return Node_Id;
+ -- (Ada 2005): Generate the code necessary to fill the appropriate entry of
+ -- the secondary dispatch table of Prim's controlling type with Thunk_Id's
+ -- address.
+
procedure Make_Abstract_Interface_DT
(AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
-- secondary dispatch table
function Expand_Interface_Thunk
- (N : Node_Id;
- Thunk_Id : Entity_Id;
- Iface_Tag : Entity_Id) return Node_Id;
+ (N : Node_Id;
+ Thunk_Alias : Node_Id;
+ Thunk_Id : Entity_Id;
+ Iface_Tag : Entity_Id) return Node_Id;
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
-- procedure of record with task components, or for a dynamically
-- created task that is assigned to a selected component.
- procedure Find_Interface_Tag
- (T : Entity_Id;
- Iface : Entity_Id;
- Iface_Tag : out Entity_Id;
- Iface_ADT : out Entity_Id);
- -- Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and
- -- Find_Interface_Tag. Given a type T implementing the interface,
- -- returns the corresponding Tag and Access_Disp_Table entities.
-
function Make_CW_Equivalent_Type
(T : Entity_Id;
E : Node_Id) return Entity_Id;
-- Find_Interface_Tag --
------------------------
- procedure Find_Interface_Tag
- (T : Entity_Id;
- Iface : Entity_Id;
- Iface_Tag : out Entity_Id;
- Iface_ADT : out Entity_Id)
+ function Find_Interface_ADT
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ ADT : Elmt_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
+
+ procedure Find_Secondary_Table (Typ : Entity_Id);
+ -- Comment required ???
+
+ --------------------------
+ -- Find_Secondary_Table --
+ --------------------------
+
+ procedure Find_Secondary_Table (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
+
+ begin
+ if Etype (Typ) /= Typ then
+ Find_Secondary_Table (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ Next_Elmt (ADT);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Secondary_Table;
+
+ -- Start of processing for Find_Interface_Tag
+
+ begin
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Ekind (Typ) = E_Protected_Type
+ or else Ekind (Typ) = E_Task_Type
+ then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ pragma Assert (Present (Node (ADT)));
+ Find_Secondary_Table (Typ);
+ pragma Assert (Found);
+ return Node (ADT);
+ end Find_Interface_ADT;
+
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
+
+ function Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
is
- AI_Tag : Entity_Id;
- ADT_Elmt : Elmt_Id;
- Found : Boolean := False;
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
- procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean);
- -- This must be commented ???
+ procedure Find_Tag (Typ : in Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
-----------------
-- Find_AI_Tag --
-----------------
- procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is
- T : Entity_Id := Typ;
- Etyp : Entity_Id; -- := Etype (Typ); -- why is this commented ???
+ procedure Find_Tag (Typ : in Entity_Id) is
AI_Elmt : Elmt_Id;
AI : Node_Id;
-- therefore shares the main tag.
if Typ = Iface then
- AI_Tag := First_Tag_Component (Typ);
- ADT_Elmt := First_Elmt (Access_Disp_Table (Typ));
- Found := True;
+ pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := First_Tag_Component (Typ);
+ Found := True;
return;
end if;
- -- Handle private types
-
- if Has_Private_Declaration (T)
- and then Present (Full_View (T))
- then
- T := Full_View (T);
- end if;
-
- if Is_Access_Type (Typ) then
- T := Directly_Designated_Type (T);
-
- elsif Ekind (T) = E_Protected_Type
- or else Ekind (T) = E_Task_Type
- then
- T := Corresponding_Record_Type (T);
- end if;
-
- Etyp := Etype (T);
-
-- Climb to the root type
- if Etyp /= Typ then
- Find_AI_Tag (Etyp, Found);
+ if Etype (Typ) /= Typ then
+ Find_Tag (Etype (Typ));
end if;
-- Traverse the list of interfaces implemented by the type
if not Found
- and then Present (Abstract_Interfaces (T))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then
- -- Skip the tag associated with the primary table (if
- -- already placed in the record)
-
- if Etype (Node (First_Elmt
- (Access_Disp_Table (T)))) = RTE (RE_Tag)
- then
- AI_Tag := Next_Tag_Component (First_Tag_Component (T));
- ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
- else
- AI_Tag := First_Tag_Component (T);
- ADT_Elmt := First_Elmt (Access_Disp_Table (T));
- end if;
+ -- Skip the tag associated with the primary table.
+ pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
- pragma Assert (Present (Node (ADT_Elmt)));
- AI_Elmt := First_Elmt (Abstract_Interfaces (T));
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
AI_Tag := Next_Tag_Component (AI_Tag);
Next_Elmt (AI_Elmt);
- Next_Elmt (ADT_Elmt);
end loop;
end if;
- end Find_AI_Tag;
+ end Find_Tag;
+
+ -- Start of processing for Find_Interface_Tag
begin
- Find_AI_Tag (T, Found);
- pragma Assert (Found);
+ -- Handle private types
- Iface_Tag := AI_Tag;
- Iface_ADT := Node (ADT_Elmt);
- end Find_Interface_Tag;
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
- ------------------------
- -- Find_Interface_Tag --
- ------------------------
+ -- Handle access types
- function Find_Interface_ADT
- (T : Entity_Id;
- Iface : Entity_Id) return Entity_Id
- is
- Iface_Tag : Entity_Id := Empty;
- Iface_ADT : Entity_Id := Empty;
- begin
- Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
- return Iface_ADT;
- end Find_Interface_ADT;
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
- ------------------------
- -- Find_Interface_Tag --
- ------------------------
+ -- Handle task and protected types implementing interfaces
- function Find_Interface_Tag
- (T : Entity_Id;
- Iface : Entity_Id) return Entity_Id
- is
- Iface_Tag : Entity_Id := Empty;
- Iface_ADT : Entity_Id := Empty;
- begin
- Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
- return Iface_Tag;
+ if Ekind (Typ) = E_Protected_Type
+ or else Ekind (Typ) = E_Task_Type
+ then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ Find_Tag (Typ);
+ pragma Assert (Found);
+ return AI_Tag;
end Find_Interface_Tag;
------------------
projects / gcc.git / commitdiff