re PR ada/58264 (incorrect bounds of string when assigned from dereference of function result)

	PR ada/58264
	* gcc-interface/trans.c (Attribute_to_gnu): Define GNAT_PREFIX local
	variable and use it throughout.
	<Attr_Length>: Note whether the prefix is the dereference of a pointer
	to unconstrained array and, in this case, capture the result for both
	Attr_First and Attr_Last.

From-SVN: r202694

gcc/ada/ChangeLog

 2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
 
+	PR ada/58264
+	* gcc-interface/trans.c (Attribute_to_gnu): Define GNAT_PREFIX local
+	variable and use it throughout.
+	<Attr_Length>: Note whether the prefix is the dereference of a pointer
+	to unconstrained array and, in this case, capture the result for both
+	Attr_First and Attr_Last.
+
+2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Abstract_State>: New.
 
 2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/gcc-interface/trans.c

@@ -1391,6 +1391,7 @@ Pragma_to_gnu (Node_Id gnat_node)
 static tree
 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 {
+  const Node_Id gnat_prefix = Prefix (gnat_node);
   tree gnu_prefix, gnu_type, gnu_expr;
   tree gnu_result_type, gnu_result = error_mark_node;
   bool prefix_unused = false;
@@ -1400,13 +1401,13 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
      parameter types might be incomplete types coming from a limited with.  */
   if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
       && Is_Dispatch_Table_Entity (Etype (gnat_node))
-      && Nkind (Prefix (gnat_node)) == N_Identifier
-      && Is_Subprogram (Entity (Prefix (gnat_node)))
-      && Is_Public (Entity (Prefix (gnat_node)))
-      && !present_gnu_tree (Entity (Prefix (gnat_node))))
-    gnu_prefix = get_minimal_subprog_decl (Entity (Prefix (gnat_node)));
+      && Nkind (gnat_prefix) == N_Identifier
+      && Is_Subprogram (Entity (gnat_prefix))
+      && Is_Public (Entity (gnat_prefix))
+      && !present_gnu_tree (Entity (gnat_prefix)))
+    gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
   else
-    gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+    gnu_prefix = gnat_to_gnu (gnat_prefix);
   gnu_type = TREE_TYPE (gnu_prefix);
 
   /* If the input is a NULL_EXPR, make a new one.  */
@@ -1549,8 +1550,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	 since it can use a special calling convention on some platforms,
 	 which cannot be propagated to the access type.  */
       else if (attribute == Attr_Access
-	       && Nkind (Prefix (gnat_node)) == N_Identifier
-	       && is_cplusplus_method (Entity (Prefix (gnat_node))))
+	       && Nkind (gnat_prefix) == N_Identifier
+	       && is_cplusplus_method (Entity (gnat_prefix)))
 	post_error ("access to C++ constructor or member function not allowed",
 		    gnat_node);
 
@@ -1661,13 +1662,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	  /* If this is a dereference and we have a special dynamic constrained
 	     subtype on the prefix, use it to compute the size; otherwise, use
 	     the designated subtype.  */
-	  if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
+	  if (Nkind (gnat_prefix) == N_Explicit_Dereference)
 	    {
-	      Node_Id gnat_deref = Prefix (gnat_node);
 	      Node_Id gnat_actual_subtype
-		= Actual_Designated_Subtype (gnat_deref);
+		= Actual_Designated_Subtype (gnat_prefix);
 	      tree gnu_ptr_type
-		= TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
+		= TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
 
 	      if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
 		  && Present (gnat_actual_subtype))
@@ -1728,7 +1728,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	  align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
 	else
 	  {
-	    Node_Id gnat_prefix = Prefix (gnat_node);
 	    Entity_Id gnat_type = Etype (gnat_prefix);
 	    unsigned int double_align;
 	    bool is_capped_double, align_clause;
@@ -1800,28 +1799,38 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 			 : 1), i;
 	struct parm_attr_d *pa = NULL;
 	Entity_Id gnat_param = Empty;
+	bool unconstrained_ptr_deref = false;
 
 	/* Make sure any implicit dereference gets done.  */
 	gnu_prefix = maybe_implicit_deref (gnu_prefix);
 	gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 
-	/* We treat unconstrained array In parameters specially.  */
-	if (!Is_Constrained (Etype (Prefix (gnat_node))))
-	  {
-	    Node_Id gnat_prefix = Prefix (gnat_node);
-
-	    /* This is the direct case.  */
-	    if (Nkind (gnat_prefix) == N_Identifier
-		&& Ekind (Entity (gnat_prefix)) == E_In_Parameter)
-	      gnat_param = Entity (gnat_prefix);
-
-	    /* This is the indirect case.  Note that we need to be sure that
-	       the access value cannot be null as we'll hoist the load.  */
-	    if (Nkind (gnat_prefix) == N_Explicit_Dereference
-		&& Nkind (Prefix (gnat_prefix)) == N_Identifier
-		&& Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter
-		&& Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
-	      gnat_param = Entity (Prefix (gnat_prefix));
+	/* We treat unconstrained array In parameters specially.  We also note
+	   whether we are dereferencing a pointer to unconstrained array.  */
+	if (!Is_Constrained (Etype (gnat_prefix)))
+	  switch (Nkind (gnat_prefix))
+	    {
+	    case N_Identifier:
+	      /* This is the direct case.  */
+	      if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
+		gnat_param = Entity (gnat_prefix);
+	      break;
+
+	    case N_Explicit_Dereference:
+	      /* This is the indirect case.  Note that we need to be sure that
+		 the access value cannot be null as we'll hoist the load.  */
+	      if (Nkind (Prefix (gnat_prefix)) == N_Identifier
+		  && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
+		{
+		  if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
+		    gnat_param = Entity (Prefix (gnat_prefix));
+		}
+	      else
+		unconstrained_ptr_deref = true;
+	      break;
+
+	    default:
+	      break;
 	  }
 
 	/* If the prefix is the view conversion of a constrained array to an
@@ -1956,22 +1965,54 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	  {
 	    gnu_result
 	      = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
-	    if (attribute == Attr_First)
-	      pa->first = gnu_result;
-	    else if (attribute == Attr_Last)
-	      pa->last = gnu_result;
-	    else
-	      pa->length = gnu_result;
+	    switch (attribute)
+	      {
+	      case Attr_First:
+		pa->first = gnu_result;
+		break;
+
+	      case Attr_Last:
+		pa->last = gnu_result;
+		break;
+
+	      case Attr_Length:
+	      case Attr_Range_Length:
+		pa->length = gnu_result;
+		break;
+
+	      default:
+		gcc_unreachable ();
+	      }
 	  }
 
-	/* Set the source location onto the predicate of the condition in the
-	   'Length case but do not do it if the expression is cached to avoid
-	   messing up the debug info.  */
-	else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
-		 && TREE_CODE (gnu_result) == COND_EXPR
-		 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
-	  set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
-				       gnat_node);
+	/* Otherwise, evaluate it each time it is referenced.  */
+	else
+	  switch (attribute)
+	    {
+	    case Attr_First:
+	    case Attr_Last:
+	      /* If we are dereferencing a pointer to unconstrained array, we
+		 need to capture the value because the pointed-to bounds may
+		 subsequently be released.  */
+	      if (unconstrained_ptr_deref)
+		gnu_result
+		  = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
+	      break;
+
+	    case Attr_Length:
+	    case Attr_Range_Length:
+	      /* Set the source location onto the predicate of the condition
+		 but not if the expression is cached to avoid messing up the
+		 debug info.  */
+	      if (TREE_CODE (gnu_result) == COND_EXPR
+		  && EXPR_P (TREE_OPERAND (gnu_result, 0)))
+		set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
+					     gnat_node);
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	    }
 
 	break;
       }
@@ -2144,8 +2185,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 
     case Attr_Mechanism_Code:
       {
+	Entity_Id gnat_obj = Entity (gnat_prefix);
 	int code;
-	Entity_Id gnat_obj = Entity (Prefix (gnat_node));
 
 	prefix_unused = true;
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -2180,10 +2221,11 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
      it has a side-effect.  But don't do it if the prefix is just an entity
      name.  However, if an access check is needed, we must do it.  See second
      example in AARM 11.6(5.e).  */
-  if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
-      && !Is_Entity_Name (Prefix (gnat_node)))
-    gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
-				       gnu_result);
+  if (prefix_unused
+      && TREE_SIDE_EFFECTS (gnu_prefix)
+      && !Is_Entity_Name (gnat_prefix))
+    gnu_result
+      = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
 
   *gnu_result_type_p = gnu_result_type;
   return gnu_result;

gcc/testsuite/ChangeLog

+2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
+
+	*  gnat.dg/array_bounds_test2.adb: New test.
+
 2013-09-18  Kyrylo Tkachov  <kyrylo.tkachov@arm.com>
 
 	* g++.dg/debug/dwarf2/omp-fesdr.C: Check for fopenmp effective target.

gcc/testsuite/gnat.dg/array_bounds_test2.adb

+--  { dg-do run }
+
+with Ada.Unchecked_Deallocation;
+
+procedure Array_Bounds_Test2 is
+
+  type String_Ptr_T is access String;
+  procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr_T);
+  String_Data : String_Ptr_T := new String'("Hello World");
+
+  function Peek return String_Ptr_T is
+  begin
+    return String_Data;
+  end Peek;
+
+begin
+  declare
+    Corrupted_String : String := Peek.all;
+  begin
+    Free(String_Data);
+    if Corrupted_String'First /= 1 then
+      raise Program_Error;
+    end if;
+  end;
+end;