[Ada] Fix spurious error on renaming of component of return value

[Eric Botcazou <ebotcazou at adacore dot com>]

This is a long-standing regression present in the compiler: it issues an 
unexpected error on the renaming of a component of the return value of a 
function call, when the return type has dynamic size and the renaming is 
declared at library level.

Tested on x86_64-suse-linux, applied on the mainline.


2016-02-29  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/ada-tree.h (DECL_RETURN_VALUE_P): New macro.
	* gcc-interface/gigi.h (gigi): Remove useless attribute.
	(gnat_gimplify_expr): Likewise.
	(gnat_to_gnu_external): Declare.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Factor out
	code dealing with the expression of external constants into...
	Invoke gnat_to_gnu_external instead.
	<E_Variable>: Invoke gnat_to_gnu_external to translate renamed objects
	when not for a definition.  Deal with COMPOUND_EXPR and variables with
	DECL_RETURN_VALUE_P set for renamings and with the case of a dangling
	'reference to a function call in a renaming.  Remove obsolete test and
	adjust associated comment.
	* gcc-interface/trans.c (Call_to_gnu): Set DECL_RETURN_VALUE_P on the
	temporaries created to hold the return value, if any.
	(gnat_to_gnu_external): ...this.  New function.
	* gcc-interface/utils.c (create_var_decl): Detect a constant created
	to hold 'reference to function call.
	* gcc-interface/utils2.c (build_unary_op) <ADDR_EXPR>: Add folding
	for COMPOUND_EXPR in the DECL_RETURN_VALUE_P case.


2016-02-29  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/renaming8.adb: New test.
	* gnat.dg/renaming8_pkg1.ads: New helper.
	* gnat.dg/renaming8_pkg2.ad[sb]: Likewise.
	* gnat.dg/renaming8_pkg3.ad[sb]: Likewise.


-- 
Eric Botcazou

Index: gcc-interface/ada-tree.h
===================================================================
--- gcc-interface/ada-tree.h	(revision 233738)
+++ gcc-interface/ada-tree.h	(working copy)
@@ -457,6 +457,10 @@ do {						   \
    a discriminant of a discriminated type without default expression.  */
 #define DECL_INVARIANT_P(NODE) DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE))
 
+/* Nonzero in a VAR_DECL if it is a temporary created to hold the return
+   value of a function call or 'reference to a function call.  */
+#define DECL_RETURN_VALUE_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE))
+
 /* In a FIELD_DECL corresponding to a discriminant, contains the
    discriminant number.  */
 #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 233738)
+++ gcc-interface/decl.c	(working copy)
@@ -552,31 +552,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	  && Present (Expression (Declaration_Node (gnat_entity)))
 	  && Nkind (Expression (Declaration_Node (gnat_entity)))
 	     != N_Allocator)
-	{
-	  bool went_into_elab_proc = false;
-	  int save_force_global = force_global;
-
 	  /* The expression may contain N_Expression_With_Actions nodes and
-	     thus object declarations from other units.  In this case, even
-	     though the expression will eventually be discarded since not a
-	     constant, the declarations would be stuck either in the global
-	     varpool or in the current scope.  Therefore we force the local
-	     context and create a fake scope that we'll zap at the end.  */
-	  if (!current_function_decl)
-	    {
-	      current_function_decl = get_elaboration_procedure ();
-	      went_into_elab_proc = true;
-	    }
-	  force_global = 0;
-	  gnat_pushlevel ();
-
-	  gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
-
-	  gnat_zaplevel ();
-	  force_global = save_force_global;
-	  if (went_into_elab_proc)
-	    current_function_decl = NULL_TREE;
-	}
+	     thus object declarations from other units.  Discard them.  */
+	gnu_expr
+	  = gnat_to_gnu_external (Expression (Declaration_Node (gnat_entity)));
 
       /* ... fall through ... */
 
@@ -611,13 +590,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	tree renamed_obj = NULL_TREE;
 	tree gnu_object_size;
 
+	/* We need to translate the renamed object even though we are only
+	   referencing the renaming.  But it may contain a call for which
+	   we'll generate a temporary to hold the return value and which
+	   is part of the definition of the renaming, so discard it.  */
 	if (Present (Renamed_Object (gnat_entity)) && !definition)
 	  {
 	    if (kind == E_Exception)
 	      gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
 					     NULL_TREE, 0);
 	    else
-	      gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
+	      gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
 	  }
 
 	/* Get the type after elaborating the renamed object.  */
@@ -976,14 +959,39 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	      inner = TREE_OPERAND (inner, 0);
 	    /* Expand_Dispatching_Call can prepend a comparison of the tags
 	       before the call to "=".  */
-	    if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR)
+	    if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
+		|| TREE_CODE (inner) == COMPOUND_EXPR)
 	      inner = TREE_OPERAND (inner, 1);
 	    if ((TREE_CODE (inner) == CALL_EXPR
 		 && !call_is_atomic_load (inner))
 		|| TREE_CODE (inner) == ADDR_EXPR
 		|| TREE_CODE (inner) == NULL_EXPR
 		|| TREE_CODE (inner) == CONSTRUCTOR
-		|| CONSTANT_CLASS_P (inner))
+		|| CONSTANT_CLASS_P (inner)
+		/* We need to detect the case where a temporary is created to
+		   hold the return value, since we cannot safely rename it at
+		   top level as it lives only in the elaboration routine.  */
+		|| (TREE_CODE (inner) == VAR_DECL
+		    && DECL_RETURN_VALUE_P (inner))
+		/* We also need to detect the case where the front-end creates
+		   a dangling 'reference to a function call at top level and
+		   substitutes it in the renaming, for example:
+
+		     q__b : boolean renames r__f.e (1);
+
+	           can be rewritten into:
+
+		     q__R1s : constant q__A2s := r__f'reference;
+		     [...]
+		     q__b : boolean renames q__R1s.all.e (1);
+
+		   We cannot safely rename the rewritten expression since the
+		   underlying object lives only in the elaboration routine.  */
+		|| (TREE_CODE (inner) == INDIRECT_REF
+		    && (inner
+			  = remove_conversions (TREE_OPERAND (inner, 0), true))
+		    && TREE_CODE (inner) == VAR_DECL
+		    && DECL_RETURN_VALUE_P (inner)))
 	      ;
 
 	    /* Case 2: if the renaming entity need not be materialized, use
@@ -991,8 +999,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	       means that the caller is responsible for evaluating the address
 	       of the renaming in the correct place for the definition case to
 	       instantiate the SAVE_EXPRs.  */
-	    else if (TREE_CODE (inner) != COMPOUND_EXPR
-		     && !Materialize_Entity (gnat_entity))
+	    else if (!Materialize_Entity (gnat_entity))
 	      {
 		tree init = NULL_TREE;
 
@@ -1001,7 +1008,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 					 &init);
 
 		/* We cannot evaluate the first arm of a COMPOUND_EXPR in the
-		   correct place for this case, hence the above test.  */
+		   correct place for this case.  */
 		gcc_assert (!init);
 
 		/* No DECL_EXPR will be created so the expression needs to be
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h	(revision 233738)
+++ gcc-interface/gigi.h	(working copy)
@@ -246,7 +246,7 @@ extern "C" {
    structures and then generates code.  */
 extern void gigi (Node_Id gnat_root,
 	          int max_gnat_node,
-                  int number_name ATTRIBUTE_UNUSED,
+                  int number_name,
 		  struct Node *nodes_ptr,
 		  struct Flags *Flags_Ptr,
 		  Node_Id *next_node_ptr,
@@ -270,17 +270,19 @@ extern void gigi (Node_Id gnat_root,
 #endif
 
 /* GNAT_NODE is the root of some GNAT tree.  Return the root of the
-   GCC tree corresponding to that GNAT tree.  Normally, no code is generated;
-   we just return an equivalent tree which is used elsewhere to generate
-   code.  */
+   GCC tree corresponding to that GNAT tree.  */
 extern tree gnat_to_gnu (Node_Id gnat_node);
 
+/* Similar to gnat_to_gnu, but discard any object that might be created in
+   the course of the translation of GNAT_NODE, which must be an "external"
+   expression in the sense that it will be elaborated elsewhere.  */
+extern tree gnat_to_gnu_external (Node_Id gnat_node);
+
 /* GNU_STMT is a statement.  We generate code for that statement.  */
 extern void gnat_expand_stmt (tree gnu_stmt);
 
 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
-extern int gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
-                               gimple_seq *post_p ATTRIBUTE_UNUSED);
+extern int gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, gimple_seq *);
 
 /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 233738)
+++ gcc-interface/trans.c	(working copy)
@@ -4336,7 +4336,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
 		      && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
 			 == INTEGER_CST))
 	      && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
-    gnu_retval = create_temporary ("R", gnu_result_type);
+    {
+      gnu_retval = create_temporary ("R", gnu_result_type);
+      DECL_RETURN_VALUE_P (gnu_retval) = 1;
+    }
 
   /* Create the list of the actual parameters as GCC expects it, namely a
      chain of TREE_LIST nodes in which the TREE_VALUE field of each node
@@ -4461,7 +4464,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
 	     we need to create a temporary for the return value because we must
 	     preserve it before copying back at the very end.  */
 	  if (!in_param && returning_value && !gnu_retval)
-	    gnu_retval = create_temporary ("R", gnu_result_type);
+	    {
+	      gnu_retval = create_temporary ("R", gnu_result_type);
+	      DECL_RETURN_VALUE_P (gnu_retval) = 1;
+	    }
 
 	  /* If we haven't pushed a binding level, push a new one.  This will
 	     narrow the lifetime of the temporary we are about to make as much
@@ -7808,6 +7814,37 @@ gnat_to_gnu (Node_Id gnat_node)
 
   return gnu_result;
 }
+
+/* Similar to gnat_to_gnu, but discard any object that might be created in
+   the course of the translation of GNAT_NODE, which must be an "external"
+   expression in the sense that it will be elaborated elsewhere.  */
+
+tree
+gnat_to_gnu_external (Node_Id gnat_node)
+{
+  const int save_force_global = force_global;
+  bool went_into_elab_proc = false;
+
+  /* Force the local context and create a fake scope that we zap
+     at the end so declarations will not be stuck either in the
+     global varpool or in the current scope.  */
+  if (!current_function_decl)
+    {
+      current_function_decl = get_elaboration_procedure ();
+      went_into_elab_proc = true;
+    }
+  force_global = 0;
+  gnat_pushlevel ();
+
+  tree gnu_result = gnat_to_gnu (gnat_node);
+
+  gnat_zaplevel ();
+  force_global = save_force_global;
+  if (went_into_elab_proc)
+    current_function_decl = NULL_TREE;
+
+  return gnu_result;
+}
 
 /* Subroutine of above to push the exception label stack.  GNU_STACK is
    a pointer to the stack to update and GNAT_LABEL, if present, is the
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c	(revision 233738)
+++ gcc-interface/utils.c	(working copy)
@@ -2464,6 +2464,22 @@ create_var_decl (tree name, tree asm_nam
 		   && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
 		  name, type);
 
+  /* Detect constants created by the front-end to hold 'reference to function
+     calls for stabilization purposes.  This is needed for renaming.  */
+  if (const_flag && init && POINTER_TYPE_P (type))
+    {
+      tree inner = init;
+      if (TREE_CODE (inner) == COMPOUND_EXPR)
+	inner = TREE_OPERAND (inner, 1);
+      inner = remove_conversions (inner, true);
+      if (TREE_CODE (inner) == ADDR_EXPR
+	  && ((TREE_CODE (TREE_OPERAND (inner, 0)) == CALL_EXPR
+	       && !call_is_atomic_load (TREE_OPERAND (inner, 0)))
+	      || (TREE_CODE (TREE_OPERAND (inner, 0)) == VAR_DECL
+		  && DECL_RETURN_VALUE_P (TREE_OPERAND (inner, 0)))))
+	DECL_RETURN_VALUE_P (var_decl) = 1;
+    }
+
   /* If this is external, throw away any initializations (they will be done
      elsewhere) unless this is a constant for which we would like to remain
      able to get the initializer.  If we are defining a global here, leave a
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c	(revision 233738)
+++ gcc-interface/utils2.c	(working copy)
@@ -1383,8 +1383,11 @@ build_unary_op (enum tree_code op_code,
 	     since the middle-end cannot handle it.  But we don't it in the
 	     general case because it may introduce aliasing issues if the
 	     first operand is an indirect assignment and the second operand
-	     the corresponding address, e.g. for an allocator.  */
-	  if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+	     the corresponding address, e.g. for an allocator.  However do
+	     it for a return value to expose it for later recognition.  */
+	  if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE
+	      || (TREE_CODE (TREE_OPERAND (operand, 1)) == VAR_DECL
+		  && DECL_RETURN_VALUE_P (TREE_OPERAND (operand, 1))))
 	    {
 	      result = build_unary_op (ADDR_EXPR, result_type,
 				       TREE_OPERAND (operand, 1));

-- { dg-do run }
-- { dg-options "-gnatp" }

with Renaming8_Pkg1; use Renaming8_Pkg1;

procedure Renaming8 is
begin
  if not B then
    raise Program_Error;
  end if;
end;

with Renaming8_Pkg2; use Renaming8_Pkg2;

package Renaming8_Pkg1 is

  B: Boolean renames F.E(1);

end Renaming8_Pkg1;

package Renaming8_Pkg3 is

  function Last_Index return Integer;

end Renaming8_Pkg3;

package body Renaming8_Pkg2 is

  function F return Rec is
  begin
    return (E => (others => True));
  end;

end Renaming8_Pkg2;

with Renaming8_Pkg3; use Renaming8_Pkg3;

package Renaming8_Pkg2 is

  type Arr is array (Positive range 1 .. Last_Index) of Boolean;

  type Rec is record
     E : Arr;
  end record;

  function F return Rec;

end Renaming8_Pkg2;

package body Renaming8_Pkg3 is

  function Last_Index return Integer is
  begin
    return 16;
  end;

end Renaming8_Pkg3;