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 <ebotca...@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 <ebotca...@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 BotcazouIndex: 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;
