Skip to content

R
riscv-gcc-1
Commit b2e1beb3 by Ed Schonberg Committed by Arnaud Charlet
Options

exp_disp.ads, [...] (Build_Dispatch_Tables): Handle tagged types declared in the… 

exp_disp.ads, [...] (Build_Dispatch_Tables): Handle tagged types declared in the declarative part of a nested package body...

2007-08-14  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads, exp_disp.adb (Build_Dispatch_Tables): Handle tagged
	types declared in the declarative part of a nested package body or in
	the proper body of a stub.
	(Set_All_DT_Position): Add missing check to avoid wrong assignation
	of the same dispatch table slot to renamed primitives.
	(Make_Select_Specific_Data_Table): Handle private types.
	(Tagged_Kind): Handle private types.
	(Make_Tags, Make_DT): Set tag entity as internal to ensure proper dg
	output of implicit importation and exportation.
	(Expand_Interface_Thunk): Fix bug in the expansion assuming that the
	first formal of the thunk is always associated with the controlling
	type. In addition perform the following code cleanup: remove formal
	Thunk_Alias which is no longer required, cleanup evaluation of the
	the controlling type, and update the documentation.
	Replace occurrence of Default_Prim_Op_Count by
	Max_Predef_Prims. Addition of compile-time check to verify
	that the value of Max_Predef_Prims is correct.
	(Check_Premature_Freezing): Apply check in Ada95 mode as well.
	(Make_DT): Add parameter to indicate when type has been frozen by an
	object declaration, for diagnostic purposes.
	(Build_Static_Dispatch_Tables): New subprogram that takes care of the
	construction of statically allocated dispatch tables.
	(Make_DT): In case of library-level tagged types export the declaration
	of the primary tag. Remove generation of tags (now done by Make_Tags).
	Additional modifications to handle non-static generation of dispatch
	tables. Take care of building tables for asynchronous interface types
	(Make_Tags): New subprogram that generates the entities associated with
	the primary and secondary tags of Typ and fills the contents of Access_
	Disp_Table. In case of library-level tagged types imports the forward
	declaration of the primary tag that will be declared later by Make_DT.
	(Expand_Interface_Conversion): In case of access types to interfaces
	replace an itype declaration by an explicit type declaration to avoid
	problems associated with the scope of such itype in transient blocks.

From-SVN: r127418
parent 04df6250
Showing with 1050 additions and 668 deletions
gcc/ada/exp_disp.adb
...@@ -37,7 +37,6 @@ with Exp_Tss; use Exp_Tss; ...@@ -37,7 +37,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze; with Freeze; use Freeze;
with Itypes; use Itypes; with Itypes; use Itypes;
with Lib; use Lib;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
with Namet; use Namet; with Namet; use Namet;
...@@ -91,6 +90,148 @@ package body Exp_Disp is ...@@ -91,6 +90,148 @@ package body Exp_Disp is
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value. -- to an RE_Tagged_Kind enumeration value.
----------------------------------
-- Build_Static_Dispatch_Tables --
----------------------------------
procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
Target_List : List_Id;
procedure Build_Dispatch_Tables (List : List_Id);
-- Build the static dispatch table of tagged types found in the list of
-- declarations. The generated nodes are added at the end of Target_List
procedure Build_Package_Dispatch_Tables (N : Node_Id);
-- Build static dispatch tables associated with package declaration N
---------------------------
-- Build_Dispatch_Tables --
---------------------------
procedure Build_Dispatch_Tables (List : List_Id) is
D : Node_Id;
begin
D := First (List);
while Present (D) loop
-- Handle nested packages and package bodies recursively. The
-- generated code is placed on the Target_List established for
-- the enclosing compilation unit.
if Nkind (D) = N_Package_Declaration then
Build_Package_Dispatch_Tables (D);
elsif Nkind (D) = N_Package_Body then
Build_Dispatch_Tables (Declarations (D));
elsif Nkind (D) = N_Package_Body_Stub
and then Present (Library_Unit (D))
then
Build_Dispatch_Tables
(Declarations (Proper_Body (Unit (Library_Unit (D)))));
-- Handle full type declarations and derivations of library
-- level tagged types
elsif (Nkind (D) = N_Full_Type_Declaration
or else Nkind (D) = N_Derived_Type_Definition)
and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
and then not Is_Private_Type (Defining_Entity (D))
then
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (Defining_Entity (D)));
-- Handle private types of library level tagged types. We must
-- exchange the private and full-view to ensure the correct
-- expansion.
elsif (Nkind (D) = N_Private_Type_Declaration
or else Nkind (D) = N_Private_Extension_Declaration)
and then Present (Full_View (Defining_Entity (D)))
and then Is_Library_Level_Tagged_Type
(Full_View (Defining_Entity (D)))
and then Ekind (Full_View (Defining_Entity (D)))
/= E_Record_Subtype
then
declare
E1, E2 : Entity_Id;
begin
E1 := Defining_Entity (D);
E2 := Full_View (Defining_Entity (D));
Exchange_Entities (E1, E2);
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (E1));
Exchange_Entities (E1, E2);
end;
end if;
Next (D);
end loop;
end Build_Dispatch_Tables;
-----------------------------------
-- Build_Package_Dispatch_Tables --
-----------------------------------
procedure Build_Package_Dispatch_Tables (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Id : constant Entity_Id := Defining_Entity (N);
Vis_Decls : constant List_Id := Visible_Declarations (Spec);
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
Push_Scope (Id);
if Present (Priv_Decls) then
Build_Dispatch_Tables (Vis_Decls);
Build_Dispatch_Tables (Priv_Decls);
elsif Present (Vis_Decls) then
Build_Dispatch_Tables (Vis_Decls);
end if;
Pop_Scope;
end Build_Package_Dispatch_Tables;
-- Start of processing for Build_Static_Dispatch_Tables
begin
if not Expander_Active
or else VM_Target /= No_VM
then
return;
end if;
if Nkind (N) = N_Package_Declaration then
declare
Spec : constant Node_Id := Specification (N);
Vis_Decls : constant List_Id := Visible_Declarations (Spec);
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
if Present (Priv_Decls)
and then Is_Non_Empty_List (Priv_Decls)
then
Target_List := Priv_Decls;
elsif not Present (Vis_Decls) then
Target_List := New_List;
Set_Private_Declarations (Spec, Target_List);
else
Target_List := Vis_Decls;
end if;
Build_Package_Dispatch_Tables (N);
end;
else pragma Assert (Nkind (N) = N_Package_Body);
Target_List := Declarations (N);
Build_Dispatch_Tables (Target_List);
end if;
end Build_Static_Dispatch_Tables;
------------------------------ ------------------------------
-- Default_Prim_Op_Position -- -- Default_Prim_Op_Position --
------------------------------ ------------------------------
...@@ -573,12 +714,9 @@ package body Exp_Disp is ...@@ -573,12 +714,9 @@ package body Exp_Disp is
Etyp : constant Entity_Id := Etype (N); Etyp : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N); Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand); Operand_Typ : Entity_Id := Etype (Operand);
Fent : Entity_Id;
Func : Node_Id; Func : Node_Id;
Iface_Typ : Entity_Id := Etype (N); Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id; Iface_Tag : Entity_Id;
New_Itype : Entity_Id;
Stats : List_Id;
begin begin
-- Ada 2005 (AI-345): Handle synchronized interface type derivations -- Ada 2005 (AI-345): Handle synchronized interface type derivations
...@@ -672,19 +810,25 @@ package body Exp_Disp is ...@@ -672,19 +810,25 @@ package body Exp_Disp is
-- data returned by IW_Convert to indicate that this is a dispatching -- data returned by IW_Convert to indicate that this is a dispatching
-- call. -- call.
New_Itype := Create_Itype (E_Anonymous_Access_Type, N); declare
Set_Etype (New_Itype, New_Itype); New_Itype : Entity_Id;
Init_Esize (New_Itype);
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype, Etyp);
Rewrite (N, Make_Explicit_Dereference (Loc, begin
Unchecked_Convert_To (New_Itype, New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
Relocate_Node (N)))); Set_Etype (New_Itype, New_Itype);
Analyze (N); Init_Esize (New_Itype);
Freeze_Itype (New_Itype, N); Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype, Etyp);
return; Rewrite (N,
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
Analyze (N);
Freeze_Itype (New_Itype, N);
return;
end;
end if; end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
...@@ -709,18 +853,24 @@ package body Exp_Disp is ...@@ -709,18 +853,24 @@ package body Exp_Disp is
-- the value of the displaced actual. That is: -- the value of the displaced actual. That is:
-- function Func (O : Address) return Iface_Typ is -- function Func (O : Address) return Iface_Typ is
-- type Op_Typ is access all Operand_Typ;
-- Aux : Op_Typ := To_Op_Typ (O);
-- begin -- begin
-- if O = Null_Address then -- if O = Null_Address then
-- return null; -- return null;
-- else -- else
-- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address); -- return Iface_Typ!(Aux.Iface_Tag'Address);
-- end if; -- end if;
-- end Func; -- end Func;
Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
declare declare
Desig_Typ : Entity_Id; Decls : List_Id;
Desig_Typ : Entity_Id;
Fent : Entity_Id;
New_Typ_Decl : Node_Id;
New_Obj_Decl : Node_Id;
Stats : List_Id;
begin begin
Desig_Typ := Etype (Expression (N)); Desig_Typ := Etype (Expression (N));
...@@ -728,99 +878,127 @@ package body Exp_Disp is ...@@ -728,99 +878,127 @@ package body Exp_Disp is
Desig_Typ := Directly_Designated_Type (Desig_Typ); Desig_Typ := Directly_Designated_Type (Desig_Typ);
end if; end if;
New_Itype := Create_Itype (E_Anonymous_Access_Type, N); New_Typ_Decl :=
Set_Etype (New_Itype, New_Itype); Make_Full_Type_Declaration (Loc,
Set_Scope (New_Itype, Fent); Defining_Identifier =>
Init_Size_Align (New_Itype); Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Set_Directly_Designated_Type (New_Itype, Desig_Typ); Type_Definition =>
end; Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
New_Reference_To (Desig_Typ, Loc)));
Stats := New_List ( New_Obj_Decl :=
Make_Return_Statement (Loc, Make_Object_Declaration (Loc,
Unchecked_Convert_To (Etype (N), Defining_Identifier =>
Make_Attribute_Reference (Loc, Make_Defining_Identifier (Loc,
Prefix => New_Internal_Name ('S')),
Make_Selected_Component (Loc, Constant_Present => True,
Prefix => Unchecked_Convert_To (New_Itype, Object_Definition =>
Make_Identifier (Loc, Name_uO)), New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
Selector_Name => Expression =>
New_Occurrence_Of (Iface_Tag, Loc)), Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
Attribute_Name => Name_Address)))); Make_Identifier (Loc, Name_uO)));
-- If the type is null-excluding, no need for the null branch. Decls := New_List (
-- Otherwise we need to check for it and return null. New_Typ_Decl,
New_Obj_Decl);
if not Can_Never_Be_Null (Etype (N)) then
Stats := New_List ( Stats := New_List (
Make_If_Statement (Loc, Make_Simple_Return_Statement (Loc,
Condition => Unchecked_Convert_To (Etype (N),
Make_Op_Eq (Loc, Make_Attribute_Reference (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uO), Prefix =>
Right_Opnd => New_Reference_To Make_Selected_Component (Loc,
(RTE (RE_Null_Address), Loc)), Prefix =>
New_Reference_To
Then_Statements => New_List ( (Defining_Identifier (New_Obj_Decl),
Make_Return_Statement (Loc, Loc),
Make_Null (Loc))), Selector_Name =>
Else_Statements => Stats)); New_Occurrence_Of (Iface_Tag, Loc)),
end if; Attribute_Name => Name_Address))));
Func := -- If the type is null-excluding, no need for the null branch.
Make_Subprogram_Body (Loc, -- Otherwise we need to check for it and return null.
Specification =>
Make_Function_Specification (Loc, if not Can_Never_Be_Null (Etype (N)) then
Defining_Unit_Name => Fent, Stats := New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uO),
Right_Opnd => New_Reference_To
(RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Make_Null (Loc))),
Else_Statements => Stats));
end if;
Parameter_Specifications => New_List ( Fent :=
Make_Parameter_Specification (Loc, Make_Defining_Identifier (Loc,
Defining_Identifier => New_Internal_Name ('F'));
Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc))),
Result_Definition => Func :=
New_Reference_To (Etype (N), Loc)), Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Fent,
Declarations => Empty_List, Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc))),
Handled_Statement_Sequence => Result_Definition =>
Make_Handled_Sequence_Of_Statements (Loc, Stats)); New_Reference_To (Etype (N), Loc)),
-- Place function body before the expression containing the Declarations => Decls,
-- conversion. We suppress all checks because the body of the
-- internally generated function already takes care of the case
-- in which the actual is null; therefore there is no need to
-- double check that the pointer is not null when the program
-- executes the alternative that performs the type conversion).
Insert_Action (N, Func, Suppress => All_Checks); Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stats));
if Is_Access_Type (Etype (Expression (N))) then -- Place function body before the expression containing the
-- conversion. We suppress all checks because the body of the
-- internally generated function already takes care of the case
-- in which the actual is null; therefore there is no need to
-- double check that the pointer is not null when the program
-- executes the alternative that performs the type conversion).
-- Generate: Operand_Typ!(Expression.all)'Address Insert_Action (N, Func, Suppress => All_Checks);
Rewrite (N, if Is_Access_Type (Etype (Expression (N))) then
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Make_Explicit_Dereference (Loc,
Relocate_Node (Expression (N)))),
Attribute_Name => Name_Address))));
else -- Generate: Operand_Typ!(Expression.all)'Address
-- Generate: Operand_Typ!(Expression)'Address
Rewrite (N, Rewrite (N,
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc), Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ, Prefix => Unchecked_Convert_To (Operand_Typ,
Relocate_Node (Expression (N))), Make_Explicit_Dereference (Loc,
Attribute_Name => Name_Address)))); Relocate_Node (Expression (N)))),
end if; Attribute_Name => Name_Address))));
else
-- Generate: Operand_Typ!(Expression)'Address
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Relocate_Node (Expression (N))),
Attribute_Name => Name_Address))));
end if;
end;
end if; end if;
Analyze (N); Analyze (N);
...@@ -1014,12 +1192,11 @@ package body Exp_Disp is ...@@ -1014,12 +1192,11 @@ package body Exp_Disp is
---------------------------- ----------------------------
procedure Expand_Interface_Thunk procedure Expand_Interface_Thunk
(N : Node_Id; (Prim : Node_Id;
Thunk_Alias : Entity_Id; Thunk_Id : out Entity_Id;
Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id)
Thunk_Code : out Node_Id)
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (Prim);
Actuals : constant List_Id := New_List; Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List; Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List; Formals : constant List_Id := New_List;
...@@ -1038,13 +1215,13 @@ package body Exp_Disp is ...@@ -1038,13 +1215,13 @@ package body Exp_Disp is
-- Give message if configurable run-time and Offset_To_Top unavailable -- Give message if configurable run-time and Offset_To_Top unavailable
if not RTE_Available (RE_Offset_To_Top) then if not RTE_Available (RE_Offset_To_Top) then
Error_Msg_CRT ("abstract interface types", N); Error_Msg_CRT ("abstract interface types", Prim);
return; return;
end if; end if;
-- Traverse the list of alias to find the final target -- Traverse the list of alias to find the final target
Target := Thunk_Alias; Target := Prim;
while Present (Alias (Target)) loop while Present (Alias (Target)) loop
Target := Alias (Target); Target := Alias (Target);
end loop; end loop;
...@@ -1076,15 +1253,7 @@ package body Exp_Disp is ...@@ -1076,15 +1253,7 @@ package body Exp_Disp is
Next_Formal (Formal); Next_Formal (Formal);
end loop; end loop;
if Ekind (First_Formal (Target)) = E_In_Parameter Controlling_Typ := Find_Dispatching_Type (Target);
and then Ekind (Etype (First_Formal (Target)))
= E_Anonymous_Access_Type
then
Controlling_Typ :=
Directly_Designated_Type (Etype (First_Formal (Target)));
else
Controlling_Typ := Etype (First_Formal (Target));
end if;
Target_Formal := First_Formal (Target); Target_Formal := First_Formal (Target);
Formal := First (Formals); Formal := First (Formals);
...@@ -1096,11 +1265,9 @@ package body Exp_Disp is ...@@ -1096,11 +1265,9 @@ package body Exp_Disp is
then then
-- Generate: -- Generate:
-- type T is access all <<type of the first formal>> -- type T is access all <<type of the target formal>>
-- S1 := Storage_Offset!(formal) -- S : Storage_Offset := Storage_Offset!(Formal)
-- - Offset_To_Top (Formal.Tag) -- - Offset_To_Top (address!(Formal))
-- ... and the first actual of the call is generated as T!(S1)
Decl_2 := Decl_2 :=
Make_Full_Type_Declaration (Loc, Make_Full_Type_Declaration (Loc,
...@@ -1144,7 +1311,8 @@ package body Exp_Disp is ...@@ -1144,7 +1311,8 @@ package body Exp_Disp is
Append_To (Decl, Decl_2); Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1); Append_To (Decl, Decl_1);
-- Reference the new first actual -- Reference the new actual. Generate:
-- T!(S)
Append_To (Actuals, Append_To (Actuals,
Unchecked_Convert_To Unchecked_Convert_To
...@@ -1154,9 +1322,9 @@ package body Exp_Disp is ...@@ -1154,9 +1322,9 @@ package body Exp_Disp is
elsif Etype (Target_Formal) = Controlling_Typ then elsif Etype (Target_Formal) = Controlling_Typ then
-- Generate: -- Generate:
-- S1 := Storage_Offset!(Formal'Address) -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
-- - Offset_To_Top (Formal.Tag) -- - Offset_To_Top (Formal'Address)
-- S2 := Tag_Ptr!(S3) -- S2 : Addr_Ptr := Addr_Ptr!(S1)
Decl_1 := Decl_1 :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -1200,11 +1368,12 @@ package body Exp_Disp is ...@@ -1200,11 +1368,12 @@ package body Exp_Disp is
Append_To (Decl, Decl_1); Append_To (Decl, Decl_1);
Append_To (Decl, Decl_2); Append_To (Decl, Decl_2);
-- Reference the new first actual -- Reference the new actual. Generate:
-- Target_Formal (S2.all)
Append_To (Actuals, Append_To (Actuals,
Unchecked_Convert_To Unchecked_Convert_To
(Etype (First_Entity (Target)), (Etype (Target_Formal),
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc)))); New_Reference_To (Defining_Identifier (Decl_2), Loc))));
...@@ -1252,7 +1421,7 @@ package body Exp_Disp is ...@@ -1252,7 +1421,7 @@ package body Exp_Disp is
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Occurrence_Of (Target, Loc), Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))))); Parameter_Associations => Actuals)))));
...@@ -1919,7 +2088,7 @@ package body Exp_Disp is ...@@ -1919,7 +2088,7 @@ package body Exp_Disp is
-- return To_Address (_T._task_id); -- return To_Address (_T._task_id);
Ret := Ret :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Unchecked_Type_Conversion (Loc, Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
...@@ -1938,7 +2107,7 @@ package body Exp_Disp is ...@@ -1938,7 +2107,7 @@ package body Exp_Disp is
-- return Null_Address; -- return Null_Address;
Ret := Ret :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
end if; end if;
...@@ -2262,23 +2431,41 @@ package body Exp_Disp is ...@@ -2262,23 +2431,41 @@ package body Exp_Disp is
-- ... -- ...
-- end; -- end;
function Make_DT (Typ : Entity_Id) return List_Id is function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Is_Local_DT : constant Boolean :=
Ekind (Cunit_Entity (Get_Source_Unit (Typ))) Has_DT : constant Boolean :=
/= E_Package; not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls);
Build_Static_DT : constant Boolean :=
Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ);
Max_Predef_Prims : constant Int := Max_Predef_Prims : constant Int :=
UI_To_Int UI_To_Int
(Intval (Intval
(Expression (Expression
(Parent (RTE (RE_Default_Prim_Op_Count))))); (Parent (RTE (RE_Max_Predef_Prims)))));
procedure Check_Premature_Freezing (Subp : 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
-- subprogram is frozen, enough must be known about it to build the
-- activation record for it, which requires at least that the size of
-- all parameters be known. Controlling arguments are by-reference,
-- and therefore the rule only applies to non-tagged types.
-- 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.
procedure Make_Secondary_DT procedure Make_Secondary_DT
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
AI_Tag : Entity_Id; AI_Tag : Entity_Id;
Iface_DT_Ptr : Entity_Id; Iface_DT_Ptr : Entity_Id;
Result : List_Id); Result : List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
-- Table of Typ associated with Iface (each abstract interface of Typ -- Table of Typ associated with Iface (each abstract interface of Typ
-- has a secondary dispatch table). The arguments Typ, Ancestor_Typ -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ
...@@ -2286,6 +2473,29 @@ package body Exp_Disp is ...@@ -2286,6 +2473,29 @@ package body Exp_Disp is
-- is added at the end of Acc_Disp_Tables; this external name will be -- is added at the end of Acc_Disp_Tables; this external name will be
-- used later by the subprogram Exp_Ch3.Build_Init_Procedure. -- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
------------------------------
-- 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)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (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);
end if;
end Check_Premature_Freezing;
----------------------- -----------------------
-- Make_Secondary_DT -- -- Make_Secondary_DT --
----------------------- -----------------------
...@@ -2299,7 +2509,6 @@ package body Exp_Disp is ...@@ -2299,7 +2509,6 @@ package body Exp_Disp is
is is
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
Name_DT : constant Name_Id := New_Internal_Name ('T'); Name_DT : constant Name_Id := New_Internal_Name ('T');
Iface_DT : constant Entity_Id := Iface_DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT); Make_Defining_Identifier (Loc, Name_DT);
...@@ -2321,12 +2530,10 @@ package body Exp_Disp is ...@@ -2321,12 +2530,10 @@ package body Exp_Disp is
Prim_Ops_Aggr_List : List_Id; Prim_Ops_Aggr_List : List_Id;
begin begin
-- Handle the case where the backend does not support statically -- Handle cases in which we do not generate statically allocated
-- allocated dispatch tables. -- dispatch tables.
if not Static_Dispatch_Tables if not Build_Static_DT then
or else Is_Local_DT
then
Set_Ekind (Predef_Prims, E_Variable); Set_Ekind (Predef_Prims, E_Variable);
Set_Is_Statically_Allocated (Predef_Prims); Set_Is_Statically_Allocated (Predef_Prims);
...@@ -2369,7 +2576,7 @@ package body Exp_Disp is ...@@ -2369,7 +2576,7 @@ package body Exp_Disp is
-- Stage 1: Calculate the number of predefined primitives -- Stage 1: Calculate the number of predefined primitives
if not Static_Dispatch_Tables then if not Build_Static_DT then
Nb_Predef_Prims := Max_Predef_Prims; Nb_Predef_Prims := Max_Predef_Prims;
else else
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
...@@ -2415,11 +2622,7 @@ package body Exp_Disp is ...@@ -2415,11 +2622,7 @@ package body Exp_Disp is
Prim := Alias (Prim); Prim := Alias (Prim);
end loop; end loop;
Expand_Interface_Thunk Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
(N => Prim,
Thunk_Alias => Prim,
Thunk_Id => Thunk_Id,
Thunk_Code => Thunk_Code);
if Present (Thunk_Id) then if Present (Thunk_Id) then
Append_To (Result, Thunk_Code); Append_To (Result, Thunk_Code);
...@@ -2447,7 +2650,7 @@ package body Exp_Disp is ...@@ -2447,7 +2650,7 @@ package body Exp_Disp is
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims, Defining_Identifier => Predef_Prims,
Constant_Present => Static_Dispatch_Tables, Constant_Present => Build_Static_DT,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc), New_Reference_To (RTE (RE_Address_Array), Loc),
...@@ -2627,6 +2830,16 @@ package body Exp_Disp is ...@@ -2627,6 +2830,16 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Component_Associations => OSD_Aggr_List)))))); Component_Associations => OSD_Aggr_List))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (OSD, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- In secondary dispatch tables the Typeinfo component contains -- In secondary dispatch tables the Typeinfo component contains
-- the address of the Object Specific Data (see a-tags.ads) -- the address of the Object Specific Data (see a-tags.ads)
...@@ -2645,7 +2858,7 @@ package body Exp_Disp is ...@@ -2645,7 +2858,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
elsif Is_Abstract_Type (Typ) elsif Is_Abstract_Type (Typ)
or else not Static_Dispatch_Tables or else not Build_Static_DT
then then
for J in 1 .. Nb_Prim loop for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
...@@ -2680,11 +2893,7 @@ package body Exp_Disp is ...@@ -2680,11 +2893,7 @@ package body Exp_Disp is
and then not Is_Parent (Iface, Typ) and then not Is_Parent (Iface, Typ)
then then
Expand_Interface_Thunk Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Thunk_Code => Thunk_Code);
if Present (Thunk_Id) then if Present (Thunk_Id) then
Pos := Pos :=
...@@ -2733,6 +2942,16 @@ package body Exp_Disp is ...@@ -2733,6 +2942,16 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List))); Expressions => DT_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Iface_DT, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- Generate code to create the pointer to the dispatch table -- Generate code to create the pointer to the dispatch table
-- Iface_DT_Ptr : Tag := Tag!(DT'Address); -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
...@@ -2758,35 +2977,16 @@ package body Exp_Disp is ...@@ -2758,35 +2977,16 @@ package body Exp_Disp is
-- Local variables -- Local variables
-- Seems a huge list, shouldn't some of these be commented???
-- Seems like we are counting too much on guessing from names here???
Elab_Code : constant List_Id := New_List; Elab_Code : constant List_Id := New_List;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag); Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
Result : constant List_Id := New_List; Result : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ); Tname : constant Name_Id := Chars (Typ);
Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R');
Name_SSD : constant Name_Id := New_External_Name (Tname, 'S');
Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT);
Exname : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
Predef_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Predef_Prims);
SSD : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_SSD);
TSD : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_TSD);
AI : Elmt_Id; AI : Elmt_Id;
AI_Tag_Comp : Elmt_Id; AI_Tag_Comp : Elmt_Id;
AI_Ptr_Elmt : Elmt_Id; AI_Ptr_Elmt : Elmt_Id;
DT_Constr_List : List_Id; DT_Constr_List : List_Id;
DT_Aggr_List : List_Id; DT_Aggr_List : List_Id;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Has_Dispatch_Table : Boolean := True;
ITable : Node_Id; ITable : Node_Id;
I_Depth : Nat := 0; I_Depth : Nat := 0;
Iface_Table_Node : Node_Id; Iface_Table_Node : Node_Id;
...@@ -2803,137 +3003,66 @@ package body Exp_Disp is ...@@ -2803,137 +3003,66 @@ package body Exp_Disp is
Prim : Entity_Id; Prim : Entity_Id;
Prim_Elmt : Elmt_Id; Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id; Prim_Ops_Aggr_List : List_Id;
Transportable : Entity_Id;
RC_Offset_Node : Node_Id;
Suffix_Index : Int; Suffix_Index : Int;
Typ_Comps : Elist_Id; Typ_Comps : Elist_Id;
Typ_Ifaces : Elist_Id; Typ_Ifaces : Elist_Id;
TSD_Aggr_List : List_Id; TSD_Aggr_List : List_Id;
TSD_Tags_List : List_Id; TSD_Tags_List : List_Id;
TSD_Ifaces_List : List_Id;
-- The following name entries are used by Make_DT to generate a number
-- of entities related to a tagged type. These entities may be generated
-- in a scope other than that of the tagged type declaration, and if
-- the entities for two tagged types with the same name happen to be
-- generated in the same scope, we have to take care to use different
-- names. This is achieved by means of a unique serial number appended
-- to each generated entity name.
Name_DT : constant Name_Id :=
New_External_Name (Tname, 'T', Suffix_Index => -1);
Name_Exname : constant Name_Id :=
New_External_Name (Tname, 'E', Suffix_Index => -1);
Name_Predef_Prims : constant Name_Id :=
New_External_Name (Tname, 'R', Suffix_Index => -1);
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);
-- Entities built with above names
DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT);
Exname : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
Predef_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Predef_Prims);
SSD : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_SSD);
TSD : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_TSD);
-- Start of processing for Make_DT -- Start of processing for Make_DT
begin begin
-- Fill the contents of Access_Disp_Table pragma Assert (Is_Frozen (Typ));
-- 1) Generate the primary and secondary tag entities
declare
DT_Ptr : Node_Id;
Name_DT_Ptr : Name_Id;
Typ_Name : Name_Id;
Iface_DT_Ptr : Node_Id;
Suffix_Index : Int;
AI_Tag_Comp : Elmt_Id;
begin
-- Collect the components associated with secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
end if;
-- Generate the primary tag entity
Name_DT_Ptr := New_External_Name (Tname, 'P');
DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Statically_Allocated (DT_Ptr);
Set_Is_True_Constant (DT_Ptr);
pragma Assert (No (Access_Disp_Table (Typ)));
Set_Access_Disp_Table (Typ, New_Elmt_List);
Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
-- Generate the secondary tag entities
if Has_Abstract_Interfaces (Typ) then
Suffix_Index := 0;
-- 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.
AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop
Get_Secondary_DT_External_Name
(Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index);
Typ_Name := Name_Find;
Name_DT_Ptr := New_External_Name (Typ_Name, "P");
Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
Set_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Statically_Allocated (Iface_DT_Ptr);
Set_Is_True_Constant (Iface_DT_Ptr);
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
Next_Elmt (AI_Tag_Comp);
end loop;
end if;
end;
-- 2) At the end of Access_Disp_Table we add the entity of an access
-- type declaration. It is used by Build_Get_Prim_Op_Address to
-- expand dispatching calls through the primary dispatch table.
-- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Address;
-- type Typ_DT_Acc is access Typ_DT;
declare
Name_DT_Prims : constant Name_Id :=
New_External_Name (Tname, 'G');
Name_DT_Prims_Acc : constant Name_Id :=
New_External_Name (Tname, 'H');
DT_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT_Prims);
DT_Prims_Acc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_DT_Prims_Acc);
begin
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims,
Type_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Typ))))),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Reference_To (RTE (RE_Address), Loc)))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc))));
Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); -- Handle cases in which there is no need to build the dispatch table
end;
if Is_CPP_Class (Typ) then if Has_Dispatch_Table (Typ)
or else No (Access_Disp_Table (Typ))
or else Is_CPP_Class (Typ)
then
return Result; return Result;
end if;
if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then elsif No_Run_Time_Mode then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Error_Msg_CRT ("tagged types", Typ);
return Result;
elsif not RTE_Available (RE_Tag) then
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr, Defining_Identifier => Node (First_Elmt
(Access_Disp_Table (Typ))),
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Constant_Present => True, Constant_Present => True,
Expression => Expression =>
...@@ -2945,64 +3074,143 @@ package body Exp_Disp is ...@@ -2945,64 +3074,143 @@ package body Exp_Disp is
return Result; return Result;
end if; end if;
if not Static_Dispatch_Tables -- Ensure that the value of Max_Predef_Prims defined in a-tags is
or else Is_Local_DT -- correct. Valid values are 10 under configurable runtime or 15
then -- with full runtime.
Set_Ekind (DT, E_Variable);
Set_Is_Statically_Allocated (DT); if RTE_Available (RE_Interface_Data) then
if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else else
Set_Ekind (DT, E_Constant); if Max_Predef_Prims /= 10 then
Set_Is_Statically_Allocated (DT); Error_Msg_N ("run-time library configuration error", Typ);
Set_Is_True_Constant (DT); Error_Msg_CRT ("tagged types", Typ);
return Result;
end if;
end if; end if;
pragma Assert (Present (Access_Disp_Table (Typ))); -- Ensure that all the primitives are frozen. This is only required when
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); -- building static dispatch tables --- the primitives must be frozen to
-- be referenced (otherwise we have problems with the backend). It is
-- not a requirement with nonstatic dispatch tables because in this case
-- we generate now an empty dispatch table; the extra code required to
-- register the primitive in the slot will be generated later --- when
-- each primitive is frozen (see Freeze_Subprogram).
-- Ada 2005 (AI-251): Build the secondary dispatch tables if Build_Static_DT
and then not Is_CPP_Class (Typ)
then
declare
Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
Prim_Elmt : Elmt_Id;
Frnodes : List_Id;
if Has_Abstract_Interfaces (Typ) then begin
Suffix_Index := 0; Freezing_Library_Level_Tagged_Type := True;
AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
AI_Tag_Comp := First_Elmt (Typ_Comps); declare
while Present (AI_Tag_Comp) loop Subp : constant Entity_Id := Node (Prim_Elmt);
Make_Secondary_DT F : Entity_Id;
(Typ => Typ,
Iface => Base_Type
(Related_Interface (Node (AI_Tag_Comp))),
AI_Tag => Node (AI_Tag_Comp),
Iface_DT_Ptr => Node (AI_Ptr_Elmt),
Result => Result);
Suffix_Index := Suffix_Index + 1; begin
Next_Elmt (AI_Ptr_Elmt); F := First_Formal (Subp);
Next_Elmt (AI_Tag_Comp); while Present (F) loop
end loop; Check_Premature_Freezing (Subp, Etype (F));
end if; Next_Formal (F);
end loop;
Check_Premature_Freezing (Subp, Etype (Subp));
end;
if Present (Frnodes) then
Append_List_To (Result, Frnodes);
end if;
Next_Elmt (Prim_Elmt);
end loop;
Freezing_Library_Level_Tagged_Type := Save;
end;
end if;
-- Evaluate if we generate the dispatch table -- In case of locally defined tagged type we declare the object
-- contanining the dispatch table by means of a variable. Its
-- initialization is done later by means of an assignment. This is
-- required to generate its External_Tag.
if not Build_Static_DT then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
Set_Ekind (DT, E_Variable);
-- Export the declaration of the tag previously generated and imported
-- by Make_Tags.
else
DT_Ptr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Tname, 'C', Suffix_Index => -1));
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Statically_Allocated (DT_Ptr);
Set_Is_True_Constant (DT_Ptr);
Set_Is_Exported (DT_Ptr);
Get_External_Name (Node (First_Elmt (Access_Disp_Table (Typ))), True);
Set_Interface_Name (DT_Ptr,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Set tag as internal to ensure proper Sprint output of its implicit
-- exportation.
Set_Is_Internal (DT_Ptr);
Set_Ekind (DT, E_Constant);
Set_Is_True_Constant (DT);
-- The tag is made public to ensure its availability to the linker
-- (to handle the forward reference). This is required to handle
-- tagged types defined in library level package bodies.
Set_Is_Public (DT_Ptr);
end if;
Set_Is_Statically_Allocated (DT);
-- Ada 2005 (AI-251): Build the secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
Suffix_Index := 0;
AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type
(Related_Interface (Node (AI_Tag_Comp))),
AI_Tag => Node (AI_Tag_Comp),
Iface_DT_Ptr => Node (AI_Ptr_Elmt),
Result => Result);
Has_Dispatch_Table := Suffix_Index := Suffix_Index + 1;
not Is_Interface (Typ) Next_Elmt (AI_Ptr_Elmt);
and then not Restriction_Active (No_Dispatching_Calls); Next_Elmt (AI_Tag_Comp);
end loop;
end if;
-- Calculate the number of primitives of the dispatch table and the -- Calculate the number of primitives of the dispatch table and the
-- size of the Type_Specific_Data record. -- size of the Type_Specific_Data record.
if Has_Dispatch_Table then if Has_DT then
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
end if; end if;
if not Static_Dispatch_Tables then
Set_Ekind (Predef_Prims, E_Variable);
Set_Is_Statically_Allocated (Predef_Prims);
else
Set_Ekind (Predef_Prims, E_Constant);
Set_Is_Statically_Allocated (Predef_Prims);
Set_Is_True_Constant (Predef_Prims);
end if;
Set_Ekind (SSD, E_Constant); Set_Ekind (SSD, E_Constant);
Set_Is_Statically_Allocated (SSD); Set_Is_Statically_Allocated (SSD);
Set_Is_True_Constant (SSD); Set_Is_True_Constant (SSD);
...@@ -3020,7 +3228,7 @@ package body Exp_Disp is ...@@ -3020,7 +3228,7 @@ package body Exp_Disp is
-- multiple-called scopes. -- multiple-called scopes.
if not Is_Interface (Typ) then if not Is_Interface (Typ) then
Name_No_Reg := New_External_Name (Tname, 'F'); Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1);
No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg);
Set_Ekind (No_Reg, E_Variable); Set_Ekind (No_Reg, E_Variable);
...@@ -3038,13 +3246,14 @@ package body Exp_Disp is ...@@ -3038,13 +3246,14 @@ package body Exp_Disp is
-- initialization is done later by means of an assignment. This is -- initialization is done later by means of an assignment. This is
-- required to generate its External_Tag. -- required to generate its External_Tag.
if Is_Local_DT then if not Build_Static_DT then
-- Generate: -- Generate:
-- DT : No_Dispatch_Table_Wrapper; -- DT : No_Dispatch_Table_Wrapper;
-- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
if not Has_Dispatch_Table then if not Has_DT then
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT, Defining_Identifier => DT,
...@@ -3055,6 +3264,16 @@ package body Exp_Disp is ...@@ -3055,6 +3264,16 @@ package body Exp_Disp is
(RTE (RE_No_Dispatch_Table_Wrapper), Loc))); (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
Append_To (Result, Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr, Defining_Identifier => DT_Ptr,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
...@@ -3187,36 +3406,24 @@ package body Exp_Disp is ...@@ -3187,36 +3406,24 @@ package body Exp_Disp is
end; end;
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Make_Component_Association (Loc, Make_Integer_Literal (Loc, I_Depth));
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
Expression =>
Make_Integer_Literal (Loc, I_Depth)));
-- Access_Level -- Access_Level
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Make_Component_Association (Loc, Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
Expression =>
Make_Integer_Literal (Loc, Type_Access_Level (Typ))));
-- Expanded_Name -- Expanded_Name
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Make_Component_Association (Loc, Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Choices => New_List ( Make_Attribute_Reference (Loc,
New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)), Prefix => New_Reference_To (Exname, Loc),
Expression => Attribute_Name => Name_Address)));
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
-- External_Tag of a local tagged type -- External_Tag of a local tagged type
-- Exname : constant String := -- <typ>A : constant String :=
-- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
-- The reason we generate this strange name is that we do not want to -- The reason we generate this strange name is that we do not want to
...@@ -3237,63 +3444,42 @@ package body Exp_Disp is ...@@ -3237,63 +3444,42 @@ package body Exp_Disp is
-- in scope, but it clearly must be erroneous to compute the internal -- in scope, but it clearly must be erroneous to compute the internal
-- tag of a tagged type that is out of scope! -- tag of a tagged type that is out of scope!
if Is_Local_DT then -- We don't do this processing if an explicit external tag has been
-- specified. That's an odd case for which we have already issued a
-- warning, where we will not be able to compute the internal tag.
if not Is_Library_Level_Entity (Typ)
and then not Has_External_Tag_Rep_Clause (Typ)
then
declare declare
Name_Exname : constant Name_Id := New_External_Name (Tname, 'L');
Name_Str1 : constant Name_Id := New_Internal_Name ('I');
Name_Str2 : constant Name_Id := New_Internal_Name ('I');
Name_Str3 : constant Name_Id := New_Internal_Name ('I');
Exname : constant Entity_Id := Exname : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Exname); Make_Defining_Identifier (Loc,
Str1 : constant Entity_Id := New_External_Name (Tname, 'A'));
Make_Defining_Identifier (Loc, Name_Str1);
Str2 : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Str2);
Str3 : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Str3);
Full_Name : constant String_Id := Full_Name : constant String_Id :=
Full_Qualified_Name (First_Subtype (Typ)); Full_Qualified_Name (First_Subtype (Typ));
Str1_Id : String_Id; Str1_Id : String_Id;
Str2_Id : String_Id; Str2_Id : String_Id;
Str3_Id : String_Id;
begin begin
-- Generate: -- Generate:
-- Str1 : constant String := "Internal tag at 16#"; -- Str1 = "Internal tag at 16#";
Set_Ekind (Str1, E_Constant);
Set_Is_Statically_Allocated (Str1);
Set_Is_True_Constant (Str1);
Start_String; Start_String;
Store_String_Chars ("Internal tag at 16#"); Store_String_Chars ("Internal tag at 16#");
Str1_Id := End_String; Str1_Id := End_String;
-- Generate: -- Generate:
-- Str2 : constant String := "#: "; -- Str2 = "#: <type-full-name>";
Set_Ekind (Str2, E_Constant);
Set_Is_Statically_Allocated (Str2);
Set_Is_True_Constant (Str2);
Start_String; Start_String;
Store_String_Chars ("#: "); Store_String_Chars ("#: ");
Str2_Id := End_String;
-- Generate:
-- Str3 : constant String := <full-name-of-typ>;
Set_Ekind (Str3, E_Constant);
Set_Is_Statically_Allocated (Str3);
Set_Is_True_Constant (Str3);
Start_String;
Store_String_Chars (Full_Name); Store_String_Chars (Full_Name);
Str3_Id := End_String; Str2_Id := End_String;
-- Generate: -- Generate:
-- Exname : constant String := -- Exname : constant String :=
-- Str1 & Address_Image (Tag) & Str2 & Str3; -- Str1 & Address_Image (Tag) & Str2;
if RTE_Available (RE_Address_Image) then if RTE_Available (RE_Address_Image) then
Append_To (Result, Append_To (Result,
...@@ -3317,11 +3503,8 @@ package body Exp_Disp is ...@@ -3317,11 +3503,8 @@ package body Exp_Disp is
Unchecked_Convert_To (RTE (RE_Address), Unchecked_Convert_To (RTE (RE_Address),
New_Reference_To (DT_Ptr, Loc)))), New_Reference_To (DT_Ptr, Loc)))),
Right_Opnd => Right_Opnd =>
Make_Op_Concat (Loc, Make_String_Literal (Loc, Str2_Id)))));
Left_Opnd =>
Make_String_Literal (Loc, Str2_Id),
Right_Opnd =>
Make_String_Literal (Loc, Str3_Id))))));
else else
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -3334,11 +3517,7 @@ package body Exp_Disp is ...@@ -3334,11 +3517,7 @@ package body Exp_Disp is
Left_Opnd => Left_Opnd =>
Make_String_Literal (Loc, Str1_Id), Make_String_Literal (Loc, Str1_Id),
Right_Opnd => Right_Opnd =>
Make_Op_Concat (Loc, Make_String_Literal (Loc, Str2_Id))));
Left_Opnd =>
Make_String_Literal (Loc, Str2_Id),
Right_Opnd =>
Make_String_Literal (Loc, Str3_Id)))));
end if; end if;
New_Node := New_Node :=
...@@ -3372,11 +3551,12 @@ package body Exp_Disp is ...@@ -3372,11 +3551,12 @@ package body Exp_Disp is
else else
Old_Val := Strval (Expr_Value_S (Expression (Def))); Old_Val := Strval (Expr_Value_S (Expression (Def)));
-- For the rep clause "for x'external_tag use y" generate: -- For the rep clause "for <typ>'external_tag use y" generate:
-- xV : constant string := y; -- <typ>A : constant string := y;
-- Set_External_Tag (x'tag, xV'Address); --
-- Register_Tag (x'tag); -- <typ>A'Address is used to set the External_Tag component
-- of the TSD
-- Create a new nul terminated string if it is not already -- Create a new nul terminated string if it is not already
...@@ -3412,43 +3592,34 @@ package body Exp_Disp is ...@@ -3412,43 +3592,34 @@ package body Exp_Disp is
end; end;
end if; end if;
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List, New_Node);
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_External_Tag), Loc)),
Expression => New_Node));
-- HT_Link -- HT_Link
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Make_Component_Association (Loc, Unchecked_Convert_To (RTE (RE_Tag),
Choices => New_List ( New_Reference_To (RTE (RE_Null_Address), Loc)));
New_Occurrence_Of
(RTE_Record_Component (RE_HT_Link), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc))));
-- Transportable: Set for types that can be used in remote calls -- Transportable: Set for types that can be used in remote calls
-- with respect to E.4(18) legality rules. -- with respect to E.4(18) legality rules.
Transportable := declare
Boolean_Literals Transportable : Entity_Id;
(Is_Pure (Typ)
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ)
or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
Append_To (TSD_Aggr_List, begin
Make_Component_Association (Loc, Transportable :=
Choices => New_List ( Boolean_Literals
New_Occurrence_Of (Is_Pure (Typ)
(RTE_Record_Component (RE_Transportable), Loc)), or else Is_Shared_Passive (Typ)
Expression => New_Occurrence_Of (Transportable, Loc))); or else
((Is_Remote_Types (Typ)
or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
Append_To (TSD_Aggr_List,
New_Occurrence_Of (Transportable, Loc));
end;
-- RC_Offset: These are the valid values and their meaning: -- RC_Offset: These are the valid values and their meaning:
...@@ -3465,47 +3636,48 @@ package body Exp_Disp is ...@@ -3465,47 +3636,48 @@ package body Exp_Disp is
-- -2: There are no controlled components at this level. We need to -- -2: There are no controlled components at this level. We need to
-- get the position from the parent. -- get the position from the parent.
if not Has_Controlled_Component (Typ) then declare
RC_Offset_Node := Make_Integer_Literal (Loc, 0); RC_Offset_Node : Node_Id;
elsif Etype (Typ) /= Typ begin
and then Has_Discriminants (Etype (Typ)) if not Has_Controlled_Component (Typ) then
then RC_Offset_Node := Make_Integer_Literal (Loc, 0);
if Has_New_Controlled_Component (Typ) then
RC_Offset_Node := Make_Integer_Literal (Loc, -1); elsif Etype (Typ) /= Typ
and then Has_Discriminants (Etype (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 else
RC_Offset_Node := Make_Integer_Literal (Loc, -2); 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; 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, Append_To (TSD_Aggr_List, RC_Offset_Node);
Make_Component_Association (Loc, end;
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
Expression => RC_Offset_Node));
-- Interfaces_Table (required for AI-405) -- Interfaces_Table (required for AI-405)
...@@ -3527,98 +3699,86 @@ package body Exp_Disp is ...@@ -3527,98 +3699,86 @@ package body Exp_Disp is
-- Generate the Interface_Table object -- Generate the Interface_Table object
else else
TSD_Ifaces_List := New_List;
declare declare
Pos : Nat := 1; TSD_Ifaces_List : constant List_Id := New_List;
Aggr_List : List_Id;
begin begin
AI := First_Elmt (Typ_Ifaces); AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop while Present (AI) loop
Aggr_List := New_List ( Append_To (TSD_Ifaces_List,
Make_Component_Association (Loc, Make_Aggregate (Loc,
Choices => New_List ( Expressions => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Iface_Tag), Loc)), -- Iface_Tag
Expression =>
Unchecked_Convert_To (Generalized_Tag, Unchecked_Convert_To (Generalized_Tag,
New_Reference_To New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Node (AI)))), (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
Loc))), Loc)),
Make_Component_Association (Loc, -- Static_Offset_To_Top
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Static_Offset_To_Top),
Loc)),
Expression =>
New_Reference_To (Standard_True, Loc)),
Make_Component_Association (Loc, New_Reference_To (Standard_True, Loc),
Choices => New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True));
Append_To (TSD_Ifaces_List, -- Offset_To_Top_Value
Make_Component_Association (Loc,
Choices => New_List ( Make_Integer_Literal (Loc, 0),
Make_Integer_Literal (Loc, Pos)),
Expression => Make_Aggregate (Loc, -- Offset_To_Top_Func
Component_Associations => Aggr_List)));
Make_Null (Loc))));
Pos := Pos + 1;
Next_Elmt (AI); Next_Elmt (AI);
end loop; end loop;
end;
Name_ITable := New_External_Name (Tname, 'I'); Name_ITable := New_External_Name (Tname, 'I');
ITable := Make_Defining_Identifier (Loc, Name_ITable); ITable := Make_Defining_Identifier (Loc, Name_ITable);
Set_Is_Statically_Allocated (ITable);
Set_Ekind (ITable, E_Constant); -- The table of interfaces is not constant; its slots are
Set_Is_Statically_Allocated (ITable); -- filled at run-time by the IP routine using attribute
Set_Is_True_Constant (ITable); -- 'Position to know the location of the tag components
-- (and this attribute cannot be safely used before the
-- object is initialized).
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => ITable, Defining_Identifier => ITable,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Constant_Present => False,
Make_Subtype_Indication (Loc, Object_Definition =>
Subtype_Mark => Make_Subtype_Indication (Loc,
New_Reference_To (RTE (RE_Interface_Data), Loc), Subtype_Mark =>
Constraint => Make_Index_Or_Discriminant_Constraint (Loc, New_Reference_To (RTE (RE_Interface_Data), Loc),
Constraints => New_List ( Constraint => Make_Index_Or_Discriminant_Constraint
Make_Integer_Literal (Loc, Num_Ifaces)))), (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Num_Ifaces)))),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Component_Associations => New_List ( Expressions => New_List (
Make_Component_Association (Loc, Make_Integer_Literal (Loc, Num_Ifaces),
Choices => New_List ( Make_Aggregate (Loc,
New_Occurrence_Of Expressions => TSD_Ifaces_List)))));
(RTE_Record_Component (RE_Nb_Ifaces), Loc)),
Expression =>
Make_Integer_Literal (Loc, Num_Ifaces)),
Make_Component_Association (Loc, Append_To (Result,
Choices => New_List ( Make_Attribute_Definition_Clause (Loc,
New_Occurrence_Of Name => New_Reference_To (ITable, Loc),
(RTE_Record_Component (RE_Ifaces_Table), Loc)), Chars => Name_Alignment,
Expression => Make_Aggregate (Loc, Expression =>
Component_Associations => TSD_Ifaces_List)))))); Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Iface_Table_Node := Iface_Table_Node :=
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (ITable, Loc), Prefix => New_Reference_To (ITable, Loc),
Attribute_Name => Name_Unchecked_Access); Attribute_Name => Name_Unchecked_Access);
end;
end if; end if;
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List, Iface_Table_Node);
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Interfaces_Table), Loc)),
Expression => Iface_Table_Node));
end if; end if;
-- Generate the Select Specific Data table for synchronized types that -- Generate the Select Specific Data table for synchronized types that
...@@ -3627,7 +3787,7 @@ package body Exp_Disp is ...@@ -3627,7 +3787,7 @@ package body Exp_Disp is
if RTE_Record_Component_Available (RE_SSD) then if RTE_Record_Component_Available (RE_SSD) then
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Has_Dispatch_Table and then Has_DT
and then Is_Concurrent_Record_Type (Typ) and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ) and then Has_Abstract_Interfaces (Typ)
and then Nb_Prim > 0 and then Nb_Prim > 0
...@@ -3648,110 +3808,127 @@ package body Exp_Disp is ...@@ -3648,110 +3808,127 @@ package body Exp_Disp is
Constraints => New_List ( Constraints => New_List (
Make_Integer_Literal (Loc, Nb_Prim)))))); Make_Integer_Literal (Loc, Nb_Prim))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (SSD, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- This table is initialized by Make_Select_Specific_Data_Table, -- This table is initialized by Make_Select_Specific_Data_Table,
-- which calls Set_Entry_Index and Set_Prim_Op_Kind. -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Make_Component_Association (Loc, Make_Attribute_Reference (Loc,
Choices => New_List ( Prefix => New_Reference_To (SSD, Loc),
New_Occurrence_Of Attribute_Name => Name_Unchecked_Access));
(RTE_Record_Component (RE_SSD), Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Unchecked_Access)));
else else
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List, Make_Null (Loc));
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_SSD), Loc)),
Expression => Make_Null (Loc)));
end if; end if;
end if; end if;
-- Initialize the table of ancestor tags. In case of interface types -- Initialize the table of ancestor tags. In case of interface types
-- this table is not needed. -- this table is not needed.
if Is_Interface (Typ) then declare
Append_To (TSD_Aggr_List, Current_Typ : Entity_Id;
Make_Component_Association (Loc, Parent_Typ : Entity_Id;
Choices => New_List (Make_Others_Choice (Loc)), Pos : Nat;
Expression => Empty,
Box_Present => True));
else
declare
Current_Typ : Entity_Id;
Parent_Typ : Entity_Id;
Pos : Nat;
begin begin
TSD_Tags_List := New_List; TSD_Tags_List := New_List;
-- Fill position 0 with null because we still have not generated -- If we are not statically allocating the dispatch table then we
-- the tag of Typ. -- must fill position 0 with null because we still have not
-- generated the tag of Typ.
if not Build_Static_DT
or else Is_Interface (Typ)
then
Append_To (TSD_Tags_List, Append_To (TSD_Tags_List,
Make_Component_Association (Loc, Unchecked_Convert_To (RTE (RE_Tag),
Choices => New_List ( New_Reference_To (RTE (RE_Null_Address), Loc)));
Make_Integer_Literal (Loc, 0)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc))));
-- Fill the rest of the table with the tags of the ancestors -- Otherwise we can safely import the tag. The name must be unique
-- over the compilation unit, to avoid conflicts when types of the
-- same name appear in different nested packages. We don't need to
-- use an external name because this name is only locally used.
Pos := 1; else
Current_Typ := Typ; declare
Imported_DT_Ptr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('D'));
loop begin
Parent_Typ := Etype (Current_Typ); Set_Is_Imported (Imported_DT_Ptr);
Set_Is_Statically_Allocated (Imported_DT_Ptr);
Set_Is_True_Constant (Imported_DT_Ptr);
Get_External_Name
(Node (First_Elmt (Access_Disp_Table (Typ))), True);
Set_Interface_Name (Imported_DT_Ptr,
Make_String_Literal (Loc, String_From_Name_Buffer));
if Is_Private_Type (Parent_Typ) then -- Set tag as internal to ensure proper Sprint output of its
Parent_Typ := Full_View (Base_Type (Parent_Typ)); -- implicit importation.
end if;
exit when Parent_Typ = Current_Typ; Set_Is_Internal (Imported_DT_Ptr);
if Is_CPP_Class (Parent_Typ) then Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Imported_DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag),
Loc)));
-- The tags defined in the C++ side will be inherited when Append_To (TSD_Tags_List,
-- the object is constructed. New_Reference_To (Imported_DT_Ptr, Loc));
-- (see Exp_Ch3.Build_Init_Procedure) end;
end if;
Append_To (TSD_Tags_List, -- Fill the rest of the table with the tags of the ancestors
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Pos)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc))));
else
Append_To (TSD_Tags_List,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Pos)),
Expression =>
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
Loc)));
end if;
Pos := Pos + 1; Pos := 1;
Current_Typ := Parent_Typ; Current_Typ := Typ;
end loop;
pragma Assert (Pos = I_Depth + 1); loop
end; Parent_Typ := Etype (Current_Typ);
Append_To (TSD_Aggr_List, if Is_Private_Type (Parent_Typ) then
Make_Component_Association (Loc, Parent_Typ := Full_View (Base_Type (Parent_Typ));
Choices => New_List ( end if;
New_Occurrence_Of
(RTE_Record_Component (RE_Tags_Table), Loc)), exit when Parent_Typ = Current_Typ;
Expression => Make_Aggregate (Loc,
Component_Associations => TSD_Tags_List))); if Is_CPP_Class (Parent_Typ)
end if; or else Is_Interface (Typ)
then
-- The tags defined in the C++ side will be inherited when
-- the object is constructed (Exp_Ch3.Build_Init_Procedure)
Append_To (TSD_Tags_List,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)));
else
Append_To (TSD_Tags_List,
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
Loc));
end if;
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 -- Build the TSD object
...@@ -3759,6 +3936,7 @@ package body Exp_Disp is ...@@ -3759,6 +3936,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => TSD, Defining_Identifier => TSD,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Build_Static_DT,
Object_Definition => Object_Definition =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To ( Subtype_Mark => New_Reference_To (
...@@ -3769,7 +3947,7 @@ package body Exp_Disp is ...@@ -3769,7 +3947,7 @@ package body Exp_Disp is
Make_Integer_Literal (Loc, I_Depth)))), Make_Integer_Literal (Loc, I_Depth)))),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Component_Associations => TSD_Aggr_List))); Expressions => TSD_Aggr_List)));
Append_To (Result, Append_To (Result,
Make_Attribute_Definition_Clause (Loc, Make_Attribute_Definition_Clause (Loc,
...@@ -3786,8 +3964,9 @@ package body Exp_Disp is ...@@ -3786,8 +3964,9 @@ package body Exp_Disp is
-- DT : No_Dispatch_Table := -- DT : No_Dispatch_Table :=
-- (NDT_TSD => TSD'Address; -- (NDT_TSD => TSD'Address;
-- NDT_Prims_Ptr => 0); -- NDT_Prims_Ptr => 0);
-- for DT'Alignment use Address'Alignment
if not Has_Dispatch_Table then if not Has_DT then
DT_Constr_List := New_List; DT_Constr_List := New_List;
DT_Aggr_List := New_List; DT_Aggr_List := New_List;
...@@ -3806,7 +3985,7 @@ package body Exp_Disp is ...@@ -3806,7 +3985,7 @@ package body Exp_Disp is
-- and uninitialized object for the dispatch table, which is now -- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment. -- initialized by means of an assignment.
if Is_Local_DT then if not Build_Static_DT then
Append_To (Result, Append_To (Result,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc), Name => New_Reference_To (DT, Loc),
...@@ -3821,13 +4000,23 @@ package body Exp_Disp is ...@@ -3821,13 +4000,23 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT, Defining_Identifier => DT,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Static_Dispatch_Tables, Constant_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List))); Expressions => DT_Aggr_List)));
Append_To (Result, Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr, Defining_Identifier => DT_Ptr,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
...@@ -3865,13 +4054,14 @@ package body Exp_Disp is ...@@ -3865,13 +4054,14 @@ package body Exp_Disp is
-- prim-op-2'address, -- prim-op-2'address,
-- ... -- ...
-- prim-op-n'address)); -- prim-op-n'address));
-- for DT'Alignment use Address'Alignment
else else
declare declare
Pos : Nat; Pos : Nat;
begin begin
if not Static_Dispatch_Tables then if not Build_Static_DT then
Nb_Predef_Prims := Max_Predef_Prims; Nb_Predef_Prims := Max_Predef_Prims;
else else
...@@ -3902,11 +4092,12 @@ package body Exp_Disp is ...@@ -3902,11 +4092,12 @@ package body Exp_Disp is
Prim_Ops_Aggr_List := New_List; Prim_Ops_Aggr_List := New_List;
Prim_Table := (others => Empty); Prim_Table := (others => Empty);
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
if Static_Dispatch_Tables if Build_Static_DT
and then Is_Predefined_Dispatching_Operation (Prim) and then Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Abstract_Subprogram (Prim) and then not Is_Abstract_Subprogram (Prim)
and then not Present (Prim_Table and then not Present (Prim_Table
...@@ -3941,7 +4132,7 @@ package body Exp_Disp is ...@@ -3941,7 +4132,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims, Defining_Identifier => Predef_Prims,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Static_Dispatch_Tables, Constant_Present => Build_Static_DT,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc), New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc, Expression => Make_Aggregate (Loc,
...@@ -4017,7 +4208,7 @@ package body Exp_Disp is ...@@ -4017,7 +4208,7 @@ package body Exp_Disp is
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
elsif not Static_Dispatch_Tables then elsif not Build_Static_DT then
for J in 1 .. Nb_Prim loop for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc)); New_Reference_To (RTE (RE_Null_Address), Loc));
...@@ -4059,10 +4250,6 @@ package body Exp_Disp is ...@@ -4059,10 +4250,6 @@ package body Exp_Disp is
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim); (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
Prim_Table (UI_To_Int (DT_Position (Prim))) := E; Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
-- There is no need to set Has_Delayed_Freeze here
-- because the analysis of 'Address and 'Code_Address
-- takes care of it.
end if; end if;
end if; end if;
...@@ -4092,7 +4279,7 @@ package body Exp_Disp is ...@@ -4092,7 +4279,7 @@ package body Exp_Disp is
-- and uninitialized object for the dispatch table, which is now -- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment. -- initialized by means of an assignment.
if Is_Local_DT then if not Build_Static_DT then
Append_To (Result, Append_To (Result,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc), Name => New_Reference_To (DT, Loc),
...@@ -4107,7 +4294,7 @@ package body Exp_Disp is ...@@ -4107,7 +4294,7 @@ package body Exp_Disp is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => DT, Defining_Identifier => DT,
Aliased_Present => True, Aliased_Present => True,
Constant_Present => Static_Dispatch_Tables, Constant_Present => True,
Object_Definition => Object_Definition =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To Subtype_Mark => New_Reference_To
...@@ -4147,7 +4334,8 @@ package body Exp_Disp is ...@@ -4147,7 +4334,8 @@ package body Exp_Disp is
-- Initialize the table of ancestor tags -- Initialize the table of ancestor tags
if not Is_Interface (Typ) if not Build_Static_DT
and then not Is_Interface (Typ)
and then not Is_CPP_Class (Typ) and then not Is_CPP_Class (Typ)
then then
Append_To (Result, Append_To (Result,
...@@ -4169,7 +4357,7 @@ package body Exp_Disp is ...@@ -4169,7 +4357,7 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if; end if;
if Static_Dispatch_Tables then if Build_Static_DT then
null; null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables -- If the ancestor is a CPP_Class type we inherit the dispatch tables
...@@ -4225,6 +4413,7 @@ package body Exp_Disp is ...@@ -4225,6 +4413,7 @@ package body Exp_Disp is
if Nb_Prims /= 0 then if Nb_Prims /= 0 then
Append_To (Elab_Code, Append_To (Elab_Code,
Build_Inherit_Prims (Loc, Build_Inherit_Prims (Loc,
Typ => Typ,
Old_Tag_Node => Old_Tag2, Old_Tag_Node => Old_Tag2,
New_Tag_Node => New_Reference_To (DT_Ptr, Loc), New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Num_Prims => Nb_Prims)); Num_Prims => Nb_Prims));
...@@ -4304,6 +4493,7 @@ package body Exp_Disp is ...@@ -4304,6 +4493,7 @@ package body Exp_Disp is
if Num_Prims /= 0 then if Num_Prims /= 0 then
Append_To (Elab_Code, Append_To (Elab_Code,
Build_Inherit_Prims (Loc, Build_Inherit_Prims (Loc,
Typ => Node (Iface),
Old_Tag_Node => Old_Tag_Node =>
Unchecked_Convert_To Unchecked_Convert_To
(RTE (RE_Tag), (RTE (RE_Tag),
...@@ -4315,7 +4505,7 @@ package body Exp_Disp is ...@@ -4315,7 +4505,7 @@ package body Exp_Disp is
(RTE (RE_Tag), (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Sec_DT_Typ), Loc)), (Node (Sec_DT_Typ), Loc)),
Num_Prims => Num_Prims)); Num_Prims => Num_Prims));
end if; end if;
end; end;
end if; end if;
...@@ -4370,7 +4560,7 @@ package body Exp_Disp is ...@@ -4370,7 +4560,7 @@ package body Exp_Disp is
if not Is_Interface (Typ) then if not Is_Interface (Typ) then
if not No_Run_Time_Mode if not No_Run_Time_Mode
and then not Is_Local_DT and then Is_Library_Level_Entity (Typ)
and then RTE_Available (RE_Register_Tag) and then RTE_Available (RE_Register_Tag)
then then
Append_To (Elab_Code, Append_To (Elab_Code,
...@@ -4391,7 +4581,21 @@ package body Exp_Disp is ...@@ -4391,7 +4581,21 @@ package body Exp_Disp is
Then_Statements => Elab_Code)); Then_Statements => Elab_Code));
end if; end if;
-- Populate the two auxiliary tables used for dispatching
-- asynchronous, conditional and timed selects for synchronized
-- types that implement a limited interface.
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));
end if;
Analyze_List (Result, Suppress => All_Checks); Analyze_List (Result, Suppress => All_Checks);
Set_Has_Dispatch_Table (Typ);
return Result; return Result;
end Make_DT; end Make_DT;
...@@ -4459,6 +4663,10 @@ package body Exp_Disp is ...@@ -4459,6 +4663,10 @@ package body Exp_Disp is
if Present (Corresponding_Concurrent_Type (Typ)) then if Present (Corresponding_Concurrent_Type (Typ)) then
Conc_Typ := Corresponding_Concurrent_Type (Typ); 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 if Ekind (Conc_Typ) = E_Protected_Type then
Decls := Visible_Declarations (Protected_Definition ( Decls := Visible_Declarations (Protected_Definition (
Parent (Conc_Typ))); Parent (Conc_Typ)));
...@@ -4549,6 +4757,159 @@ package body Exp_Disp is ...@@ -4549,6 +4757,159 @@ package body Exp_Disp is
return Assignments; return Assignments;
end Make_Select_Specific_Data_Table; end Make_Select_Specific_Data_Table;
---------------
-- Make_Tags --
---------------
function Make_Tags (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Build_Static_DT : constant Boolean :=
Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ);
Tname : constant Name_Id := Chars (Typ);
Result : constant List_Id := New_List;
AI_Tag_Comp : Elmt_Id;
DT_Ptr : Node_Id;
Iface_DT_Ptr : Node_Id;
Suffix_Index : Int;
Typ_Name : Name_Id;
Typ_Comps : Elist_Id;
begin
-- 1) Generate the primary and secondary tag entities
-- Collect the components associated with secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
end if;
-- 1) Generate the primary tag entity
DT_Ptr := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'P'));
Set_Etype (DT_Ptr, RTE (RE_Tag));
Set_Ekind (DT_Ptr, E_Variable);
-- Import the forward declaration of the tag (Make_DT will take care of
-- its exportation)
if Build_Static_DT then
Set_Is_Imported (DT_Ptr);
Set_Is_True_Constant (DT_Ptr);
Set_Scope (DT_Ptr, Current_Scope);
Get_External_Name (DT_Ptr, True);
Set_Interface_Name (DT_Ptr,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Set tag entity as internal to ensure proper Sprint output of its
-- implicit importation.
Set_Is_Internal (DT_Ptr);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
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));
-- 2) Generate the secondary tag entities
if Has_Abstract_Interfaces (Typ) then
Suffix_Index := 0;
-- 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.
AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop
Get_Secondary_DT_External_Name
(Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index);
Typ_Name := Name_Find;
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_Statically_Allocated (Iface_DT_Ptr);
Set_Is_True_Constant (Iface_DT_Ptr);
Set_Related_Interface
(Iface_DT_Ptr, Related_Interface (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
Next_Elmt (AI_Tag_Comp);
end loop;
end if;
-- 3) At the end of Access_Disp_Table we add the entity of an access
-- type declaration. It is used by Build_Get_Prim_Op_Address to
-- expand dispatching calls through the primary dispatch table.
-- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Address;
-- type Typ_DT_Acc is access Typ_DT;
declare
Name_DT_Prims : constant Name_Id :=
New_External_Name (Tname, 'G');
Name_DT_Prims_Acc : constant Name_Id :=
New_External_Name (Tname, 'H');
DT_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT_Prims);
DT_Prims_Acc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_DT_Prims_Acc);
begin
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims,
Type_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Typ))))),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Reference_To (RTE (RE_Address), Loc)))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc))));
Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
-- Analyze the resulting list and suppress the generation of the
-- Init_Proc associated with the above array declaration because
-- we never use such type in object declarations; this type is only
-- used to simplify the expansion associated with dispatching calls.
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
end;
return Result;
end Make_Tags;
----------------------------------- -----------------------------------
-- Original_View_In_Visible_Part -- -- Original_View_In_Visible_Part --
----------------------------------- -----------------------------------
...@@ -4730,15 +5091,15 @@ package body Exp_Disp is ...@@ -4730,15 +5091,15 @@ package body Exp_Disp is
pragma Assert (Is_Interface (Iface_Typ)); pragma Assert (Is_Interface (Iface_Typ));
Expand_Interface_Thunk Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Thunk_Code => Thunk_Code);
if not Is_Parent (Iface_Typ, Typ) if not Is_Parent (Iface_Typ, Typ)
and then Present (Thunk_Code) and then Present (Thunk_Code)
then then
-- Comment needed on why checks are suppressed. This is not just
-- efficiency, but fundamental functionality (see 1.295 RH, which
-- still does not answer this question) ???
Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
-- Generate the code necessary to fill the appropriate entry of -- Generate the code necessary to fill the appropriate entry of
...@@ -5075,6 +5436,7 @@ package body Exp_Disp is ...@@ -5075,6 +5436,7 @@ package body Exp_Disp is
elsif not Present (Abstract_Interface_Alias (Prim)) elsif not Present (Abstract_Interface_Alias (Prim))
and then Present (Alias (Prim)) and then Present (Alias (Prim))
and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Parent and then Is_Parent
(Find_Dispatching_Type (Alias (Prim)), Typ) (Find_Dispatching_Type (Alias (Prim)), Typ)
...@@ -5245,7 +5607,7 @@ package body Exp_Disp is ...@@ -5245,7 +5607,7 @@ package body Exp_Disp is
then then
Error_Msg_NE Error_Msg_NE
("abstract inherited private operation&" & ("abstract inherited private operation&" &
" must be overridden ('R'M 3.9.3(10))", " must be overridden (RM 3.9.3(10))",
Parent (Typ), Prim); Parent (Typ), Prim);
end if; end if;
end if; end if;
...@@ -5384,6 +5746,10 @@ package body Exp_Disp is ...@@ -5384,6 +5746,10 @@ package body Exp_Disp is
elsif Is_Concurrent_Record_Type (T) then elsif Is_Concurrent_Record_Type (T) then
Conc_Typ := Corresponding_Concurrent_Type (T); Conc_Typ := Corresponding_Concurrent_Type (T);
if Present (Full_View (Conc_Typ)) then
Conc_Typ := Full_View (Conc_Typ);
end if;
if Ekind (Conc_Typ) = E_Protected_Type then if Ekind (Conc_Typ) = E_Protected_Type then
return New_Reference_To (RTE (RE_TK_Protected), Loc); return New_Reference_To (RTE (RE_TK_Protected), Loc);
else else
...@@ -5414,7 +5780,7 @@ package body Exp_Disp is ...@@ -5414,7 +5780,7 @@ package body Exp_Disp is
-- Protect this procedure against wrong usage. Required because it will -- Protect this procedure against wrong usage. Required because it will
-- be used directly from GDB -- be used directly from GDB
if not (Typ in First_Node_Id .. Last_Node_Id) if not (Typ <= Last_Node_Id)
or else not Is_Tagged_Type (Typ) or else not Is_Tagged_Type (Typ)
then then
Write_Str ("wrong usage: Write_DT must be used with tagged types"); Write_Str ("wrong usage: Write_DT must be used with tagged types");
......
gcc/ada/exp_disp.ads
...@@ -122,11 +122,11 @@ package Exp_Disp is ...@@ -122,11 +122,11 @@ package Exp_Disp is
-- PPOs are collected and added to the Primitive_Operations list of -- PPOs are collected and added to the Primitive_Operations list of
-- a type by the regular analysis mechanism. -- a type by the regular analysis mechanism.
-- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze. -- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze
-- Thunks for PPOs are created by Make_DT. -- Thunks for PPOs are created by Make_DT
-- Dispatch table positions of PPOs are set by Set_All_DT_Position. -- Dispatch table positions of PPOs are set by Set_All_DT_Position
-- Calls to PPOs proceed as regular dispatching calls. If the PPO -- Calls to PPOs proceed as regular dispatching calls. If the PPO
-- has a thunk, a call proceeds as a regular dispatching call with -- has a thunk, a call proceeds as a regular dispatching call with
...@@ -134,8 +134,8 @@ package Exp_Disp is ...@@ -134,8 +134,8 @@ package Exp_Disp is
-- Guidelines for addition of new predefined primitive operations -- Guidelines for addition of new predefined primitive operations
-- Update the value of constant Default_Prim_Op_Count in A-Tags.ads -- Update the value of constant Max_Predef_Prims in a-tags.ads to
-- to reflect the new number of PPOs. -- indicate the new number of PPOs.
-- Introduce a new predefined name for the new PPO in Snames.ads and -- Introduce a new predefined name for the new PPO in Snames.ads and
-- Snames.adb. -- Snames.adb.
...@@ -161,10 +161,19 @@ package Exp_Disp is ...@@ -161,10 +161,19 @@ package Exp_Disp is
-- for a tagged type. If more predefined primitive operations are -- for a tagged type. If more predefined primitive operations are
-- added, the following items must be changed: -- added, the following items must be changed:
-- Ada.Tags.Defailt_Prim_Op_Count - indirect use -- Ada.Tags.Max_Predef_Prims - indirect use
-- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use -- Exp_Disp.Set_All_DT_Position - direct use
procedure Build_Static_Dispatch_Tables (N : Node_Id);
-- N is a library level package declaration or package body. Build the
-- static dispatch table of the tagged types defined at library level. In
-- case of package declarations with private part the generated nodes are
-- added at the end of the list of private declarations. Otherwise they are
-- added to the end of the list of public declarations. In case of package
-- bodies they are added to the end of the list of declarations of the
-- package body.
procedure Expand_Dispatching_Call (Call_Node : Node_Id); procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform -- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types tag checks are -- the required tag checks when appropriate. For CPP types tag checks are
...@@ -182,21 +191,23 @@ package Exp_Disp is ...@@ -182,21 +191,23 @@ package Exp_Disp is
-- secondary dispatch table. -- secondary dispatch table.
procedure Expand_Interface_Thunk procedure Expand_Interface_Thunk
(N : Node_Id; (Prim : Node_Id;
Thunk_Alias : Node_Id; Thunk_Id : out Entity_Id;
Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id);
Thunk_Code : out Node_Id);
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible -- generate additional subprograms (thunks) associated with each primitive
-- with the C++ ABI. The thunk modifies the value of the first actual of -- Prim to have a layout compatible with the C++ ABI. The thunk displaces
-- the call (that is, the pointer to the object) before transferring -- the pointers to the actuals that depend on the controlling type before
-- control to the target function. -- transferring control to the target subprogram. If there is no need to
-- -- generate the thunk then Thunk_Id and Thunk_Code are set to Empty.
-- Required in 3.4 case, why ??? giant comment needed for any gcc -- Otherwise they are set to the defining identifier and the subprogram
-- specific code ??? -- body of the generated thunk.
function Make_DT (Typ : Entity_Id) return List_Id; function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. -- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place
-- error messages when the declaration leads to the freezing of a given
-- primitive operation that has an incomplete non- tagged formal.
function Make_Disp_Asynchronous_Select_Body function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
...@@ -234,10 +245,9 @@ package Exp_Disp is ...@@ -234,10 +245,9 @@ package Exp_Disp is
function Make_Disp_Get_Task_Id_Body function Make_Disp_Get_Task_Id_Body
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type -- Ada 2005 (AI-345): Generate body of the primitive operation of type Typ
-- Typ used for retrieving the _task_id field of a task interface class- -- used for retrieving the _task_id field of a task interface class- wide
-- wide type. Generate a null body if Typ is an interface or a non-task -- type. Generate a null body if Typ is an interface or a non-task type.
-- type.
function Make_Disp_Get_Task_Id_Spec function Make_Disp_Get_Task_Id_Spec
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
...@@ -263,6 +273,12 @@ package Exp_Disp is ...@@ -263,6 +273,12 @@ package Exp_Disp is
-- selects. Generate code to set the primitive operation kinds and entry -- selects. Generate code to set the primitive operation kinds and entry
-- indices of primitive operations and primitive wrappers. -- indices of primitive operations and primitive wrappers.
function Make_Tags (Typ : Entity_Id) return List_Id;
-- Generate the entities associated with the primary and secondary tags of
-- Typ and fill the contents of Access_Disp_Table. In case of library level
-- tagged types this routine imports the forward declaration of the tag
-- entity, that will be declared and exported by Make_DT.
procedure Register_Primitive procedure Register_Primitive
(Loc : Source_Ptr; (Loc : Source_Ptr;
Prim : Entity_Id; Prim : Entity_Id;
......
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