From 3192631e2438b31b79d6aa9873b6ed83417af857 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 15 Oct 2007 15:54:33 +0200 Subject: [PATCH] exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and Unrestricted_Access. 2007-10-15 Javier Miranda * exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and Unrestricted_Access. Cleanup code that takes care of access to class-wide interface types plus removal of bizarre conversion of tagged object to access type (reported by Gary Dismukes). After this patch there is no need to perform any additional management on these nodes in Expand_Interface_Actuals. * exp_disp.adb (Expand_Interface_Actuals): Code cleanup. Remove code that handles use of 'Access and 'Unchecked_Access applied to actuals covering interface types. Such code is now centralized in Expand_N_Attribute_Reference. From-SVN: r129322 --- gcc/ada/exp_attr.adb | 252 +++++++++++++++++++++---------------------- gcc/ada/exp_disp.adb | 19 ++-- 2 files changed, 132 insertions(+), 139 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8564beadefe..4bb8d197a5a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -606,155 +606,155 @@ package body Exp_Attr is Attribute_Unchecked_Access | Attribute_Unrestricted_Access => - if Is_Access_Protected_Subprogram_Type (Btyp) then - Expand_Access_To_Protected_Op (N, Pref, Typ); + Access_Cases : declare + Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp); + Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); - -- If the prefix is a type name, this is a reference to the current - -- instance of the type, within its initialization procedure. - - elsif Is_Entity_Name (Pref) - and then Is_Type (Entity (Pref)) - then - declare - Par : Node_Id; - Formal : Entity_Id; - - begin - -- If the current instance name denotes a task type, then the - -- access attribute is rewritten to be the name of the "_task" - -- parameter associated with the task type's task procedure. - -- An unchecked conversion is applied to ensure a type match in - -- cases of expander-generated calls (e.g., init procs). - - if Is_Task_Type (Entity (Pref)) then - Formal := - First_Entity (Get_Task_Body_Procedure (Entity (Pref))); - while Present (Formal) loop - exit when Chars (Formal) = Name_uTask; - Next_Entity (Formal); - end loop; - - pragma Assert (Present (Formal)); - - Rewrite (N, - Unchecked_Convert_To (Typ, - New_Occurrence_Of (Formal, Loc))); - Set_Etype (N, Typ); + begin + if Is_Access_Protected_Subprogram_Type (Btyp) then + Expand_Access_To_Protected_Op (N, Pref, Typ); - -- The expression must appear in a default expression, (which - -- in the initialization procedure is the right-hand side of an - -- assignment), and not in a discriminant constraint. + -- If prefix is a type name, this is a reference to the current + -- instance of the type, within its initialization procedure. - else - Par := Parent (N); - while Present (Par) loop - exit when Nkind (Par) = N_Assignment_Statement; + elsif Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + then + declare + Par : Node_Id; + Formal : Entity_Id; - if Nkind (Par) = N_Component_Declaration then - return; - end if; + begin + -- If the current instance name denotes a task type, then + -- the access attribute is rewritten to be the name of the + -- "_task" parameter associated with the task type's task + -- procedure. An unchecked conversion is applied to ensure + -- a type match in cases of expander-generated calls (e.g. + -- init procs). + + if Is_Task_Type (Entity (Pref)) then + Formal := + First_Entity (Get_Task_Body_Procedure (Entity (Pref))); + while Present (Formal) loop + exit when Chars (Formal) = Name_uTask; + Next_Entity (Formal); + end loop; - Par := Parent (Par); - end loop; + pragma Assert (Present (Formal)); - if Present (Par) then Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Attribute_Name => Attribute_Name (N))); + Unchecked_Convert_To (Typ, + New_Occurrence_Of (Formal, Loc))); + Set_Etype (N, Typ); - Analyze_And_Resolve (N, Typ); - end if; - end if; - end; + -- The expression must appear in a default expression, + -- (which in the initialization procedure is the + -- right-hand side of an assignment), and not in a + -- discriminant constraint. - -- The following handles cases involving interfaces and when the - -- prefix of an access attribute is an explicit dereference. In the - -- case where the access attribute is specifically Attribute_Access, - -- we only do this when the context type is E_General_Access_Type, - -- and not for anonymous access types. It seems that this code should - -- be used for anonymous contexts as well, but that causes various - -- regressions, such as on prefix-notation calls to dispatching - -- operations and back-end errors on access type conversions. ??? - - elsif Id /= Attribute_Access - or else Ekind (Btyp) = E_General_Access_Type - then - declare - Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); - Parm_Ent : Entity_Id; - Conversion : Node_Id; + else + Par := Parent (N); + while Present (Par) loop + exit when Nkind (Par) = N_Assignment_Statement; - begin - -- If the prefix of an Access attribute is a dereference of an - -- access parameter (or a renaming of such a dereference) and - -- the context is a general access type (but not an anonymous - -- access type), then rewrite the attribute as a conversion of - -- the access parameter to the context access type. This will - -- result in an accessibility check being performed, if needed. - - -- (X.all'Access => Acc_Type (X)) - - -- Note: Limit the expansion of an attribute applied to a - -- dereference of an access parameter so that it's only done - -- for 'Access. This fixes a problem with 'Unrestricted_Access - -- that leads to errors in the case where the attribute type - -- is access-to-variable and the access parameter is - -- access-to-constant. The conversion is only done to get - -- accessibility checks, so it makes sense to limit it to - -- 'Access (and consistent with existing comment). - - if Nkind (Ref_Object) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Ref_Object)) - and then Id = Attribute_Access - then - Parm_Ent := Entity (Prefix (Ref_Object)); + if Nkind (Par) = N_Component_Declaration then + return; + end if; - if Ekind (Parm_Ent) in Formal_Kind - and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type - and then Present (Extra_Accessibility (Parm_Ent)) - then - Conversion := - Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))); + Par := Parent (Par); + end loop; - Rewrite (N, Conversion); - Analyze_And_Resolve (N, Typ); + if Present (Par) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Attribute_Name (N))); - return; + Analyze_And_Resolve (N, Typ); + end if; end if; - end if; + end; - -- Ada 2005 (AI-251): If the designated type is an interface, - -- then rewrite the referenced object as a conversion, to force - -- the displacement of the pointer to the secondary dispatch - -- table. + -- If the prefix of an Access attribute is a dereference of an + -- access parameter (or a renaming of such a dereference) and + -- the context is a general access type (but not an anonymous + -- access type), then rewrite the attribute as a conversion of + -- the access parameter to the context access type. This will + -- result in an accessibility check being performed, if needed. + + -- (X.all'Access => Acc_Type (X)) + + -- Note: Limit the expansion of an attribute applied to a + -- dereference of an access parameter so that it's only done + -- for 'Access. This fixes a problem with 'Unrestricted_Access + -- that leads to errors in the case where the attribute type + -- is access-to-variable and the access parameter is + -- access-to-constant. The conversion is only done to get + -- accessibility checks, so it makes sense to limit it to + -- 'Access. + + elsif Nkind (Ref_Object) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Ref_Object)) + and then Ekind (Btyp) = E_General_Access_Type + and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind + and then Ekind (Etype (Entity (Prefix (Ref_Object)))) + = E_Anonymous_Access_Type + and then Present (Extra_Accessibility + (Entity (Prefix (Ref_Object)))) + then + Rewrite (N, + Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)))); + Analyze_And_Resolve (N, Typ); - if Is_Interface (Directly_Designated_Type (Btyp)) then + -- Ada 2005 (AI-251): If the designated type is an interface we + -- add an implicit conversion to force the displacement of the + -- pointer to reference the secondary dispatch table. - -- When the object is an explicit dereference, just convert - -- the dereference's prefix. + elsif Is_Interface (Btyp_DDT) + and then (Comes_From_Source (N) + or else Comes_From_Source (Ref_Object) + or else (Nkind (Ref_Object) in N_Has_Chars + and then Chars (Ref_Object) = Name_uInit)) + then + if Nkind (Ref_Object) /= N_Explicit_Dereference then - if Nkind (Ref_Object) = N_Explicit_Dereference then - Conversion := - Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))); + -- No implicit conversion required if types match - -- It seems rather bizarre that we generate a conversion of - -- a tagged object to an access type, since such conversions - -- are not normally permitted, but Expand_N_Type_Conversion - -- (actually Expand_Interface_Conversion) is designed to - -- handle them in the interface case. Do we really want to - -- create such odd conversions??? + if Btyp_DDT /= Etype (Ref_Object) then + Rewrite (Prefix (N), + Convert_To (Directly_Designated_Type (Typ), + New_Copy_Tree (Prefix (N)))); - else - Conversion := - Convert_To (Typ, New_Copy_Tree (Ref_Object)); + Analyze_And_Resolve (Prefix (N), + Directly_Designated_Type (Typ)); end if; - Rewrite (N, Conversion); - Analyze_And_Resolve (N, Typ); + -- When the object is an explicit dereference, convert the + -- dereference's prefix. + + else + declare + Obj_DDT : constant Entity_Id := + Base_Type + (Directly_Designated_Type + (Etype (Prefix (Ref_Object)))); + begin + -- No implicit conversion required if designated types + -- match. + + if Obj_DDT /= Btyp_DDT + and then not (Is_Class_Wide_Type (Obj_DDT) + and then Etype (Obj_DDT) = Btyp_DDT) + then + Rewrite (N, + Convert_To (Typ, + New_Copy_Tree (Prefix (Ref_Object)))); + Analyze_And_Resolve (N, Typ); + end if; + end; end if; - end; - end if; + end if; + end Access_Cases; -------------- -- Adjacent -- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 54e08c6142c..20cf387d089 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1011,7 +1011,6 @@ package body Exp_Disp is ------------------------------ procedure Expand_Interface_Actuals (Call_Node : Node_Id) is - Loc : constant Source_Ptr := Sloc (Call_Node); Actual : Node_Id; Actual_Dup : Node_Id; Actual_Typ : Entity_Id; @@ -1020,7 +1019,6 @@ package body Exp_Disp is Formal : Entity_Id; Formal_Typ : Entity_Id; Subp : Entity_Id; - Nam : Name_Id; Formal_DDT : Entity_Id; Actual_DDT : Entity_Id; @@ -1106,18 +1104,13 @@ package body Exp_Disp is (Attribute_Name (Actual) = Name_Access or else Attribute_Name (Actual) = Name_Unchecked_Access) then - Nam := Attribute_Name (Actual); + -- This case must have been handled by the analysis and + -- expansion of 'Access. The only exception is when types + -- match and no further expansion is required. - Conversion := Convert_To (Formal_DDT, Prefix (Actual)); - Rewrite (Actual, Conversion); - Analyze_And_Resolve (Actual, Formal_DDT); - - Rewrite (Actual, - Unchecked_Convert_To (Formal_Typ, - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Actual), - Attribute_Name => Nam))); - Analyze_And_Resolve (Actual, Formal_Typ); + pragma Assert (Base_Type (Etype (Prefix (Actual))) + = Base_Type (Formal_DDT)); + null; -- No need to displace the pointer if the type of the actual -- coincides with the type of the formal. -- 2.30.2