with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
-with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Namet; use Namet;
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- 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 --
------------------------------
Etyp : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand);
- Fent : Entity_Id;
Func : Node_Id;
Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
- New_Itype : Entity_Id;
- Stats : List_Id;
begin
-- Ada 2005 (AI-345): Handle synchronized interface type derivations
-- data returned by IW_Convert to indicate that this is a dispatching
-- call.
- New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
- Set_Etype (New_Itype, New_Itype);
- Init_Esize (New_Itype);
- Init_Size_Align (New_Itype);
- Set_Directly_Designated_Type (New_Itype, Etyp);
+ declare
+ New_Itype : Entity_Id;
- Rewrite (N, Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (New_Itype,
- Relocate_Node (N))));
- Analyze (N);
- Freeze_Itype (New_Itype, N);
+ begin
+ New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Init_Esize (New_Itype);
+ 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;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
-- the value of the displaced actual. That 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
-- if O = Null_Address then
-- return null;
-- else
- -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
+ -- return Iface_Typ!(Aux.Iface_Tag'Address);
-- end if;
-- end Func;
- Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
-
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
Desig_Typ := Etype (Expression (N));
Desig_Typ := Directly_Designated_Type (Desig_Typ);
end if;
- New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
- Set_Etype (New_Itype, New_Itype);
- Set_Scope (New_Itype, Fent);
- Init_Size_Align (New_Itype);
- Set_Directly_Designated_Type (New_Itype, Desig_Typ);
- end;
+ New_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
+ Type_Definition =>
+ 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 (
- Make_Return_Statement (Loc,
- Unchecked_Convert_To (Etype (N),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (New_Itype,
- Make_Identifier (Loc, Name_uO)),
- Selector_Name =>
- New_Occurrence_Of (Iface_Tag, Loc)),
- Attribute_Name => Name_Address))));
+ New_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
+ Expression =>
+ Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
+ Make_Identifier (Loc, Name_uO)));
- -- If the type is null-excluding, no need for the null branch.
- -- Otherwise we need to check for it and return null.
+ Decls := New_List (
+ New_Typ_Decl,
+ New_Obj_Decl);
- if not Can_Never_Be_Null (Etype (N)) then
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_Return_Statement (Loc,
- Make_Null (Loc))),
- Else_Statements => Stats));
- end if;
+ Make_Simple_Return_Statement (Loc,
+ Unchecked_Convert_To (Etype (N),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (New_Obj_Decl),
+ Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc)),
+ Attribute_Name => Name_Address))));
- Func :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Fent,
+ -- If the type is null-excluding, no need for the null branch.
+ -- Otherwise we need to check for it and return null.
+
+ if not Can_Never_Be_Null (Etype (N)) then
+ 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 (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uO),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Address), Loc))),
+ Fent :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('F'));
- Result_Definition =>
- New_Reference_To (Etype (N), Loc)),
+ Func :=
+ 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 =>
- Make_Handled_Sequence_Of_Statements (Loc, Stats));
+ Result_Definition =>
+ New_Reference_To (Etype (N), Loc)),
- -- 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).
+ Declarations => Decls,
- 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,
- 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))));
+ if Is_Access_Type (Etype (Expression (N))) then
- else
- -- Generate: Operand_Typ!(Expression)'Address
+ -- Generate: Operand_Typ!(Expression.all)'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;
+ 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,
+ Make_Explicit_Dereference (Loc,
+ Relocate_Node (Expression (N)))),
+ 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;
Analyze (N);
----------------------------
procedure Expand_Interface_Thunk
- (N : Node_Id;
- Thunk_Alias : Entity_Id;
- Thunk_Id : out Entity_Id;
- Thunk_Code : out Node_Id)
+ (Prim : Node_Id;
+ Thunk_Id : out Entity_Id;
+ Thunk_Code : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (Prim);
Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List;
-- Give message if configurable run-time and Offset_To_Top unavailable
if not RTE_Available (RE_Offset_To_Top) then
- Error_Msg_CRT ("abstract interface types", N);
+ Error_Msg_CRT ("abstract interface types", Prim);
return;
end if;
-- Traverse the list of alias to find the final target
- Target := Thunk_Alias;
+ Target := Prim;
while Present (Alias (Target)) loop
Target := Alias (Target);
end loop;
Next_Formal (Formal);
end loop;
- if Ekind (First_Formal (Target)) = E_In_Parameter
- 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;
+ Controlling_Typ := Find_Dispatching_Type (Target);
Target_Formal := First_Formal (Target);
Formal := First (Formals);
then
-- Generate:
- -- type T is access all <<type of the first formal>>
- -- S1 := Storage_Offset!(formal)
- -- - Offset_To_Top (Formal.Tag)
-
- -- ... and the first actual of the call is generated as T!(S1)
+ -- type T is access all <<type of the target formal>>
+ -- S : Storage_Offset := Storage_Offset!(Formal)
+ -- - Offset_To_Top (address!(Formal))
Decl_2 :=
Make_Full_Type_Declaration (Loc,
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
- -- Reference the new first actual
+ -- Reference the new actual. Generate:
+ -- T!(S)
Append_To (Actuals,
Unchecked_Convert_To
elsif Etype (Target_Formal) = Controlling_Typ then
-- Generate:
- -- S1 := Storage_Offset!(Formal'Address)
- -- - Offset_To_Top (Formal.Tag)
- -- S2 := Tag_Ptr!(S3)
+ -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
+ -- - Offset_To_Top (Formal'Address)
+ -- S2 : Addr_Ptr := Addr_Ptr!(S1)
Decl_1 :=
Make_Object_Declaration (Loc,
Append_To (Decl, Decl_1);
Append_To (Decl, Decl_2);
- -- Reference the new first actual
+ -- Reference the new actual. Generate:
+ -- Target_Formal (S2.all)
Append_To (Actuals,
Unchecked_Convert_To
- (Etype (First_Entity (Target)),
+ (Etype (Target_Formal),
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals)))));
-- return To_Address (_T._task_id);
Ret :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
-- return Null_Address;
Ret :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
New_Reference_To (RTE (RE_Null_Address), Loc));
end if;
-- ...
-- end;
- function Make_DT (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Is_Local_DT : constant Boolean :=
- Ekind (Cunit_Entity (Get_Source_Unit (Typ)))
- /= E_Package;
+ function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Has_DT : constant Boolean :=
+ 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 :=
UI_To_Int
(Intval
(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
- (Typ : Entity_Id;
- Iface : Entity_Id;
- AI_Tag : Entity_Id;
- Iface_DT_Ptr : Entity_Id;
- Result : List_Id);
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ AI_Tag : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Result : List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
-- Table of Typ associated with Iface (each abstract interface of Typ
-- has a secondary dispatch table). The arguments Typ, Ancestor_Typ
-- is added at the end of Acc_Disp_Tables; this external name will be
-- 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 --
-----------------------
is
Loc : constant Source_Ptr := Sloc (Typ);
Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
-
Name_DT : constant Name_Id := New_Internal_Name ('T');
Iface_DT : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT);
Prim_Ops_Aggr_List : List_Id;
begin
- -- Handle the case where the backend does not support statically
- -- allocated dispatch tables.
+ -- Handle cases in which we do not generate statically allocated
+ -- dispatch tables.
- if not Static_Dispatch_Tables
- or else Is_Local_DT
- then
+ if not Build_Static_DT then
Set_Ekind (Predef_Prims, E_Variable);
Set_Is_Statically_Allocated (Predef_Prims);
-- 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;
else
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
Prim := Alias (Prim);
end loop;
- Expand_Interface_Thunk
- (N => Prim,
- Thunk_Alias => Prim,
- Thunk_Id => Thunk_Id,
- Thunk_Code => Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
- Constant_Present => Static_Dispatch_Tables,
+ Constant_Present => Build_Static_DT,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc,
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
-- the address of the Object Specific Data (see a-tags.ads)
New_Reference_To (RTE (RE_Null_Address), Loc));
elsif Is_Abstract_Type (Typ)
- or else not Static_Dispatch_Tables
+ or else not Build_Static_DT
then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List,
and then not Is_Parent (Iface, Typ)
then
- Expand_Interface_Thunk
- (N => Prim,
- Thunk_Alias => Alias (Prim),
- Thunk_Id => Thunk_Id,
- Thunk_Code => Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
Pos :=
Expression => Make_Aggregate (Loc,
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
-- Iface_DT_Ptr : Tag := Tag!(DT'Address);
-- 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;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
- Result : constant List_Id := New_List;
- 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);
+ Result : constant List_Id := New_List;
+ Tname : constant Name_Id := Chars (Typ);
AI : Elmt_Id;
AI_Tag_Comp : Elmt_Id;
AI_Ptr_Elmt : Elmt_Id;
DT_Constr_List : List_Id;
DT_Aggr_List : List_Id;
DT_Ptr : Entity_Id;
- Has_Dispatch_Table : Boolean := True;
ITable : Node_Id;
I_Depth : Nat := 0;
Iface_Table_Node : Node_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
- Transportable : Entity_Id;
- RC_Offset_Node : Node_Id;
Suffix_Index : Int;
Typ_Comps : Elist_Id;
Typ_Ifaces : Elist_Id;
TSD_Aggr_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
begin
- -- Fill the contents of Access_Disp_Table
-
- -- 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))));
+ pragma Assert (Is_Frozen (Typ));
- Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
- end;
+ -- Handle cases in which there is no need to build the dispatch table
- 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;
- end if;
- if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ elsif No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Typ);
+ return Result;
+ elsif not RTE_Available (RE_Tag) then
Append_To (Result,
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),
Constant_Present => True,
Expression =>
return Result;
end if;
- if not Static_Dispatch_Tables
- or else Is_Local_DT
- then
- Set_Ekind (DT, E_Variable);
- Set_Is_Statically_Allocated (DT);
+ -- Ensure that the value of Max_Predef_Prims defined in a-tags is
+ -- correct. Valid values are 10 under configurable runtime or 15
+ -- with full runtime.
+
+ 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
- Set_Ekind (DT, E_Constant);
- Set_Is_Statically_Allocated (DT);
- Set_Is_True_Constant (DT);
+ if Max_Predef_Prims /= 10 then
+ Error_Msg_N ("run-time library configuration error", Typ);
+ Error_Msg_CRT ("tagged types", Typ);
+ return Result;
+ end if;
end if;
- pragma Assert (Present (Access_Disp_Table (Typ)));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ -- Ensure that all the primitives are frozen. This is only required when
+ -- 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
- Suffix_Index := 0;
- AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ begin
+ Freezing_Library_Level_Tagged_Type := True;
+ 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);
- 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);
+ declare
+ Subp : constant Entity_Id := Node (Prim_Elmt);
+ F : Entity_Id;
- Suffix_Index := Suffix_Index + 1;
- Next_Elmt (AI_Ptr_Elmt);
- Next_Elmt (AI_Tag_Comp);
- end loop;
- end if;
+ begin
+ F := First_Formal (Subp);
+ while Present (F) loop
+ Check_Premature_Freezing (Subp, Etype (F));
+ 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 :=
- not Is_Interface (Typ)
- and then not Restriction_Active (No_Dispatching_Calls);
+ Suffix_Index := Suffix_Index + 1;
+ Next_Elmt (AI_Ptr_Elmt);
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
-- Calculate the number of primitives of the dispatch table and the
-- 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)));
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_Is_Statically_Allocated (SSD);
Set_Is_True_Constant (SSD);
-- multiple-called scopes.
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);
Set_Ekind (No_Reg, E_Variable);
-- initialization is done later by means of an assignment. This is
-- required to generate its External_Tag.
- if Is_Local_DT then
+ if not Build_Static_DT then
-- Generate:
-- DT : No_Dispatch_Table_Wrapper;
+ -- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
- if not Has_Dispatch_Table then
+ if not Has_DT then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
New_Reference_To
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+ 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,
Defining_Identifier => DT_Ptr,
end;
Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
- Expression =>
- Make_Integer_Literal (Loc, I_Depth)));
+ Make_Integer_Literal (Loc, I_Depth));
-- Access_Level
Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
- Expression =>
- Make_Integer_Literal (Loc, Type_Access_Level (Typ))));
+ Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
-- Expanded_Name
Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- 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
- -- Exname : constant String :=
+ -- <typ>A : constant String :=
-- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
-- The reason we generate this strange name is that we do not want to
-- in scope, but it clearly must be erroneous to compute the internal
-- 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
- 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 :=
- Make_Defining_Identifier (Loc, Name_Exname);
- Str1 : constant Entity_Id :=
- 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);
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Tname, 'A'));
+
Full_Name : constant String_Id :=
Full_Qualified_Name (First_Subtype (Typ));
Str1_Id : String_Id;
Str2_Id : String_Id;
- Str3_Id : String_Id;
begin
-- Generate:
- -- Str1 : constant String := "Internal tag at 16#";
-
- Set_Ekind (Str1, E_Constant);
- Set_Is_Statically_Allocated (Str1);
- Set_Is_True_Constant (Str1);
+ -- Str1 = "Internal tag at 16#";
Start_String;
Store_String_Chars ("Internal tag at 16#");
Str1_Id := End_String;
-- Generate:
- -- Str2 : constant String := "#: ";
-
- Set_Ekind (Str2, E_Constant);
- Set_Is_Statically_Allocated (Str2);
- Set_Is_True_Constant (Str2);
+ -- Str2 = "#: <type-full-name>";
Start_String;
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);
- Str3_Id := End_String;
+ Str2_Id := End_String;
-- Generate:
-- Exname : constant String :=
- -- Str1 & Address_Image (Tag) & Str2 & Str3;
+ -- Str1 & Address_Image (Tag) & Str2;
if RTE_Available (RE_Address_Image) then
Append_To (Result,
Unchecked_Convert_To (RTE (RE_Address),
New_Reference_To (DT_Ptr, Loc)))),
Right_Opnd =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc, Str2_Id),
- Right_Opnd =>
- Make_String_Literal (Loc, Str3_Id))))));
+ Make_String_Literal (Loc, Str2_Id)))));
+
else
Append_To (Result,
Make_Object_Declaration (Loc,
Left_Opnd =>
Make_String_Literal (Loc, Str1_Id),
Right_Opnd =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc, Str2_Id),
- Right_Opnd =>
- Make_String_Literal (Loc, Str3_Id)))));
+ Make_String_Literal (Loc, Str2_Id))));
end if;
New_Node :=
else
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;
- -- Set_External_Tag (x'tag, xV'Address);
- -- Register_Tag (x'tag);
+ -- <typ>A : constant string := y;
+ --
+ -- <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
end;
end if;
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_External_Tag), Loc)),
- Expression => New_Node));
+ Append_To (TSD_Aggr_List, New_Node);
-- HT_Link
Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- 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))));
+ 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
-- with respect to E.4(18) legality rules.
- Transportable :=
- Boolean_Literals
- (Is_Pure (Typ)
- or else Is_Shared_Passive (Typ)
- or else
- ((Is_Remote_Types (Typ)
- or else Is_Remote_Call_Interface (Typ))
- and then Original_View_In_Visible_Part (Typ))
- or else not Comes_From_Source (Typ));
+ declare
+ Transportable : Entity_Id;
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Transportable), Loc)),
- Expression => New_Occurrence_Of (Transportable, Loc)));
+ begin
+ Transportable :=
+ Boolean_Literals
+ (Is_Pure (Typ)
+ or else Is_Shared_Passive (Typ)
+ or else
+ ((Is_Remote_Types (Typ)
+ or else Is_Remote_Call_Interface (Typ))
+ and then Original_View_In_Visible_Part (Typ))
+ or else not Comes_From_Source (Typ));
+
+ Append_To (TSD_Aggr_List,
+ New_Occurrence_Of (Transportable, Loc));
+ end;
-- RC_Offset: These are the valid values and their meaning:
-- -2: There are no controlled components at this level. We need to
-- get the position from the parent.
- if not Has_Controlled_Component (Typ) then
- RC_Offset_Node := Make_Integer_Literal (Loc, 0);
+ declare
+ RC_Offset_Node : Node_Id;
- 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);
+ begin
+ if not Has_Controlled_Component (Typ) then
+ RC_Offset_Node := Make_Integer_Literal (Loc, 0);
+
+ 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
- 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;
- 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,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
- Expression => RC_Offset_Node));
+ Append_To (TSD_Aggr_List, RC_Offset_Node);
+ end;
-- Interfaces_Table (required for AI-405)
-- Generate the Interface_Table object
else
- TSD_Ifaces_List := New_List;
-
declare
- Pos : Nat := 1;
- Aggr_List : List_Id;
+ TSD_Ifaces_List : constant List_Id := New_List;
begin
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
- Aggr_List := New_List (
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Iface_Tag), Loc)),
- Expression =>
+ Append_To (TSD_Ifaces_List,
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+
+ -- Iface_Tag
+
Unchecked_Convert_To (Generalized_Tag,
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Node (AI)))),
- Loc))),
+ Loc)),
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Static_Offset_To_Top),
- Loc)),
- Expression =>
- New_Reference_To (Standard_True, Loc)),
+ -- Static_Offset_To_Top
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
+ New_Reference_To (Standard_True, Loc),
- Append_To (TSD_Ifaces_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc, Pos)),
- Expression => Make_Aggregate (Loc,
- Component_Associations => Aggr_List)));
+ -- Offset_To_Top_Value
+
+ Make_Integer_Literal (Loc, 0),
+
+ -- Offset_To_Top_Func
+
+ Make_Null (Loc))));
- Pos := Pos + 1;
Next_Elmt (AI);
end loop;
- end;
- Name_ITable := New_External_Name (Tname, 'I');
- ITable := Make_Defining_Identifier (Loc, Name_ITable);
+ Name_ITable := New_External_Name (Tname, 'I');
+ ITable := Make_Defining_Identifier (Loc, Name_ITable);
+ Set_Is_Statically_Allocated (ITable);
- Set_Ekind (ITable, E_Constant);
- Set_Is_Statically_Allocated (ITable);
- Set_Is_True_Constant (ITable);
+ -- The table of interfaces is not constant; its slots are
+ -- filled at run-time by the IP routine using attribute
+ -- 'Position to know the location of the tag components
+ -- (and this attribute cannot be safely used before the
+ -- object is initialized).
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => ITable,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Interface_Data), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc, Num_Ifaces)))),
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => ITable,
+ Aliased_Present => True,
+ Constant_Present => False,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Interface_Data), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint
+ (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces)))),
- Expression => Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Nb_Ifaces), Loc)),
- Expression =>
- Make_Integer_Literal (Loc, Num_Ifaces)),
+ Expression => Make_Aggregate (Loc,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces),
+ Make_Aggregate (Loc,
+ Expressions => TSD_Ifaces_List)))));
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Ifaces_Table), Loc)),
- Expression => Make_Aggregate (Loc,
- Component_Associations => TSD_Ifaces_List))))));
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (ITable, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
- Iface_Table_Node :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (ITable, Loc),
- Attribute_Name => Name_Unchecked_Access);
+ Iface_Table_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (ITable, Loc),
+ Attribute_Name => Name_Unchecked_Access);
+ end;
end if;
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Interfaces_Table), Loc)),
- Expression => Iface_Table_Node));
+ Append_To (TSD_Aggr_List, Iface_Table_Node);
end if;
-- Generate the Select Specific Data table for synchronized types that
if RTE_Record_Component_Available (RE_SSD) then
if Ada_Version >= Ada_05
- and then Has_Dispatch_Table
+ and then Has_DT
and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ)
and then Nb_Prim > 0
Constraints => New_List (
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,
-- which calls Set_Entry_Index and Set_Prim_Op_Kind.
Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_SSD), Loc)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (SSD, Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Unchecked_Access));
else
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_SSD), Loc)),
- Expression => Make_Null (Loc)));
+ Append_To (TSD_Aggr_List, Make_Null (Loc));
end if;
end if;
-- Initialize the table of ancestor tags. In case of interface types
-- this table is not needed.
- if Is_Interface (Typ) then
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- else
- declare
- Current_Typ : Entity_Id;
- Parent_Typ : Entity_Id;
- Pos : Nat;
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+ Pos : Nat;
- begin
- TSD_Tags_List := New_List;
+ begin
+ TSD_Tags_List := New_List;
- -- Fill position 0 with null because we still have not generated
- -- the tag of Typ.
+ -- If we are not statically allocating the dispatch table then we
+ -- 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,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc, 0)),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (RTE (RE_Null_Address), Loc))));
+ 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;
- Current_Typ := Typ;
+ else
+ declare
+ Imported_DT_Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('D'));
- loop
- Parent_Typ := Etype (Current_Typ);
+ begin
+ 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
- Parent_Typ := Full_View (Base_Type (Parent_Typ));
- end if;
+ -- Set tag as internal to ensure proper Sprint output of its
+ -- implicit importation.
- 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
- -- the object is constructed.
- -- (see Exp_Ch3.Build_Init_Procedure)
+ Append_To (TSD_Tags_List,
+ New_Reference_To (Imported_DT_Ptr, Loc));
+ end;
+ end if;
- Append_To (TSD_Tags_List,
- 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;
+ -- Fill the rest of the table with the tags of the ancestors
- Pos := Pos + 1;
- Current_Typ := Parent_Typ;
- end loop;
+ Pos := 1;
+ Current_Typ := Typ;
- pragma Assert (Pos = I_Depth + 1);
- end;
+ loop
+ Parent_Typ := Etype (Current_Typ);
- Append_To (TSD_Aggr_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- New_Occurrence_Of
- (RTE_Record_Component (RE_Tags_Table), Loc)),
- Expression => Make_Aggregate (Loc,
- Component_Associations => TSD_Tags_List)));
- end if;
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ exit when Parent_Typ = Current_Typ;
+
+ if Is_CPP_Class (Parent_Typ)
+ 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
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
+ Constant_Present => Build_Static_DT,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
Make_Integer_Literal (Loc, I_Depth)))),
Expression => Make_Aggregate (Loc,
- Component_Associations => TSD_Aggr_List)));
+ Expressions => TSD_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
-- DT : No_Dispatch_Table :=
-- (NDT_TSD => TSD'Address;
-- 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_Aggr_List := New_List;
-- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment.
- if Is_Local_DT then
+ if not Build_Static_DT then
Append_To (Result,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc),
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
- Constant_Present => Static_Dispatch_Tables,
+ Constant_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
+ 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,
Defining_Identifier => DT_Ptr,
-- prim-op-2'address,
-- ...
-- prim-op-n'address));
+ -- for DT'Alignment use Address'Alignment
else
declare
Pos : Nat;
begin
- if not Static_Dispatch_Tables then
+ if not Build_Static_DT then
Nb_Predef_Prims := Max_Predef_Prims;
else
Prim_Ops_Aggr_List := New_List;
Prim_Table := (others => Empty);
+
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- if Static_Dispatch_Tables
+ if Build_Static_DT
and then Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Abstract_Subprogram (Prim)
and then not Present (Prim_Table
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
Aliased_Present => True,
- Constant_Present => Static_Dispatch_Tables,
+ Constant_Present => Build_Static_DT,
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc,
Append_To (Prim_Ops_Aggr_List,
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
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
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;
-- and uninitialized object for the dispatch table, which is now
-- initialized by means of an assignment.
- if Is_Local_DT then
+ if not Build_Static_DT then
Append_To (Result,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (DT, Loc),
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
- Constant_Present => Static_Dispatch_Tables,
+ Constant_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
-- 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)
then
Append_To (Result,
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if;
- if Static_Dispatch_Tables then
+ if Build_Static_DT then
null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables
if Nb_Prims /= 0 then
Append_To (Elab_Code,
Build_Inherit_Prims (Loc,
+ Typ => Typ,
Old_Tag_Node => Old_Tag2,
New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Num_Prims => Nb_Prims));
if Num_Prims /= 0 then
Append_To (Elab_Code,
Build_Inherit_Prims (Loc,
+ Typ => Node (Iface),
Old_Tag_Node =>
Unchecked_Convert_To
(RTE (RE_Tag),
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc)),
- Num_Prims => Num_Prims));
+ Num_Prims => Num_Prims));
end if;
end;
end if;
if not Is_Interface (Typ) then
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)
then
Append_To (Elab_Code,
Then_Statements => Elab_Code));
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);
+ Set_Has_Dispatch_Table (Typ);
+
return Result;
end Make_DT;
if Present (Corresponding_Concurrent_Type (Typ)) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ if Present (Full_View (Conc_Typ)) then
+ Conc_Typ := Full_View (Conc_Typ);
+ end if;
+
if Ekind (Conc_Typ) = E_Protected_Type then
Decls := Visible_Declarations (Protected_Definition (
Parent (Conc_Typ)));
return Assignments;
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 --
-----------------------------------
pragma Assert (Is_Interface (Iface_Typ));
- Expand_Interface_Thunk
- (N => Prim,
- Thunk_Alias => Alias (Prim),
- Thunk_Id => Thunk_Id,
- Thunk_Code => Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if not Is_Parent (Iface_Typ, Typ)
and then Present (Thunk_Code)
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);
-- Generate the code necessary to fill the appropriate entry of
elsif not Present (Abstract_Interface_Alias (Prim))
and then Present (Alias (Prim))
+ and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Parent
(Find_Dispatching_Type (Alias (Prim)), Typ)
then
Error_Msg_NE
("abstract inherited private operation&" &
- " must be overridden ('R'M 3.9.3(10))",
+ " must be overridden (RM 3.9.3(10))",
Parent (Typ), Prim);
end if;
end if;
elsif Is_Concurrent_Record_Type (T) then
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
return New_Reference_To (RTE (RE_TK_Protected), Loc);
else
-- Protect this procedure against wrong usage. Required because it will
-- 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)
then
Write_Str ("wrong usage: Write_DT must be used with tagged types");
git://gcc.gnu.org / gcc.git / commitdiff