From: Eric Botcazou <ebotcazou@adacore.com>
Date: Mon, 27 May 2019 11:04:48 +0000 (+0000)
Subject: trans.c (Identifier_to_gnu): Minor tweaks.
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=eb0f4e48fafd54870e5326b2febdc06cad80d176;p=gcc.git

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
---

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  <ebotcazou@adacore.com>
+
+	* 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  <ebotcazou@adacore.com>
 
 	* 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  <ebotcazou@adacore.com>
+
+	* gnat.dg/aliased2.adb: New test.
+
 2019-05-27  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* 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;