trans.c (Subprogram_Body_to_gnu): For a function with copy-in/copy-out parameters...

	* 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.

From-SVN: r217155

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 72c0313afd3f5cc9f458344e943ebe46c9f61edc..c4b8640153335feef4705b533b66ad0f915c895c 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2014-11-05  Eric Botcazou  <ebotcazou@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  <ebotcazou@adacore.com>
 
        * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: For a

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 05b81ef75fb5dbae1bf5977e4f10a6ca95befd3f..01c9234e166a10ab0011ce874704d1c7d6a7d0bd 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -3547,13 +3547,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
   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_node)
 
   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_node)
       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_node)
      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_node)
       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));
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 913b5c727661cf38e8dc3ff2526e3966a6945f50..c699ce31b4fda897ed72debe6d97e334f2e4d56c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/discr42.adb: New test.
+       * gnat.dg/discr42_pkg.ad[sb]: New helper.
+
 2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/specs/private2.ads: New test.

diff --git a/gcc/testsuite/gnat.dg/discr42.adb b/gcc/testsuite/gnat.dg/discr42.adb
new file mode 100644 (file)
index 0000000..e3380b8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr42.adb
@@ -0,0 +1,22 @@
+-- { 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;

diff --git a/gcc/testsuite/gnat.dg/discr42_pkg.adb b/gcc/testsuite/gnat.dg/discr42_pkg.adb
new file mode 100644 (file)
index 0000000..8ec584c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr42_pkg.adb
@@ -0,0 +1,13 @@
+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;

diff --git a/gcc/testsuite/gnat.dg/discr42_pkg.ads b/gcc/testsuite/gnat.dg/discr42_pkg.ads
new file mode 100644 (file)
index 0000000..b9bef43
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr42_pkg.ads
@@ -0,0 +1,12 @@
+package Discr42_Pkg is
+
+   type Rec (D : Boolean := False) is record
+      case D is
+         when True  => N : Natural;
+         when False => null;
+      end case;
+   end record;
+
+   function F (Pos : in out Natural) return Rec;
+
+end Discr42_Pkg;