From eb0f4e48fafd54870e5326b2febdc06cad80d176 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 27 May 2019 11:04:48 +0000 Subject: [PATCH] trans.c (Identifier_to_gnu): Minor tweaks. * gcc-interface/trans.c (Identifier_to_gnu): Minor tweaks. (gnat_to_gnu): Do not convert the result if it is a reference to an unconstrained array used as the prefix of an attribute reference that requires an lvalue. From-SVN: r271653 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/gcc-interface/trans.c | 25 ++++++++++++++++++------- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/aliased2.adb | 23 +++++++++++++++++++++++ 4 files changed, 52 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/aliased2.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7b975bd7673..fc08a02a4f8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-05-27 Eric Botcazou + + * gcc-interface/trans.c (Identifier_to_gnu): Minor tweaks. + (gnat_to_gnu): Do not convert the result if it is a reference to an + unconstrained array used as the prefix of an attribute reference that + requires an lvalue. + 2019-05-27 Eric Botcazou * gcc-interface/trans.c (Gigi_Types_Compatible): New predicate. diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3af5eee9e91..2efc800d60e 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -1110,11 +1110,12 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) } else { - /* We want to use the Actual_Subtype if it has already been elaborated, - otherwise the Etype. Avoid using Actual_Subtype for packed arrays to - simplify things. */ + /* We use the Actual_Subtype only if it has already been elaborated, + as we may be invoked precisely during its elaboration, otherwise + the Etype. Avoid using it for packed arrays to simplify things. */ if ((Ekind (gnat_entity) == E_Constant - || Ekind (gnat_entity) == E_Variable || Is_Formal (gnat_entity)) + || Ekind (gnat_entity) == E_Variable + || Is_Formal (gnat_entity)) && !(Is_Array_Type (Etype (gnat_entity)) && Present (Packed_Array_Impl_Type (Etype (gnat_entity)))) && Present (Actual_Subtype (gnat_entity)) @@ -8685,7 +8686,11 @@ gnat_to_gnu (Node_Id gnat_node) declaration, return the result unmodified because we want to use the return slot optimization in this case. - 5. Finally, if the type of the result is already correct. */ + 5. If this is a reference to an unconstrained array which is used as the + prefix of an attribute reference that requires an lvalue, return the + result unmodified because we want return the original bounds. + + 6. Finally, if the type of the result is already correct. */ if (Present (Parent (gnat_node)) && (lhs_or_actual_p (gnat_node) @@ -8734,13 +8739,19 @@ gnat_to_gnu (Node_Id gnat_node) else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) gnu_result = error_mark_node; - else if (Present (Parent (gnat_node)) + else if (TREE_CODE (gnu_result) == CALL_EXPR + && Present (Parent (gnat_node)) && (Nkind (Parent (gnat_node)) == N_Object_Declaration || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration) - && TREE_CODE (gnu_result) == CALL_EXPR && return_type_with_variable_size_p (TREE_TYPE (gnu_result))) ; + else if (TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF + && Present (Parent (gnat_node)) + && Nkind (Parent (gnat_node)) == N_Attribute_Reference + && lvalue_required_for_attribute_p (Parent (gnat_node))) + ; + else if (TREE_TYPE (gnu_result) != gnu_result_type) gnu_result = convert (gnu_result_type, gnu_result); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a75cdb79eb2..56084cc83f3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-05-27 Eric Botcazou + + * gnat.dg/aliased2.adb: New test. + 2019-05-27 Eric Botcazou * gnat.dg/limited_with7.ad[sb]: New test. diff --git a/gcc/testsuite/gnat.dg/aliased2.adb b/gcc/testsuite/gnat.dg/aliased2.adb new file mode 100644 index 00000000000..0e1adacd898 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliased2.adb @@ -0,0 +1,23 @@ +-- { dg-do run } + +procedure Aliased2 is + + type Rec is record + Data : access constant String; + end record; + + function Get (S : aliased String) return Rec is + R : Rec := (Data => S'Unchecked_Access); + begin + return R; + end; + + S : aliased String := "Hello"; + + R : Rec := Get (S); + +begin + if R.Data'Length /= S'Length then + raise Program_Error; + end if; +end; -- 2.30.2