diff options
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 303 |
1 files changed, 190 insertions, 113 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d33698d55ec..92bcc03bdab 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4497,6 +4497,196 @@ package body Exp_Ch3 is return; + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide object to ensure that we copy the full object, + -- unless we are targetting a VM where interfaces are handled by + -- VM itself. Note that if the root type of Typ is an ancestor + -- of Expr's type, both types share the same dispatch table and + -- there is no need to displace the pointer. + + elsif Comes_From_Source (N) + and then Is_Interface (Typ) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + if Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + + Decl_1 : Node_Id; + Decl_2 : Node_Id; + New_Expr : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then we + -- restore the original node to generate code that + -- statically displaces the pointer to the interface + -- component. + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Unchecked_Type_Conversion + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- CW : I'Class renames TiC!(Tmp.I_Tag); + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => + Unchecked_Convert_To (Expr_Typ, + Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Selector_Name => + New_Reference_To + (Find_Interface_Tag (Expr_Typ, Iface), + Loc)))); + + -- General case: + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is <Class_Wide_Subtype>; + -- Temp : CW := CW!(Obj'Address); + -- IW : I'Class renames Displace (Temp, I'Tag); + + else + -- Generate the equivalent record type + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Object_Definition (N), + Exp => Expression (N)); + + if not Is_Interface (Etype (Expression (N))) then + New_Expr := Relocate_Node (Expression (N)); + else + New_Expr := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address))); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr)); + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Iface))), + Loc)))))))); + end if; + + Insert_Action (N, Decl_1); + Rewrite (N, Decl_2); + Analyze (N); + + -- Replace internal identifier of Decl_2 by the identifier + -- found in the sources. We also have to exchange entities + -- containing their defining identifiers to ensure the + -- correct replacement of the object declaration by this + -- object renaming declaration (because such definings + -- identifier have been previously added by Enter_Name to + -- the current scope). We must preserve the homonym chain + -- of the source entity as well. + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Exchange_Entities (Defining_Identifier (N), Def_Id); + end; + end if; + + return; + else -- In most cases, we must check that the initial value meets any -- constraint imposed by the declared type. However, there is one @@ -4530,119 +4720,6 @@ package body Exp_Ch3 is end if; end if; - -- Ada 2005 (AI-251): Rewrite the expression that initializes a - -- class-wide object to ensure that we copy the full object, - -- unless we are targetting a VM where interfaces are handled by - -- VM itself. Note that if the root type of Typ is an ancestor - -- of Expr's type, both types share the same dispatch table and - -- there is no need to displace the pointer. - - -- Replace - -- CW : I'Class := Obj; - -- by - -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); - -- CW : I'Class renames Displace (Temp, I'Tag); - - if Is_Interface (Typ) - and then Is_Class_Wide_Type (Typ) - and then - (Is_Class_Wide_Type (Etype (Expr)) - or else - not Is_Ancestor (Root_Type (Typ), Etype (Expr))) - and then Comes_From_Source (Def_Id) - and then Tagged_Type_Expansion - then - declare - Decl_1 : Node_Id; - Decl_2 : Node_Id; - - begin - Decl_1 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Object_Definition => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Expression => - Unchecked_Convert_To - (Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Base_Address), - Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Expr), - Attribute_Name => Name_Address))))))); - - Insert_Action (N, Decl_1); - - Decl_2 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Name => - Unchecked_Convert_To ( - Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Displace), Loc), - - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (Decl_1), Loc), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table - (Root_Type (Typ)))), - Loc)))))))); - - Rewrite (N, Decl_2); - Analyze (N); - - -- Replace internal identifier of Decl_2 by the identifier - -- found in the sources. We also have to exchange entities - -- containing their defining identifiers to ensure the - -- correct replacement of the object declaration by this - -- object renaming declaration (because such definings - -- identifier have been previously added by Enter_Name to - -- the current scope). We must preserve the homonym chain - -- of the source entity as well. - - Set_Chars (Defining_Identifier (N), Chars (Def_Id)); - Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); - Exchange_Entities (Defining_Identifier (N), Def_Id); - - return; - end; - end if; - -- If the type is controlled and not inherently limited, then -- the target is adjusted after the copy and attached to the -- finalization list. However, no adjustment is done in the case |