diff options
| -rw-r--r-- | gcc/ada/exp_attr.adb | 252 | ||||
| -rw-r--r-- | 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 8564bea..4bb8d19 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 54e08c6..20cf387 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. |