2015-05-16 Mikael Morin <mikael@gcc.gnu.org

	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/65792
	* trans-expr.c (gfc_trans_subcomponent_assign): Always assign
	the expression component to the destination. In addition, if
	the component has allocatable components, copy them and
	deallocate those of the expression, if it is not a variable.
	The expression is fixed if not a variable to prevent multiple
	evaluations.

2015-05-16  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/65792
	* gfortran.dg/derived_constructor_components_5: New test

From-SVN: r223234

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1b455b56e0f7ffd43feec47d0d95020400b52104..c06627e32c917ad4d1490884394cf162dcacd93b 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2015-05-16  Mikael Morin  <mikael@gcc.gnu.org
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/65792
+       * trans-expr.c (gfc_trans_subcomponent_assign): Always assign
+       the expression component to the destination. In addition, if
+       the component has allocatable components, copy them and
+       deallocate those of the expression, if it is not a variable.
+       The expression is fixed if not a variable to prevent multiple
+       evaluations.
+
 2015-05-12  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/66111
@@ -133,12 +144,12 @@
        to be referenced always.
        (build_class_array_ref): Adapt retrieval of array descriptor.
        (build_array_ref): Likewise.
-       (gfc_conv_array_ref): Hand the vptr or the descriptor to 
+       (gfc_conv_array_ref): Hand the vptr or the descriptor to
        build_array_ref depending whether the sym is class or not.
        (gfc_trans_array_cobounds):  Select correct gfc_array_spec for
        regular and class arrays.
        (gfc_trans_array_bounds): Likewise.
-       (gfc_trans_dummy_array_bias): Likewise. 
+       (gfc_trans_dummy_array_bias): Likewise.
        (gfc_get_dataptr_offset): Correcting call of build_array_ref.
        (gfc_conv_expr_descriptor): Set the array's offset to -1 when
        lbound in inner most dim is 1 and symbol non-pointer/assoc.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c71037f7b9a465c8e6ae102a3f09fc98e87efcd4..9be8a4206faa84cb9aced1e0a6bda667c0100c53 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7050,19 +7050,31 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
     {
       if (expr->expr_type != EXPR_STRUCTURE)
        {
+         tree dealloc = NULL_TREE;
          gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, expr);
          gfc_add_block_to_block (&block, &se.pre);
+         /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
+            expression in  a temporary variable and deallocate the allocatable
+            components. Then we can the copy the expression to the result.  */
          if (cm->ts.u.derived->attr.alloc_comp
-             && expr->expr_type == EXPR_VARIABLE)
+             && expr->expr_type != EXPR_VARIABLE)
+           {
+             se.expr = gfc_evaluate_now (se.expr, &block);
+             dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
+                                                  expr->rank);
+           }
+         gfc_add_modify (&block, dest,
+                         fold_convert (TREE_TYPE (dest), se.expr));
+         if (cm->ts.u.derived->attr.alloc_comp
+             && expr->expr_type != EXPR_NULL)
            {
              tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
                                         dest, expr->rank);
              gfc_add_expr_to_block (&block, tmp);
+             if (dealloc != NULL_TREE)
+               gfc_add_expr_to_block (&block, dealloc);
            }
-         else
-           gfc_add_modify (&block, dest,
-                           fold_convert (TREE_TYPE (dest), se.expr));
          gfc_add_block_to_block (&block, &se.post);
        }
       else

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 123dadfbaf31fb73cb33a2ac7ee6cffe5d478b4c..7d58a1883a15df3e15a49bcde96b68ba3ae7eb52 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-05-16  Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/65792
+       * gfortran.dg/derived_constructor_components_5: New test
+
 2015-05-16  Uros Bizjak  <ubizjak@gmail.com>
 
        PR target/66140

diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90
new file mode 100644 (file)
index 0000000..083c131
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90
@@ -0,0 +1,59 @@
+! { dg-do run }\r
+!\r
+! PR fortran/65792\r
+! The evaluation of the argument in the call to new_prt_spec2\r
+! failed to properly initialize the comp component.\r
+! While the array contents were properly copied, the array bounds remained\r
+! uninitialized.\r
+!\r
+! Contributed by Dominique D'Humieres <dominiq@lps.ens.fr>\r
+\r
+program main\r
+  implicit none\r
+\r
+  integer, parameter :: n = 2\r
+\r
+  type :: string_t\r
+     character(LEN=1), dimension(:), allocatable :: chars\r
+  end type string_t\r
+\r
+  type :: string_container_t\r
+     type(string_t) :: comp\r
+  end type string_container_t\r
+\r
+  type(string_t) :: prt_in, tmp, tmpa(n)\r
+  type(string_container_t) :: tmpc, tmpca(n)\r
+  integer :: i, j, k\r
+\r
+  do i=1,2\r
+\r
+! scalar elemental function with structure constructor\r
+     prt_in = string_t(["D"])\r
+     tmpc = new_prt_spec2 (string_container_t(prt_in))\r
+     if (any(tmpc%comp%chars .ne. ["D"])) call abort\r
+     deallocate (prt_in%chars)\r
+     deallocate(tmpc%comp%chars)\r
+! Check that function arguments are OK too\r
+     tmpc = new_prt_spec2 (string_container_t(new_str_t(["h","e","l","l","o"])))\r
+     if (any(tmpc%comp%chars .ne. ["h","e","l","l","o"])) call abort\r
+     deallocate(tmpc%comp%chars)\r
+\r
+  end do\r
+\r
+contains\r
+\r
+  impure elemental function new_prt_spec2 (name) result (prt_spec)\r
+    type(string_container_t), intent(in) :: name\r
+    type(string_container_t) :: prt_spec\r
+    prt_spec = name\r
+  end function new_prt_spec2\r
+\r
+\r
+  function new_str_t (name) result (prt_spec)\r
+    character (*), intent(in), dimension (:) :: name\r
+    type(string_t) :: prt_spec\r
+    prt_spec = string_t(name)\r
+  end function new_str_t\r
+\r
+end program main\r
+\r