-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
+with Layout; use Layout;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Namet; use Namet;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (i.e. through a renaming)
+ function New_Value (From : Node_Id) return Node_Id;
+ -- From is the original Expression. New_Value is equivalent to a call
+ -- to Duplicate_Subexpr with an explicit dereference when From is an
+ -- access parameter.
+
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
-- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec.
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value.
+ ----------------------
+ -- Apply_Tag_Checks --
+ ----------------------
+
+ procedure Apply_Tag_Checks (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
+ Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
+ Param_List : constant List_Id := Parameter_Associations (Call_Node);
+
+ Subp : Entity_Id;
+ CW_Typ : Entity_Id;
+ Param : Node_Id;
+ Typ : Entity_Id;
+ Eq_Prim_Op : Entity_Id := Empty;
+
+ begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Call_Node);
+ return;
+ end if;
+
+ -- Apply_Tag_Checks is called directly from the semantics, so we need
+ -- a check to see whether expansion is active before proceeding. In
+ -- addition, there is no need to expand the call when compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
+
+ if not Expander_Active
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+ end if;
+
+ -- Set subprogram. If this is an inherited operation that was
+ -- overridden, the body that is being called is its alias.
+
+ Subp := Entity (Name (Call_Node));
+
+ if Present (Alias (Subp))
+ and then Is_Inherited_Operation (Subp)
+ and then No (DTC_Entity (Subp))
+ then
+ Subp := Alias (Subp);
+ end if;
+
+ -- Definition of the class-wide type and the tagged type
+
+ -- If the controlling argument is itself a tag rather than a tagged
+ -- object, then use the class-wide type associated with the subprogram's
+ -- controlling type. This case can occur when a call to an inherited
+ -- primitive has an actual that originated from a default parameter
+ -- given by a tag-indeterminate call and when there is no other
+ -- controlling argument providing the tag (AI-239 requires dispatching).
+ -- This capability of dispatching directly by tag is also needed by the
+ -- implementation of AI-260 (for the generic dispatching constructors).
+
+ if Ctrl_Typ = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ then
+ CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
+
+ -- Class_Wide_Type is applied to the expressions used to initialize
+ -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
+ -- there are cases where the controlling type is resolved to a specific
+ -- type (such as for designated types of arguments such as CW'Access).
+
+ elsif Is_Access_Type (Ctrl_Typ) then
+ CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
+
+ else
+ CW_Typ := Class_Wide_Type (Ctrl_Typ);
+ end if;
+
+ Typ := Root_Type (CW_Typ);
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if not Is_Limited_Type (Typ) then
+ Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
+ end if;
+
+ -- Dispatching call to C++ primitive
+
+ if Is_CPP_Class (Typ) then
+ null;
+
+ -- Dispatching call to Ada primitive
+
+ elsif Present (Param_List) then
+
+ -- Generate the Tag checks when appropriate
+
+ Param := First_Actual (Call_Node);
+ while Present (Param) loop
+
+ -- No tag check with itself
+
+ if Param = Ctrl_Arg then
+ null;
+
+ -- No tag check for parameter whose type is neither tagged nor
+ -- access to tagged (for access parameters)
+
+ elsif No (Find_Controlling_Arg (Param)) then
+ null;
+
+ -- No tag check for function dispatching on result if the
+ -- Tag given by the context is this one
+
+ elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
+ null;
+
+ -- "=" is the only dispatching operation allowed to get
+ -- operands with incompatible tags (it just returns false).
+ -- We use Duplicate_Subexpr_Move_Checks instead of calling
+ -- Relocate_Node because the value will be duplicated to
+ -- check the tags.
+
+ elsif Subp = Eq_Prim_Op then
+ null;
+
+ -- No check in presence of suppress flags
+
+ elsif Tag_Checks_Suppressed (Etype (Param))
+ or else (Is_Access_Type (Etype (Param))
+ and then Tag_Checks_Suppressed
+ (Designated_Type (Etype (Param))))
+ then
+ null;
+
+ -- Optimization: no tag checks if the parameters are identical
+
+ elsif Is_Entity_Name (Param)
+ and then Is_Entity_Name (Ctrl_Arg)
+ and then Entity (Param) = Entity (Ctrl_Arg)
+ then
+ null;
+
+ -- Now we need to generate the Tag check
+
+ else
+ -- Generate code for tag equality check
+ -- Perhaps should have Checks.Apply_Tag_Equality_Check???
+
+ 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
+ (First_Tag_Component (Typ), Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ, New_Value (Param)),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
+
+ Then_Statements =>
+ New_List (New_Constraint_Error (Loc))));
+ end if;
+
+ Next_Actual (Param);
+ end loop;
+ end if;
+ end Apply_Tag_Checks;
+
------------------------
-- Building_Static_DT --
------------------------
-- 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)
+ elsif Nkind_In (D, N_Full_Type_Declaration,
+ 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)));
+ -- We do not generate dispatch tables for the internal types
+ -- created for a type extension with unknown discriminants
+ -- The needed information is shared with the source type,
+ -- See Expand_N_Record_Extension.
+
+ if Is_Underlying_Record_View (Defining_Entity (D))
+ or else
+ (not Comes_From_Source (Defining_Entity (D))
+ and then
+ Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
+ and then
+ not Comes_From_Source
+ (First_Subtype (Defining_Entity (D))))
+ then
+ null;
+ else
+ Insert_List_After_And_Analyze (Last (Target_List),
+ Make_DT (Defining_Entity (D)));
+ end if;
-- Handle private types of library level tagged types. We must
-- exchange the private and full-view to ensure the correct
begin
if not Expander_Active
- or else VM_Target /= No_VM
+ or else not Tagged_Type_Expansion
then
return;
end if;
end if;
end New_Value;
+ -- Local variables
+
+ New_Node : Node_Id;
+ SCIL_Node : Node_Id;
+
-- Start of processing for Expand_Dispatching_Call
begin
Typ := Non_Limited_View (Typ);
end if;
+ -- Generate the SCIL node for this dispatching call. The SCIL node for a
+ -- dispatching call is inserted in the tree before the call is rewriten
+ -- and expanded because the SCIL node must be found by the SCIL backend
+ -- BEFORE the expanded nodes associated with the call node are found.
+
+ if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
+ Set_SCIL_Related_Node (SCIL_Node, Call_Node);
+ Set_SCIL_Entity (SCIL_Node, Typ);
+ Set_SCIL_Target_Prim (SCIL_Node, Subp);
+ Insert_Action (Call_Node, SCIL_Node);
+ end if;
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
-- Dispatching call to C++ primitive. Create a new parameter list
-- with no tag checks.
+ New_Params := New_List;
+
if Is_CPP_Class (Typ) then
- New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
Append_To (New_Params, Relocate_Node (Param));
-- Dispatching call to Ada primitive
elsif Present (Param_List) then
+ Apply_Tag_Checks (Call_Node);
- -- Generate the Tag checks when appropriate
-
- New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
+ -- Cases in which we may have generated runtime checks
- -- No tag check with itself
-
- if Param = Ctrl_Arg then
- Append_To (New_Params,
- Duplicate_Subexpr_Move_Checks (Param));
-
- -- No tag check for parameter whose type is neither tagged nor
- -- access to tagged (for access parameters)
-
- elsif No (Find_Controlling_Arg (Param)) then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- No tag check for function dispatching on result if the
- -- Tag given by the context is this one
-
- elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- "=" is the only dispatching operation allowed to get
- -- operands with incompatible tags (it just returns false).
- -- We use Duplicate_Subexpr_Move_Checks instead of calling
- -- Relocate_Node because the value will be duplicated to
- -- check the tags.
-
- elsif Subp = Eq_Prim_Op then
+ if Param = Ctrl_Arg
+ or else Subp = Eq_Prim_Op
+ then
Append_To (New_Params,
Duplicate_Subexpr_Move_Checks (Param));
- -- No check in presence of suppress flags
-
- elsif Tag_Checks_Suppressed (Etype (Param))
- or else (Is_Access_Type (Etype (Param))
- and then Tag_Checks_Suppressed
- (Designated_Type (Etype (Param))))
+ elsif Nkind (Parent (Param)) /= N_Parameter_Association
+ or else not Is_Accessibility_Actual (Parent (Param))
then
Append_To (New_Params, Relocate_Node (Param));
-
- -- Optimization: no tag checks if the parameters are identical
-
- 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));
-
- -- Now we need to generate the Tag check
-
- else
- -- Generate code for tag equality check
- -- Perhaps should have Checks.Apply_Tag_Equality_Check???
-
- 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
- (First_Tag_Component (Typ), Loc)),
-
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Typ, New_Value (Param)),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc))),
-
- Then_Statements =>
- New_List (New_Constraint_Error (Loc))));
-
- Append_To (New_Params, Relocate_Node (Param));
end if;
Next_Actual (Param);
Res_Typ := Etype (Subp);
end if;
- Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
+ 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);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
Create_Extra_Formals (Subp_Typ);
end;
+ -- Complete description of pointer type, including size information, as
+ -- must be done with itypes to prevent order-of-elaboration anomalies
+ -- in gigi.
+
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
+ Layout_Type (Subp_Ptr_Typ);
-- If the controlling argument is a value of type Ada.Tag or an abstract
-- interface class-wide type then use it directly. Otherwise, the tag
else
Controlling_Tag :=
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
+ Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
end if;
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
- New_Call_Name :=
- Unchecked_Convert_To (Subp_Ptr_Typ,
- Build_Get_Predefined_Prim_Op_Address (Loc,
- Tag_Node => Controlling_Tag,
- Position => DT_Position (Subp)));
+ Build_Get_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
-- Handle dispatching calls to user-defined primitives
else
- New_Call_Name :=
- Unchecked_Convert_To (Subp_Ptr_Typ,
- Build_Get_Prim_Op_Address (Loc,
- Typ => Find_Dispatching_Type (Subp),
- Tag_Node => Controlling_Tag,
- Position => DT_Position (Subp)));
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Find_Dispatching_Type (Subp),
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
end if;
- if Nkind (Call_Node) = N_Function_Call then
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
+
+ -- Complete decoration of SCIL dispatching node. It must be done after
+ -- the new call name is built to reference the nodes that will see the
+ -- SCIL backend (because Build_Get_Prim_Op_Address generates an
+ -- unchecked type conversion which relocates the controlling tag node).
+
+ if Generate_SCIL then
+
+ -- Common case: the controlling tag is the tag of an object
+ -- (for example, obj.tag)
+
+ if Nkind (Controlling_Tag) = N_Selected_Component then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
+
+ -- Handle renaming of selected component
+
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind (Parent (Entity (Controlling_Tag))) =
+ N_Object_Renaming_Declaration
+ and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
+ N_Selected_Component
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Name (Parent (Entity (Controlling_Tag))));
+
+ -- If the controlling tag is an identifier, the SCIL node references
+ -- the corresponding object or parameter declaration
+
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind_In (Parent (Entity (Controlling_Tag)),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Controlling_Tag)));
+
+ -- If the controlling tag is a dereference, the SCIL node references
+ -- the corresponding object or parameter declaration
+
+ elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
+ and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
+ and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Prefix (Controlling_Tag))));
+
+ -- For a direct reference of the tag of the type the SCIL node
+ -- references the the internal object declaration containing the tag
+ -- of the type.
+
+ elsif Nkind (Controlling_Tag) = N_Attribute_Reference
+ and then Attribute_Name (Controlling_Tag) = Name_Tag
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
+
+ -- Interfaces are not supported. For now we leave the SCIL node
+ -- decorated with the Controlling_Tag. More work needed here???
+
+ elsif Is_Interface (Etype (Controlling_Tag)) then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end if;
+ if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
- Name => New_Call_Name,
+ Name => New_Call_Name,
Parameter_Associations => New_Params);
-- If this is a dispatching "=", we must first compare the tags so
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
- Prefix => New_Value (Param),
+ Prefix => New_Value (Param),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ),
Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
- New_Reference_To (First_Tag_Component (Typ),
- Loc))),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
else
New_Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Call_Name,
+ Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
Iface_Typ := Root_Type (Iface_Typ);
end if;
+ -- If the target type is a tagged synchronized type, the dispatch table
+ -- info is in the corresponding record type.
+
+ if Is_Concurrent_Type (Iface_Typ) then
+ Iface_Typ := Corresponding_Record_Type (Iface_Typ);
+ end if;
+
+ -- Freeze the entity associated with the target interface to have
+ -- available the attribute Access_Disp_Table.
+
+ Freeze_Before (N, Iface_Typ);
+
pragma Assert (not Is_Static
or else (not Is_Class_Wide_Type (Iface_Typ)
and then Is_Interface (Iface_Typ)));
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
-- For VM, just do a conversion ???
-- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
if Is_Access_Type (Operand_Typ) then
- pragma Assert
- (Is_Interface (Directly_Designated_Type (Operand_Typ)));
-
Rewrite (N,
Unchecked_Convert_To (Etype (N),
Make_Function_Call (Loc,
Desig_Typ := Etype (Expression (N));
if Is_Access_Type (Desig_Typ) then
- Desig_Typ := Directly_Designated_Type (Desig_Typ);
+ Desig_Typ :=
+ Available_View (Directly_Designated_Type (Desig_Typ));
end if;
if Is_Concurrent_Type (Desig_Typ) then
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (Call_Node));
- -- Normal case
+ -- Call using selected component
+
+ elsif Nkind (Name (Call_Node)) = N_Selected_Component then
+ Subp := Entity (Selector_Name (Name (Call_Node)));
+
+ -- Call using direct name
else
Subp := Entity (Name (Call_Node));
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Prim);
- Actuals : constant List_Id := New_List;
- Decl : constant List_Id := New_List;
- Formals : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
Controlling_Typ : Entity_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
+ Expr : Node_Id;
Formal : Node_Id;
+ Ftyp : Entity_Id;
+ Iface_Formal : Node_Id;
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
- Target : Entity_Id;
Target_Formal : Entity_Id;
begin
Thunk_Id := Empty;
Thunk_Code := Empty;
- -- Traverse the list of alias to find the final target
-
- Target := Prim;
- while Present (Alias (Target)) loop
- Target := Alias (Target);
- end loop;
-
- -- In case of primitives that are functions without formals and
- -- a controlling result there is no need to build the thunk.
+ -- In case of primitives that are functions without formals and a
+ -- controlling result there is no need to build the thunk.
if not Present (First_Formal (Target)) then
pragma Assert (Ekind (Target) = E_Function
return;
end if;
- -- Duplicate the formals
+ -- Duplicate the formals of the Target primitive. In the thunk, the type
+ -- of the controlling formal is the covered interface type (instead of
+ -- the target tagged type). Done to avoid problems with discriminated
+ -- tagged types because, if the controlling type has discriminants with
+ -- default values, then the type conversions done inside the body of
+ -- the thunk (after the displacement of the pointer to the base of the
+ -- actual object) generate code that modify its contents.
+
+ -- Note: This special management is not done for predefined primitives
+ -- because???
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Iface_Formal := First_Formal (Interface_Alias (Prim));
+ end if;
Formal := First_Formal (Target);
while Present (Formal) loop
+ Ftyp := Etype (Formal);
+
+ -- Use the interface type as the type of the controlling formal (see
+ -- comment above).
+
+ if not Is_Controlling_Formal (Formal)
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ then
+ Ftyp := Etype (Formal);
+ Expr := New_Copy_Tree (Expression (Parent (Formal)));
+ else
+ Ftyp := Etype (Iface_Formal);
+ Expr := Empty;
+ end if;
+
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Reference_To (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Expression (Parent (Formal)))));
+ Parameter_Type => New_Reference_To (Ftyp, Loc),
+ Expression => Expr));
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Next_Formal (Iface_Formal);
+ end if;
Next_Formal (Formal);
end loop;
Target_Formal := First_Formal (Target);
Formal := First (Formals);
while Present (Formal) loop
+
+ -- Handle concurrent types
+
if Ekind (Target_Formal) = E_In_Parameter
and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
- and then Directly_Designated_Type (Etype (Target_Formal))
- = Controlling_Typ
then
- -- Generate:
+ Ftyp := Directly_Designated_Type (Etype (Target_Formal));
+ else
+ Ftyp := Etype (Target_Formal);
+ end if;
+ if Is_Concurrent_Type (Ftyp) then
+ Ftyp := Corresponding_Record_Type (Ftyp);
+ end if;
+
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ and then Ftyp = Controlling_Typ
+ then
+ -- Generate:
-- type T is access all <<type of the target formal>>
-- S : Storage_Offset := Storage_Offset!(Formal)
-- - Offset_To_Top (address!(Formal))
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Directly_Designated_Type
- (Etype (Target_Formal)), Loc)));
+ New_Reference_To (Ftyp, Loc)));
New_Arg :=
Unchecked_Convert_To (RTE (RE_Address),
(Defining_Identifier (Decl_2),
New_Reference_To (Defining_Identifier (Decl_1), Loc)));
- elsif Etype (Target_Formal) = Controlling_Typ then
- -- Generate:
+ elsif Ftyp = Controlling_Typ then
+ -- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
-- - Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
-- Target_Formal (S2.all)
Append_To (Actuals,
- Unchecked_Convert_To
- (Etype (Target_Formal),
+ Unchecked_Convert_To (Ftyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
Set_Is_Thunk (Thunk_Id);
+ -- Procedure case
+
if Ekind (Target) = E_Procedure then
Thunk_Code :=
Make_Subprogram_Body (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))));
- else pragma Assert (Ekind (Target) = E_Function);
+ -- Function case
+ else pragma Assert (Ekind (Target) = E_Function);
Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
return False;
end Is_Predefined_Dispatching_Operation;
+ ---------------------------------------
+ -- Is_Predefined_Internal_Operation --
+ ---------------------------------------
+
+ function Is_Predefined_Internal_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Internal_Operation;
+
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
+
+ else
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
end if;
return
RTE (RE_Conditional_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
+
+ else
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
end if;
return
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
+
+ else
+ -- Ensure that the statements list is non-empty
+
+ Append_To (Stmts, Make_Null_Statement (Loc));
end if;
return
-- 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 Export_DT (Typ : Entity_Id; DT : Entity_Id);
- -- Export the dispatch table entity DT of tagged type Typ. Required to
- -- generate forward references and statically allocate the table.
+ procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
+ -- Export the dispatch table DT of tagged type Typ. Required to generate
+ -- forward references and statically allocate the table. For primary
+ -- dispatch tables Index is 0; for secondary dispatch tables the value
+ -- of index must match the Suffix_Index value assigned to the table by
+ -- Make_Tags when generating its unique external name, and it is used to
+ -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
+ -- the external name generated by Import_DT.
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
-- calls through interface types; the latter secondary table is
-- generated when Build_Thunks is False, and provides support for
-- Generic Dispatching Constructors that dispatch calls through
- -- interface types.
+ -- interface types. When constructing this latter table the value
+ -- of Suffix_Index is -1 to indicate that there is no need to export
+ -- such table when building statically allocated dispatch tables; a
+ -- positive value of Suffix_Index must match the Suffix_Index value
+ -- assigned to this secondary dispatch table by Make_Tags when its
+ -- unique external name was generated.
------------------------------
-- Check_Premature_Freezing --
-- Export_DT --
---------------
- procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
+ procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
+ is
+ Count : Nat;
+ Elmt : Elmt_Id;
+
begin
Set_Is_Statically_Allocated (DT);
Set_Is_True_Constant (DT);
Set_Is_Exported (DT);
- pragma Assert (Present (Dispatch_Table_Wrapper (Typ)));
- Get_External_Name (Dispatch_Table_Wrapper (Typ), True);
+ Count := 0;
+ Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
+ while Count /= Index loop
+ Next_Elmt (Elmt);
+ Count := Count + 1;
+ end loop;
+
+ pragma Assert (Related_Type (Node (Elmt)) = Typ);
+
+ Get_External_Name
+ (Entity => Node (Elmt),
+ Has_Suffix => True);
+
Set_Interface_Name (DT,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Predef_Prims_Ptr : Entity_Id;
Result : List_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
- Name_DT : constant Name_Id := New_Internal_Name ('T');
+ Exporting_Table : constant Boolean :=
+ Building_Static_DT (Typ)
+ and then Suffix_Index > 0;
Iface_DT : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_DT);
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
Predef_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc,
- Name_Predef_Prims);
+ Chars => Name_Predef_Prims);
DT_Constr_List : List_Id;
DT_Aggr_List : List_Id;
Empty_DT : Boolean := False;
Set_Is_True_Constant (Iface_DT);
end if;
- -- Generate code to create the storage for the Dispatch_Table object.
- -- If the number of primitives of Typ is 0 we reserve a dummy single
- -- entry for its DT because at run-time the pointer to this dummy
- -- entry will be used as the tag.
+ -- Calculate the number of slots of the dispatch table. If the number
+ -- of primitives of Typ is 0 we reserve a dummy single entry for its
+ -- DT because at run-time the pointer to this dummy entry will be
+ -- used as the tag.
if Num_Iface_Prims = 0 then
Empty_DT := True;
-- prim-op-2'address,
-- ...
-- prim-op-n'address));
+ -- for Iface_DT'Alignment use Address'Alignment;
-- Stage 3: Initialize the discriminant and the record components
or else not Is_Limited_Type (Typ)
or else not Has_Interfaces (Typ)
or else not Build_Thunks
+ or else not RTE_Record_Component_Available (RE_OSD_Table)
then
-- No OSD table required
Append_Elmt (New_Node, DT_Aggr);
+ -- Note: Secondary dispatch tables cannot be declared constant
+ -- because the component Offset_To_Top is currently initialized
+ -- by the IP routine.
+
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT,
Aliased_Present => True,
+ Constant_Present => False,
+
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List)),
- Expression => Make_Aggregate (Loc,
- Expressions => DT_Aggr_List)));
+ 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 =>
+ Prefix =>
New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
+ if Exporting_Table then
+ Export_DT (Typ, Iface_DT, Suffix_Index);
+
-- Generate code to create the pointer to the dispatch table
- -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+ -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Iface_DT_Ptr,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_Interface_Tag), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Interface_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
+ -- Note: This declaration is not added here if the table is exported
+ -- because in such case Make_Tags has already added this declaration.
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Interface_Tag), Loc),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
Constant_Present => True,
- Object_Definition =>
+
+ Object_Definition =>
New_Reference_To (RTE (RE_Address), Loc),
- Expression =>
+
+ Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
-- Remember entities containing dispatch tables
then
declare
Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
+ Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Frnodes : List_Id;
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);
+ Prim := Node (Prim_Elmt);
+ Frnodes := Freeze_Entity (Prim, Loc);
declare
- Subp : constant Entity_Id := Node (Prim_Elmt);
F : Entity_Id;
begin
- F := First_Formal (Subp);
+ F := First_Formal (Prim);
while Present (F) loop
- Check_Premature_Freezing (Subp, Etype (F));
+ Check_Premature_Freezing (Prim, Etype (F));
Next_Formal (F);
end loop;
- Check_Premature_Freezing (Subp, Etype (Subp));
+ Check_Premature_Freezing (Prim, Etype (Prim));
end;
if Present (Frnodes) then
Next_Elmt (Prim_Elmt);
end loop;
+
Freezing_Library_Level_Tagged_Type := Save;
end;
end if;
if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
- Suffix_Index := 0;
+ -- Each secondary dispatch table is assigned an unique positive
+ -- suffix index; such value also corresponds with the location of
+ -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
+
+ -- Note: This value must be kept sync with the Suffix_Index values
+ -- generated by Make_Tags
+
+ Suffix_Index := 1;
AI_Tag_Elmt :=
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => Suffix_Index,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => True,
Result => Result);
- Next_Elmt (AI_Tag_Elmt);
- -- Skip the secondary dispatch table of predefined primitives
+ -- Skip secondary dispatch table and secondary dispatch table of
+ -- predefined primitives
Next_Elmt (AI_Tag_Elmt);
+ Next_Elmt (AI_Tag_Elmt);
-- Build the secondary table containing pointers to primitives
-- (used to give support to Generic Dispatching Constructors).
Make_Secondary_DT
(Typ => Typ,
Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => -1,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
Build_Thunks => False,
Result => Result);
- Next_Elmt (AI_Tag_Elmt);
- -- Skip the secondary dispatch table of predefined primitives
+ -- Skip secondary dispatch table and secondary dispatch table of
+ -- predefined primitives
Next_Elmt (AI_Tag_Elmt);
+ Next_Elmt (AI_Tag_Elmt);
Suffix_Index := Suffix_Index + 1;
Next_Elmt (AI_Tag_Comp);
New_Reference_To
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+ -- Generate a SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
-- Generate:
-- DT : Dispatch_Table_Wrapper (Nb_Prim);
-- for DT'Alignment use Address'Alignment;
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier =>
-- specific tagged type, as opposed to one of its ancestors.
-- If the type is an unconstrained type extension, we are building the
-- dispatch table of its anonymous base type, so the external tag, if
- -- any was specified, must be retrieved from the first subtype.
+ -- any was specified, must be retrieved from the first subtype. Go to
+ -- the full view in case the clause is in the private part.
else
declare
Def : constant Node_Id := Get_Attribute_Definition_Clause
- (First_Subtype (Typ),
+ (Underlying_Type (First_Subtype (Typ)),
Attribute_External_Tag);
Old_Val : String_Id;
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
Append_To (Result,
Make_Object_Declaration (Loc,
exit when Parent_Typ = Current_Typ;
- if Is_CPP_Class (Parent_Typ)
- or else Is_Interface (Typ)
- then
+ if Is_CPP_Class (Parent_Typ) then
+
-- The tags defined in the C++ side will be inherited when
-- the object is constructed (Exp_Ch3.Build_Init_Procedure)
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
+ -- Retrieve the ultimate alias of the primitive for proper
+ -- handling of renamings and eliminated primitives.
+
+ E := Ultimate_Alias (Prim);
+
if Is_Imported (Prim)
or else Present (Interface_Alias (Prim))
or else Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Eliminated (E)
then
null;
else
- -- Traverse the list of aliased entities to handle
- -- renamings of predefined primitives.
-
- E := Prim;
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
-
if not Is_Predefined_Dispatching_Operation (E)
and then not Is_Abstract_Subprogram (E)
and then not Present (Interface_Alias (E))
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
end if;
end if;
- -- Initialize the table of ancestor tags
+ -- Initialize the table of ancestor tags if not building static
+ -- dispatch table
if not Building_Static_DT (Typ)
and then not Is_Interface (Typ)
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
end if;
- -- Inherit the dispatch tables of the parent
-
- -- There is no need to inherit anything from the parent when building
- -- static dispatch tables because the whole dispatch table (including
- -- inherited primitives) has been already built.
+ -- Inherit the dispatch tables of the parent. There is no need to
+ -- inherit anything from the parent when building static dispatch tables
+ -- because the whole dispatch table (including inherited primitives) has
+ -- been already built.
if Building_Static_DT (Typ) then
null;
Append_List_To (Result, 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.
+ -- Populate the two auxiliary tables used for dispatching asynchronous,
+ -- conditional and timed selects for synchronized types that implement
+ -- a limited interface. Skip this step in Ravenscar profile or when
+ -- general dispatching is forbidden.
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
and then Has_Interfaces (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));
Analyze_List (Result, Suppress => All_Checks);
Set_Has_Dispatch_Table (Typ);
- -- Mark entities containing dispatch tables. Required by the
- -- backend to handle them properly.
+ -- Mark entities containing dispatch tables. Required by the backend to
+ -- handle them properly.
if not Is_Interface (Typ) then
declare
---------------
function Make_Tags (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Tname : constant Name_Id := Chars (Typ);
- Result : constant List_Id := New_List;
- AI_Tag_Comp : Elmt_Id;
- DT : Node_Id;
- DT_Constr_List : List_Id;
- DT_Ptr : Node_Id;
- Predef_Prims_Ptr : Node_Id;
- Iface_DT_Ptr : Node_Id;
- Nb_Prim : Nat;
- 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_Interfaces (Typ) then
- Collect_Interface_Components (Typ, Typ_Comps);
- end if;
-
- -- 1) Generate the primary tag entities
-
- -- Primary dispatch table containing user-defined primitives
-
- DT_Ptr := Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'P'));
- Set_Etype (DT_Ptr, RTE (RE_Tag));
-
- -- Primary dispatch table containing predefined primitives
-
- Predef_Prims_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'Y'));
- Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-
- -- Import the forward declaration of the Dispatch Table wrapper record
- -- (Make_DT will take care of its exportation)
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Result : constant List_Id := New_List;
+
+ procedure Import_DT
+ (Tag_Typ : Entity_Id;
+ DT : Entity_Id;
+ Is_Secondary_DT : Boolean);
+ -- Import the dispatch table DT of tagged type Tag_Typ. Required to
+ -- generate forward references and statically allocate the table. For
+ -- primary dispatch tables that require no dispatch table generate:
+ -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
+ -- $pragma import (ada, DT);
+ -- Otherwise generate:
+ -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
+ -- $pragma import (ada, DT);
- if Building_Static_DT (Typ) then
- DT :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'T'));
+ ---------------
+ -- Import_DT --
+ ---------------
- -- Generate:
- -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
- -- $pragma import (ada, DT);
+ procedure Import_DT
+ (Tag_Typ : Entity_Id;
+ DT : Entity_Id;
+ Is_Secondary_DT : Boolean)
+ is
+ DT_Constr_List : List_Id;
+ Nb_Prim : Nat;
- Set_Is_Imported (DT);
+ begin
+ Set_Is_Imported (DT);
+ Set_Ekind (DT, E_Constant);
+ Set_Related_Type (DT, Typ);
-- The scope must be set now to call Get_External_Name
-- Save this entity to allow Make_DT to generate its exportation
- Set_Dispatch_Table_Wrapper (Typ, DT);
+ Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
- if Has_DT (Typ) then
+ -- No dispatch table required
+
+ if not Is_Secondary_DT
+ and then not Has_DT (Tag_Typ)
+ then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+ else
-- Calculate the number of primitives of the dispatch table and
-- the size of the Type_Specific_Data record.
- Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ Nb_Prim :=
+ UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
-- If the tagged type has no primitives we add a dummy slot
-- whose address will be the tag of this type.
New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
+ end if;
+ end Import_DT;
+
+ -- Local variables
+
+ Tname : constant Name_Id := Chars (Typ);
+ AI_Tag_Comp : Elmt_Id;
+ DT : Node_Id := Empty;
+ DT_Ptr : Node_Id;
+ Predef_Prims_Ptr : Node_Id;
+ Iface_DT : Node_Id := Empty;
+ Iface_DT_Ptr : Node_Id;
+ New_Node : Node_Id;
+ Suffix_Index : Int;
+ Typ_Name : Name_Id;
+ Typ_Comps : Elist_Id;
+
+ -- Start of processing for Make_Tags
+
+ begin
+ -- 1) Generate the primary and secondary tag entities
+
+ -- Collect the components associated with secondary dispatch tables
+
+ if Has_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
+ end if;
+
+ -- 1) Generate the primary tag entities
+
+ -- Primary dispatch table containing user-defined primitives
+
+ DT_Ptr := Make_Defining_Identifier (Loc,
+ New_External_Name (Tname, 'P'));
+ Set_Etype (DT_Ptr, RTE (RE_Tag));
+
+ -- Primary dispatch table containing predefined primitives
+
+ Predef_Prims_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'Y'));
+ Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+
+ -- Import the forward declaration of the Dispatch Table wrapper record
+ -- (Make_DT will take care of its exportation)
+
+ if Building_Static_DT (Typ) then
+ Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+
+ DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'T'));
+
+ Import_DT (Typ, DT, Is_Secondary_DT => False);
+ if Has_DT (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
else
Append_To (Result,
Make_Object_Declaration (Loc,
- Defining_Identifier => DT,
- Aliased_Present => True,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
-
- Append_To (Result,
- Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
New_Occurrence_Of
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
end if;
Set_Is_True_Constant (DT_Ptr);
-- 2) Generate the secondary tag entities
if Has_Interfaces (Typ) then
- Suffix_Index := 0;
+
+ -- Note: The following value of Suffix_Index must be in sync with
+ -- the Suffix_Index values of secondary dispatch tables generated
+ -- by Make_DT.
+
+ Suffix_Index := 1;
-- For each interface type we build an unique external name
-- associated with its corresponding secondary dispatch table.
while Present (AI_Tag_Comp) loop
Get_Secondary_DT_External_Name
(Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
-
Typ_Name := Name_Find;
+ if Building_Static_DT (Typ) then
+ Iface_DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name
+ (Typ_Name, 'T', Suffix_Index => -1));
+ Import_DT
+ (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+ DT => Iface_DT,
+ Is_Secondary_DT => True);
+ end if;
+
-- Secondary dispatch table referencing thunks to user-defined
-- primitives covered by this interface.
(Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ if Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Interface_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+
-- Secondary dispatch table referencing thunks to predefined
-- primitives.
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.
+ -- 3) At the end of Access_Disp_Table, if the type has user-defined
+ -- primitives, we add the entity of an access type declaration that
+ -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
+ -- through the primary dispatch table.
+
+ if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
+ Analyze_List (Result);
-- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
-- 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,
+ else
+ 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_Prim_Ptr), 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_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
+ New_Occurrence_Of (DT_Prims, 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));
- 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
+ -- this type is never used in object declarations. It is only used
+ -- to simplify the expansion associated with dispatching calls.
- -- 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));
- Analyze_List (Result);
- Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+ -- Mark entity of dispatch table. Required by the back end to
+ -- handle them properly.
- -- Mark entity of dispatch table. Required by the backend to handle
- -- the properly.
+ Set_Is_Dispatch_Table_Entity (DT_Prims);
+ end;
+ end if;
- Set_Is_Dispatch_Table_Entity (DT_Prims);
- end;
+ -- Mark entities of dispatch table. Required by the back end to
+ -- handle them properly.
+
+ if Present (DT) then
+ Set_Is_Dispatch_Table_Entity (DT);
+ Set_Is_Dispatch_Table_Entity (Etype (DT));
+ end if;
+
+ if Present (Iface_DT) then
+ Set_Is_Dispatch_Table_Entity (Iface_DT);
+ Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
+ end if;
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Tag (DT_Ptr);
return Result;
end Make_Tags;
+ ---------------
+ -- New_Value --
+ ---------------
+
+ 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),
+ Prefix => Res);
+ else
+ return Res;
+ end if;
+ end New_Value;
+
-----------------------------------
-- Original_View_In_Visible_Part --
-----------------------------------
begin
-- The scope must be a package
- if Ekind (Scop) /= E_Package
- and then Ekind (Scop) /= E_Generic_Package
- then
+ if not Is_Package_Or_Generic_Package (Scop) then
return False;
end if;
Full_Typ := Corresponding_Concurrent_Type (Typ);
end if;
+ -- When a private tagged type is completed by a concurrent type,
+ -- retrieve the full view.
+
+ if Is_Private_Type (Full_Typ) then
+ Full_Typ := Full_View (Full_Typ);
+ end if;
+
if Ekind (Prim_Op) = E_Function then
-- Protected function
-- Register_Primitive --
------------------------
- procedure Register_Primitive
+ function Register_Primitive
(Loc : Source_Ptr;
- Prim : Entity_Id;
- Ins_Nod : Node_Id)
+ Prim : Entity_Id) return List_Id
is
DT_Ptr : Entity_Id;
Iface_Prim : Entity_Id;
Iface_Typ : Entity_Id;
Iface_DT_Ptr : Entity_Id;
Iface_DT_Elmt : Elmt_Id;
- L : List_Id;
+ L : constant List_Id := New_List;
Pos : Uint;
Tag : Entity_Id;
Tag_Typ : Entity_Id;
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if not RTE_Available (RE_Tag) then
- return;
+ return L;
end if;
if not Present (Interface_Alias (Prim)) then
DT_Ptr :=
Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
- -- Register copy of the pointer to the 'size primitive in the TSD.
+ -- Register copy of the pointer to the 'size primitive in the TSD
if Chars (Prim) = Name_uSize
and then RTE_Record_Component_Available (RE_Size_Func)
then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Size_Function (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Size_Func => Prim));
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Prim_Op_Address (Loc,
Typ => Tag_Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
if not Is_Ancestor (Iface_Typ, Tag_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
-- the secondary dispatch table of Prim's controlling type with
-- Thunk_Id's address.
Iface_Prim := Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ);
- L := New_List;
+
+ Prepend_To (L, Thunk_Code);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
- Insert_Actions_After (Ins_Nod, L);
-
else
pragma Assert (Pos /= Uint_0
and then Pos <= DT_Entry_Count (Tag));
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
- Insert_Actions_After (Ins_Nod, L);
end if;
end if;
end if;
+
+ return L;
end Register_Primitive;
-------------------------
begin
pragma Assert (Present (First_Tag_Component (Typ)));
- -- Set the DT_Position for each primitive operation. Perform some
- -- sanity checks to avoid to build completely inconsistent dispatch
- -- tables.
+ -- Set the DT_Position for each primitive operation. Perform some sanity
+ -- checks to avoid building inconsistent dispatch tables.
- -- First stage: Set the DTC entity of all the primitive operations
- -- This is required to properly read the DT_Position attribute in
- -- the latter stages.
+ -- First stage: Set the DTC entity of all the primitive operations. This
+ -- is required to properly read the DT_Position attribute in the latter
+ -- stages.
Prim_Elmt := First_Prim;
Count_Prim := 0;
-- Predefined primitives have a separate dispatch table
if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ or else
+ Is_Predefined_Dispatching_Alias (Prim))
then
Count_Prim := Count_Prim + 1;
end if;
procedure Set_Fixed_Prim (Pos : Nat) is
begin
- pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
+ pragma Assert (Pos <= Count_Prim);
Fixed_Prim (Pos) := True;
exception
when Constraint_Error =>
end if;
end Set_All_DT_Position;
- -----------------------------
- -- Set_Default_Constructor --
- -----------------------------
+ --------------------------
+ -- Set_CPP_Constructors --
+ --------------------------
- procedure Set_Default_Constructor (Typ : Entity_Id) is
+ procedure Set_CPP_Constructors (Typ : Entity_Id) is
Loc : Source_Ptr;
Init : Entity_Id;
- Param : Entity_Id;
E : Entity_Id;
+ Found : Boolean := False;
+ P : Node_Id;
+ Parms : List_Id;
begin
- -- Look for the default constructor entity. For now only the
- -- default constructor has the flag Is_Constructor.
+ -- Look for the constructor entities
E := Next_Entity (Typ);
- while Present (E)
- and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
- loop
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ -- Create the init procedure
+
+ Found := True;
+ Loc := Sloc (E);
+ Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Discard_Node (
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Init,
+ Parameter_Specifications => Parms)));
+
+ 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);
+ end if;
+
Next_Entity (E);
end loop;
- -- Create the init procedure
-
- if Present (E) then
- Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
- Param := Make_Defining_Identifier (Loc, Name_X);
-
- Discard_Node (
- 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);
-
-- If there are no constructors, mark the type as abstract since we
-- won't be able to declare objects of that type.
- else
+ if not Found then
Set_Is_Abstract_Type (Typ);
end if;
- end Set_Default_Constructor;
+ end Set_CPP_Constructors;
--------------------------
-- Set_DTC_Entity_Value --
Write_Str (" is null;");
end if;
+ if Is_Eliminated (Ultimate_Alias (Prim)) then
+ Write_Str (" (eliminated)");
+ end if;
+
Write_Eol;
Next_Elmt (Elmt);
OSDN Git Service
