Skip to content

R
riscv-gcc-1
Commit 3ca505dc by Javier Miranda Committed by Arnaud Charlet
Options

exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the… 

exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the support for abstract interface types in order to leave...

2005-07-07  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type):
	Reimplementation of the support for abstract interface types in order
	to leave the code more clear and easy to maintain.

	* exp_ch6.adb (Freeze_Subprogram): Reimplementation of the support for
	abstract interface types in order to leave the code clearer and easier
	to maintain.

	* exp_disp.ads, exp_disp.adb (Fill_DT_Entry): Part of its functionality
	is now implemented by the new subprogram Fill_Secondary_DT_Entry.
	(Fill_Secondary_DT_Entry): Generate the code necessary to fill the
	appropriate entry of the secondary dispatch table.
	(Make_DT): Add code to inherit the secondary dispatch tables of
	the ancestors.

	* exp_util.adb (Find_Interface_Tag/Find_Interface_ADT): Instead of
	implementing both functionalities by means of a common routine, each
	routine has its own code.

From-SVN: r101694
parent 69601f74
Showing with 621 additions and 271 deletions
gcc/ada/exp_ch3.adb
......@@ -1361,10 +1361,6 @@ package body Exp_Ch3 is
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
......@@ -1735,6 +1731,100 @@ package body Exp_Ch3 is
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);
......@@ -1864,55 +1954,10 @@ package body Exp_Ch3 is
-- 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
......@@ -4480,36 +4525,6 @@ package body Exp_Ch3 is
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
......@@ -4533,7 +4548,55 @@ package body Exp_Ch3 is
-- 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
......@@ -5681,7 +5744,7 @@ package body Exp_Ch3 is
Ret_Type => Standard_Integer));
-- Specs for dispatching stream attributes.
-- Specs for dispatching stream attributes
declare
Stream_Op_TSS_Names :
......
gcc/ada/exp_ch6.adb
......@@ -4062,37 +4062,157 @@ package body Exp_Ch6 is
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
......@@ -4107,12 +4227,69 @@ package body Exp_Ch6 is
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;
......
gcc/ada/exp_disp.adb
......@@ -902,6 +902,7 @@ package body Exp_Disp is
function Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Entity_Id;
Thunk_Id : Entity_Id;
Iface_Tag : Entity_Id) return Node_Id
is
......@@ -910,7 +911,6 @@ package body Exp_Disp 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;
......@@ -950,11 +950,7 @@ package body Exp_Disp is
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);
......@@ -1150,66 +1146,76 @@ package body Exp_Disp is
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 --
......@@ -1313,7 +1319,6 @@ package body Exp_Disp is
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);
......@@ -1538,6 +1543,71 @@ package body Exp_Disp is
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,
......@@ -1547,17 +1617,20 @@ package body Exp_Disp is
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
......@@ -1588,6 +1661,8 @@ package body Exp_Disp is
-- 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);
......@@ -1604,8 +1679,8 @@ package body Exp_Disp is
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;
......@@ -1681,8 +1756,8 @@ package body Exp_Disp is
-- 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
......@@ -1718,9 +1793,8 @@ package body Exp_Disp is
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);
......@@ -1848,7 +1922,6 @@ package body Exp_Disp is
end if;
Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
end Make_Abstract_Interface_DT;
---------------------------
......@@ -2117,6 +2190,7 @@ package body Exp_Disp is
Prim_Elmt := First_Prim;
Count_Prim := 0;
while Present (Prim_Elmt) loop
Count_Prim := Count_Prim + 1;
Prim := Node (Prim_Elmt);
......
gcc/ada/exp_disp.ads
......@@ -55,12 +55,20 @@ package Exp_Disp is
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;
......@@ -102,9 +110,10 @@ package Exp_Disp is
-- 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
......
gcc/ada/exp_util.adb
......@@ -108,15 +108,6 @@ package body Exp_Util is
-- 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;
......@@ -1298,26 +1289,100 @@ package body Exp_Util is
-- 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;
......@@ -1326,60 +1391,31 @@ package body Exp_Util is
-- 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);
......@@ -1390,47 +1426,38 @@ package body Exp_Util is
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;
------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment