[Ada] Do not generate dangling references to bounds

[Eric Botcazou <ebotcazou at adacore dot com>]

This prevents gigi from generating dangling references to the bounds of an 
aliased parameter of an unconstrained array type.  This cannot happen in 
strict Ada but you can bypass the rules by means of 'Unchecked_Access.

Tested on x86_64-suse-linux, applied on the mainline and 9 branch.


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>

	* gnat.dg/aliased2.adb: New test.

-- 
Eric Botcazou

Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 271650)
+++ gcc-interface/trans.c	(working copy)
@@ -1110,11 +1110,12 @@ Identifier_to_gnu (Node_Id gnat_node, tr
     }
   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);
 

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