The compiler crashes on a function with an In-Out parameter which returns a
discriminated record type with default discriminant.
Tested on x86_64-suse-linux, applied on the mainline.
2014-11-05 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/trans.c (Subprogram_Body_to_gnu): For a function with
copy-in/copy-out parameters and which returns by invisible reference,
do not create the variable for the return value; instead, manually
generate the indirect copy out statements on exit.
(gnat_to_gnu) <N_Simple_Return_Statement>: Adjust accordingly and build
a simple indirect assignment for the return value.
2014-11-05 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/discr42.adb: New test.
* gnat.dg/discr42_pkg.ad[sb]: New helper.
--
Eric Botcazou-- { dg-do run }
with Discr42_Pkg; use Discr42_Pkg;
procedure Discr42 is
R : Rec;
Pos : Natural := 1;
begin
R := F (Pos);
if Pos /= 2 then
raise Program_Error;
end if;
if R /= (D => True, N => 4) then
raise Program_Error;
end if;
end;package body Discr42_Pkg is
function F (Pos : in out Natural) return Rec is
begin
Pos := Pos + 1;
if Pos > 1 then
return (D => True, N => Pos * 2);
else
return (D => False);
end if;
end;
end Discr42_Pkg;Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 217152)
+++ gcc-interface/trans.c (working copy)
@@ -3547,13 +3547,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
- if (gnu_cico_list)
- gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
+ if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
+ gnu_return_var_elmt = gnu_cico_list;
/* If the function returns by invisible reference, make it explicit in the
- function body. See gnat_to_gnu_entity, E_Subprogram_Type case.
- Handle the explicit case here and the copy-in/copy-out case below. */
- if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
+ function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
{
TREE_TYPE (gnu_result_decl)
= build_reference_type (TREE_TYPE (gnu_result_decl));
@@ -3573,9 +3572,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
begin_subprog_body (gnu_subprog_decl);
- /* If there are In Out or Out parameters, we need to ensure that the return
- statement properly copies them out. We do this by making a new block and
- converting any return into a goto to a label at the end of the block. */
+ /* If there are copy-in/copy-out parameters, we need to ensure that they are
+ properly copied out by the return statement. We do this by making a new
+ block and converting any return into a goto to a label at the end of the
+ block. */
if (gnu_cico_list)
{
tree gnu_return_var = NULL_TREE;
@@ -3586,19 +3586,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
start_stmt_group ();
gnat_pushlevel ();
- /* If this is a function with In Out or Out parameters, we also need a
- variable for the return value to be placed. */
- if (gnu_return_var_elmt)
+ /* If this is a function with copy-in/copy-out parameters and which does
+ not return by invisible reference, we also need a variable for the
+ return value to be placed. */
+ if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
{
tree gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
- /* If the function returns by invisible reference, make it
- explicit in the function body. See gnat_to_gnu_entity,
- E_Subprogram_Type case. */
- if (TREE_ADDRESSABLE (gnu_subprog_type))
- gnu_return_type = build_reference_type (gnu_return_type);
-
gnu_return_var
= create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
gnu_return_type, NULL_TREE, false, false,
@@ -3693,7 +3688,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
the label and copy statement. */
if (gnu_cico_list)
{
- tree gnu_retval;
+ const Node_Id gnat_end_label
+ = End_Label (Handled_Statement_Sequence (gnat_node));
gnu_return_var_stack->pop ();
@@ -3701,14 +3697,45 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
add_stmt (build1 (LABEL_EXPR, void_type_node,
gnu_return_label_stack->last ()));
- if (list_length (gnu_cico_list) == 1)
- gnu_retval = TREE_VALUE (gnu_cico_list);
+ /* If this is a function which returns by invisible reference, the
+ return value has already been dealt with at the return statements,
+ so we only need to indirectly copy out the parameters. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
+ {
+ tree gnu_ret_deref
+ = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
+ tree t;
+
+ gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
+
+ for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
+ {
+ tree gnu_field_deref
+ = build_component_ref (gnu_ret_deref, NULL_TREE,
+ TREE_PURPOSE (t), true);
+ gnu_result = build2 (MODIFY_EXPR, void_type_node,
+ gnu_field_deref, TREE_VALUE (t));
+ add_stmt_with_node (gnu_result, gnat_end_label);
+ }
+ }
+
+ /* Otherwise, if this is a procedure or a function which does not return
+ by invisible reference, we can do a direct block-copy out. */
else
- gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
- gnu_cico_list);
+ {
+ tree gnu_retval;
+
+ if (list_length (gnu_cico_list) == 1)
+ gnu_retval = TREE_VALUE (gnu_cico_list);
+ else
+ gnu_retval
+ = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
+ gnu_cico_list);
+
+ gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
+ add_stmt_with_node (gnu_result, gnat_end_label);
+ }
- add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
- End_Label (Handled_Statement_Sequence (gnat_node)));
gnat_poplevel ();
gnu_result = end_stmt_group ();
}
@@ -6539,9 +6566,11 @@ gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
- /* If this function has copy-in/copy-out parameters, get the real
- object for the return. See Subprogram_to_gnu. */
- if (TYPE_CI_CO_LIST (gnu_subprog_type))
+ /* If this function has copy-in/copy-out parameters parameters and
+ doesn't return by invisible reference, get the real object for
+ the return. See Subprogram_Body_to_gnu. */
+ if (TYPE_CI_CO_LIST (gnu_subprog_type)
+ && !TREE_ADDRESSABLE (gnu_subprog_type))
gnu_ret_obj = gnu_return_var_stack->last ();
else
gnu_ret_obj = DECL_RESULT (current_function_decl);
@@ -6615,8 +6644,8 @@ gnat_to_gnu (Node_Id gnat_node)
tree gnu_ret_deref
= build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
gnu_ret_obj);
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_ret_deref, gnu_ret_val);
+ gnu_result = build2 (MODIFY_EXPR, void_type_node,
+ gnu_ret_deref, gnu_ret_val);
add_stmt_with_node (gnu_result, gnat_node);
gnu_ret_val = NULL_TREE;
}
@@ -6629,7 +6658,7 @@ gnat_to_gnu (Node_Id gnat_node)
that label. The return proper will be handled elsewhere. */
if (gnu_return_label_stack->last ())
{
- if (gnu_ret_obj)
+ if (gnu_ret_val)
add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
gnu_ret_val));
