-- --
-- 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 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
-
- -- We do not generate dispatch tables for the internal type
+ -- 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 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)))
+ 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)));
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);
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;
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 ???
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
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
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 (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),
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));
Tname : constant Name_Id := Chars (Typ);
AI_Tag_Comp : Elmt_Id;
- DT : Node_Id;
+ DT : Node_Id := Empty;
DT_Ptr : Node_Id;
Predef_Prims_Ptr : Node_Id;
- Iface_DT : 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;
(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,
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);
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
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;
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 --