with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Itypes; use Itypes;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Disp; use Sem_Disp;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Disp is
Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership,
DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size,
Get_Expanded_Name => RE_Get_Expanded_Name,
Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable,
Get_TSD => RE_Get_TSD,
Inherit_DT => RE_Inherit_DT,
Inherit_TSD => RE_Inherit_TSD,
Register_Tag => RE_Register_Tag,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
Set_RC_Offset => RE_Set_RC_Offset,
Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_TSD => RE_Set_TSD,
TSD_Entry_Size => RE_TSD_Entry_Size,
TSD_Prologue_Size => RE_TSD_Prologue_Size);
CPP_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CPP_CW_Membership,
DT_Entry_Size => RE_CPP_DT_Entry_Size,
DT_Prologue_Size => RE_CPP_DT_Prologue_Size,
Get_Expanded_Name => RE_CPP_Get_Expanded_Name,
Get_External_Tag => RE_CPP_Get_External_Tag,
Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address,
Get_RC_Offset => RE_CPP_Get_RC_Offset,
Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable,
Get_TSD => RE_CPP_Get_TSD,
Inherit_DT => RE_CPP_Inherit_DT,
Inherit_TSD => RE_CPP_Inherit_TSD,
Register_Tag => RE_CPP_Register_Tag,
Set_Expanded_Name => RE_CPP_Set_Expanded_Name,
Set_External_Tag => RE_CPP_Set_External_Tag,
Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address,
Set_RC_Offset => RE_CPP_Set_RC_Offset,
Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable,
Set_TSD => RE_CPP_Set_TSD,
TSD_Entry_Size => RE_CPP_TSD_Entry_Size,
TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size);
Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
(CW_Membership => False,
DT_Entry_Size => False,
DT_Prologue_Size => False,
Get_Expanded_Name => False,
Get_External_Tag => False,
Get_Prim_Op_Address => False,
Get_Remotely_Callable => False,
Get_RC_Offset => False,
Get_TSD => False,
Inherit_DT => True,
Inherit_TSD => True,
Register_Tag => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
Set_Prim_Op_Address => True,
Set_RC_Offset => True,
Set_Remotely_Callable => True,
Set_TSD => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
(CW_Membership => 2,
DT_Entry_Size => 0,
DT_Prologue_Size => 0,
Get_Expanded_Name => 1,
Get_External_Tag => 1,
Get_Prim_Op_Address => 2,
Get_RC_Offset => 1,
Get_Remotely_Callable => 1,
Get_TSD => 1,
Inherit_DT => 3,
Inherit_TSD => 2,
Register_Tag => 1,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
Set_Prim_Op_Address => 3,
Set_RC_Offset => 2,
Set_Remotely_Callable => 2,
Set_TSD => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
procedure Expand_Dispatch_Call (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Call_Typ : constant Entity_Id := Etype (Call_Node);
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
Param_List : constant List_Id := Parameter_Associations (Call_Node);
Subp : Entity_Id := Entity (Name (Call_Node));
CW_Typ : Entity_Id;
New_Call : Node_Id;
New_Call_Name : Node_Id;
New_Params : List_Id := No_List;
Param : Node_Id;
Res_Typ : Entity_Id;
Subp_Ptr_Typ : Entity_Id;
Subp_Typ : Entity_Id;
Typ : Entity_Id;
Eq_Prim_Op : Entity_Id := Empty;
function New_Value (From : Node_Id) return Node_Id;
function New_Value (From : Node_Id) return Node_Id is
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
return Make_Explicit_Dereference (Sloc (From), Res);
else
return Res;
end if;
end New_Value;
begin
if Present (Alias (Subp))
and then Is_Inherited_Operation (Subp)
and then No (DTC_Entity (Subp))
then
Subp := Alias (Subp);
end if;
if not Expander_Active then
return;
end if;
if Is_Access_Type (Etype (Ctrl_Arg)) then
CW_Typ := Designated_Type (Etype (Ctrl_Arg));
else
CW_Typ := Etype (Ctrl_Arg);
end if;
Typ := Root_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
if Is_CPP_Class (Root_Type (Typ)) then
New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
if Param = Ctrl_Arg
and then DTC_Entity (Subp) /= Tag_Component (Typ)
then
Append_To (New_Params,
Unchecked_Convert_To (Etype (Param),
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displaced_This), Loc),
Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Address), Loc),
Expression => Relocate_Node (Param)),
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ctrl_Arg),
Selector_Name =>
New_Reference_To (DTC_Entity (Subp), Loc)),
Make_Integer_Literal (Loc, DT_Position (Subp))))));
else
Append_To (New_Params, Relocate_Node (Param));
end if;
Next_Actual (Param);
end loop;
elsif Present (Param_List) then
New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
if Param = Ctrl_Arg then
Append_To (New_Params, Duplicate_Subexpr (Param));
elsif No (Find_Controlling_Arg (Param)) then
Append_To (New_Params, Relocate_Node (Param));
elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
Append_To (New_Params, Relocate_Node (Param));
elsif Subp = Eq_Prim_Op then
Append_To (New_Params, Duplicate_Subexpr (Param));
elsif Tag_Checks_Suppressed (Etype (Param))
or else (Is_Access_Type (Etype (Param))
and then Tag_Checks_Suppressed
(Designated_Type (Etype (Param))))
then
Append_To (New_Params, Relocate_Node (Param));
elsif Is_Entity_Name (Param)
and then Is_Entity_Name (Ctrl_Arg)
and then Entity (Param) = Entity (Ctrl_Arg)
then
Append_To (New_Params, Relocate_Node (Param));
else
Insert_Action (Ctrl_Arg,
Make_Implicit_If_Statement (Call_Node,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Value (Ctrl_Arg),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ, New_Value (Param)),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc))),
Then_Statements =>
New_List (New_Constraint_Error (Loc))));
Append_To (New_Params, Relocate_Node (Param));
end if;
Next_Actual (Param);
end loop;
end if;
if Etype (Subp) = Typ then
Res_Typ := CW_Typ;
else
Res_Typ := Etype (Subp);
end if;
Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Init_Size_Align (Subp_Ptr_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
declare
Old_Formal : Entity_Id := First_Formal (Subp);
New_Formal : Entity_Id;
Extra : Entity_Id;
begin
if Present (Old_Formal) then
New_Formal := New_Copy (Old_Formal);
Set_First_Entity (Subp_Typ, New_Formal);
Param := First_Actual (Call_Node);
loop
Set_Scope (New_Formal, Subp_Typ);
if Is_Controlling_Actual (Param) then
Set_Etype (New_Formal, Etype (Param));
end if;
if Is_Itype (Etype (New_Formal)) then
Extra := New_Copy (Etype (New_Formal));
if Ekind (Extra) = E_Record_Subtype
or else Ekind (Extra) = E_Class_Wide_Subtype
then
Set_Cloned_Subtype (Extra, Etype (New_Formal));
end if;
Set_Etype (New_Formal, Extra);
Set_Scope (Etype (New_Formal), Subp_Typ);
end if;
Extra := New_Formal;
Next_Formal (Old_Formal);
exit when No (Old_Formal);
Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
Next_Entity (New_Formal);
Next_Actual (Param);
end loop;
Set_Last_Entity (Subp_Typ, Extra);
New_Formal := First_Entity (Subp_Typ);
while Present (New_Formal) loop
if Present (Extra_Constrained (New_Formal)) then
Set_Extra_Formal (Extra,
New_Copy (Extra_Constrained (New_Formal)));
Extra := Extra_Formal (Extra);
Set_Extra_Constrained (New_Formal, Extra);
elsif Present (Extra_Accessibility (New_Formal)) then
Set_Extra_Formal (Extra,
New_Copy (Extra_Accessibility (New_Formal)));
Extra := Extra_Formal (Extra);
Set_Extra_Accessibility (New_Formal, Extra);
end if;
Next_Formal (New_Formal);
end loop;
end if;
end;
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Make_DT_Access_Action (Typ,
Action => Get_Prim_Op_Address,
Args => New_List (
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)),
Make_Integer_Literal (Loc, DT_Position (Subp)))));
if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
Name => New_Call_Name,
Parameter_Associations => New_Params);
if Subp = Eq_Prim_Op then
Param := First_Actual (Call_Node);
New_Call :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
else
New_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
Rewrite (Call_Node, New_Call);
Analyze_And_Resolve (Call_Node, Call_Typ);
end Expand_Dispatch_Call;
function Fill_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id)
return Node_Id
is
Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ);
begin
return
Make_DT_Access_Action (Typ,
Action => Set_Prim_Op_Address,
Args => New_List (
New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, DT_Position (Prim)),
Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
end Fill_DT_Entry;
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Obj);
begin
return Make_DT_Access_Action
(Typ => Etype (Obj),
Action => Get_Remotely_Callable,
Args => New_List (
Make_Selected_Component (Loc,
Prefix => Obj,
Selector_Name => Make_Identifier (Loc, Name_uTag))));
end Get_Remotely_Callable;
function Make_DT (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Result : constant List_Id := New_List;
Elab_Code : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ);
Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
I_Depth : Int;
Generalized_Tag : Entity_Id;
Size_Expr_Node : Node_Id;
Old_Tag : Node_Id;
Old_TSD : Node_Id;
begin
if Is_CPP_Class (Root_Type (Typ)) then
Generalized_Tag := RTE (RE_Vtable_Ptr);
else
Generalized_Tag := RTE (RE_Tag);
end if;
Set_Ekind (DT, E_Variable);
Set_Is_Statically_Allocated (DT);
Set_Ekind (DT_Ptr, E_Variable);
Set_Is_Statically_Allocated (DT_Ptr);
Set_Ekind (TSD, E_Variable);
Set_Is_Statically_Allocated (TSD);
Set_Ekind (Exname, E_Variable);
Set_Is_Statically_Allocated (Exname);
Set_Ekind (No_Reg, E_Variable);
Set_Is_Statically_Allocated (No_Reg);
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc,
DT_Entry_Count (Tag_Component (Typ)))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Size_Expr_Node))))));
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,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Unchecked_Convert_To (Generalized_Tag,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => No_Reg,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_True, Loc)));
Set_Access_Disp_Table (Typ, DT_Ptr);
declare
Parent_Type : Entity_Id := Typ;
P : Entity_Id;
begin
I_Depth := 0;
loop
P := Etype (Parent_Type);
if Is_Private_Type (P) then
P := Full_View (Base_Type (P));
end if;
exit when P = Parent_Type;
I_Depth := I_Depth + 1;
Parent_Type := P;
end loop;
end;
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
Right_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 1),
Right_Opnd =>
Make_Integer_Literal (Loc, I_Depth))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Size_Expr_Node))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (TSD, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_TSD,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address))));
if Typ = Etype (Typ)
or else Is_CPP_Class (Etype (Typ))
then
Old_Tag :=
Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
Old_TSD :=
Unchecked_Convert_To (RTE (RE_Address),
Make_Integer_Literal (Loc, 0));
else
Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc);
Old_TSD :=
Make_DT_Access_Action (Typ,
Action => Get_TSD,
Args => New_List (
New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc)));
end if;
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Old_Tag,
Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (Tag_Component (Etype (Typ)))))));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_TSD,
Args => New_List (
Node1 => Old_TSD,
Node2 => New_Reference_To (DT_Ptr, Loc))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
Constant_Present => True,
Object_Definition => New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ)))));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Expanded_Name,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
declare
Position : Node_Id;
begin
if not Has_Controlled_Component (Typ) then
Position := Make_Integer_Literal (Loc, 0);
elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
Position := Make_Integer_Literal (Loc, -1);
else
Position :=
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);
Set_Analyzed (Position);
Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
Set_Etype (Prefix (Prefix (Position)), Typ);
Set_Etype (Selector_Name (Prefix (Position)),
RTE (RE_Record_Controller));
Set_Etype (Position, RTE (RE_Storage_Offset));
end if;
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_RC_Offset,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Position)));
end;
declare
Status : Entity_Id;
begin
if 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)
then
Status := Standard_True;
else
Status := Standard_False;
end if;
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Remotely_Callable,
Args => New_List (
New_Occurrence_Of (DT_Ptr, Loc),
New_Occurrence_Of (Status, Loc))));
end;
if not Has_External_Tag_Rep_Clause (Typ) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_External_Tag,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
if Is_RTE (Generalized_Tag, RE_Tag)
and then not No_Run_Time
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
New_List (New_Reference_To (DT_Ptr, Loc))));
end if;
end if;
Append_To (Elab_Code,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (No_Reg, Loc),
Expression => New_Reference_To (Standard_False, Loc)));
Append_To (Result,
Make_Implicit_If_Statement (Typ,
Condition => New_Reference_To (No_Reg, Loc),
Then_Statements => Elab_Code));
return Result;
end Make_DT;
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
Args : List_Id)
return Node_Id
is
Action_Name : Entity_Id;
Loc : Source_Ptr;
begin
if Is_CPP_Class (Root_Type (Typ)) then
Action_Name := RTE (CPP_Actions (Action));
else
Action_Name := RTE (Ada_Actions (Action));
end if;
if No (Args) then
return New_Reference_To (Action_Name, Sloc (Typ));
end if;
pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
Loc := Sloc (First (Args));
if Action_Is_Proc (Action) then
return
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Action_Name, Loc),
Parameter_Associations => Args);
else
return
Make_Function_Call (Loc,
Name => New_Reference_To (Action_Name, Loc),
Parameter_Associations => Args);
end if;
end Make_DT_Access_Action;
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
Scop : constant Entity_Id := Scope (Typ);
begin
if Ekind (Scop) /= E_Package
and then Ekind (Scop) /= E_Generic_Package
then
return False;
end if;
if Has_Private_Declaration (Typ) then
return True;
end if;
return List_Containing (Parent (Typ)) =
Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
end Original_View_In_Visible_Part;
procedure Set_All_DT_Position (Typ : Entity_Id) is
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Parent_EC : Int;
Nb_Prim : Int;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
begin
if Parent_Typ /= Typ
and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint
then
Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ)));
else
Parent_EC := 0;
end if;
if Is_CPP_Class (Root_Typ) then
Prim_Elmt := First_Prim;
Nb_Prim := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if not Is_CPP_Class (Typ) then
Set_DTC_Entity (Prim, The_Tag);
elsif Present (Alias (Prim)) then
Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
Error_Msg_NE ("is a primitive operation of&," &
" pragma Cpp_Virtual required", Prim, Typ);
end if;
if DTC_Entity (Prim) = The_Tag then
declare
H : Entity_Id := Homonym (Prim);
begin
while Present (H) loop
if Present (DTC_Entity (H))
and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
then
Set_DT_Position (Prim, DT_Position (H));
exit;
end if;
H := Homonym (H);
end loop;
end;
if DT_Position (Prim) = No_Uint then
Nb_Prim := Nb_Prim + 1;
Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
Nb_Prim := Nb_Prim + 1;
end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
if DT_Entry_Count (The_Tag) = No_Uint
or else not Is_CPP_Class (Typ)
then
Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
Error_Msg_N ("not enough room in the Vtable for all virtual"
& " functions", The_Tag);
end if;
declare
Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
Pos : Int;
Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
(others => Empty);
begin
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if DTC_Entity (Prim) = The_Tag then
Pos := UI_To_Int (DT_Position (Prim));
if Pos not in Prim_Pos_Table'Range then
Error_Msg_N
("position not in range of virtual table", Prim);
elsif Present (Prim_Pos_Table (Pos)) then
Error_Msg_NE ("cannot be at the same position in the"
& " vtable than&", Prim, Prim_Pos_Table (Pos));
else
Prim_Pos_Table (Pos) := Prim;
end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
end;
else
Nb_Prim := 0;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Nb_Prim := Nb_Prim + 1;
Prim := Node (Prim_Elmt);
Set_DTC_Entity (Prim, The_Tag);
Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
if Chars (Prim) = Name_Finalize
and then (Is_Predefined_File_Name
(Unit_File_Name (Current_Sem_Unit))
or else
not Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Prim))))
then
Finalized := True;
end if;
if Chars (Prim) = Name_Adjust then
Adjusted := True;
end if;
if Is_Abstract (Typ)
and then Is_Abstract (Prim)
and then Present (Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
and then List_Containing (Parent (Prim))
= Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Original_View_In_Visible_Part (Typ)
and then Chars (Prim) /= Name_uInput
then
Error_Msg_NE ("abstract inherited private operation&"
& " must be overriden", Parent (Typ), Prim);
end if;
Next_Elmt (Prim_Elmt);
end loop;
if Is_Controlled (Typ) then
if not Finalized then
Error_Msg_N
("controlled type has no explicit Finalize method?", Typ);
elsif not Adjusted then
Error_Msg_N
("controlled type has no explicit Adjust method?", Typ);
end if;
end if;
Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
pragma Assert (
DT_Entry_Count (The_Tag) >=
DT_Entry_Count (Tag_Component (Parent_Typ)));
end if;
end Set_All_DT_Position;
procedure Set_Default_Constructor (Typ : Entity_Id) is
Loc : Source_Ptr;
Init : Entity_Id;
Param : Entity_Id;
Decl : Node_Id;
E : Entity_Id;
begin
E := Next_Entity (Typ);
while Present (E)
and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
loop
Next_Entity (E);
end loop;
if Present (E) then
Loc := Sloc (E);
Init := Make_Defining_Identifier (Loc, Name_uInit_Proc);
Param := Make_Defining_Identifier (Loc, Name_X);
Decl :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Init,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Param,
Parameter_Type => New_Reference_To (Typ, Loc)))));
Set_Init_Proc (Typ, Init);
Set_Is_Imported (Init);
Set_Interface_Name (Init, Interface_Name (E));
Set_Convention (Init, Convention_C);
Set_Is_Public (Init);
Set_Has_Completion (Init);
else
Set_Is_Abstract (Typ);
end if;
end Set_Default_Constructor;
end Exp_Disp;