re PR fortran/52012 (Wrong-code with realloc on assignment and RESHAPE w/ ORDER=)

2012-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52012
	* trans-expr.c (fcncall_realloc_result): Correct calculation of
	result offset. If variable shape is correct, retain the bounds,
	whatever they are.

2012-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52012
	* gfortran.dg/realloc_on_assign_10.f90: New test.
	* gfortran.dg/realloc_on_assign_11.f90: New test.

From-SVN: r183874

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 54bc970688beb46a8c6079522cacdb623fb402e7..f06158d9bd350ca1d9255b0cca7aca156a5d021f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2012-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/52012
+       * trans-expr.c (fcncall_realloc_result): Correct calculation of
+       result offset. If variable shape is correct, retain the bounds,
+       whatever they are.
+
 2012-01-28  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/52022

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 0eec9cee92d2c4188d5819625df2056c9e66eee4..c0c4c6fe9210d8c59c2f3a495b0ba567b0ff14f2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,6 +1,6 @@
 /* Expression translation
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -5536,7 +5536,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
 }
 
 
-/* For Assignment to a reallocatable lhs from intrinsic functions,
+/* For assignment to a reallocatable lhs from intrinsic functions,
    replace the se.expr (ie. the result) with a temporary descriptor.
    Null the data field so that the library allocates space for the
    result. Free the data of the original descriptor after the function,
@@ -5550,55 +5550,95 @@ fcncall_realloc_result (gfc_se *se, int rank)
   tree res_desc;
   tree tmp;
   tree offset;
+  tree zero_cond;
   int n;
 
   /* Use the allocation done by the library.  Substitute the lhs
      descriptor with a copy, whose data field is nulled.*/
   desc = build_fold_indirect_ref_loc (input_location, se->expr);
+
   /* Unallocated, the descriptor does not have a dtype.  */
   tmp = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
   res_desc = gfc_evaluate_now (desc, &se->pre);
   gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
   se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
 
-  /* Free the lhs after the function call and copy the result to
+  /* Free the lhs after the function call and copy the result data to
      the lhs descriptor.  */
   tmp = gfc_conv_descriptor_data_get (desc);
+  zero_cond = fold_build2_loc (input_location, EQ_EXPR,
+                              boolean_type_node, tmp,
+                              build_int_cst (TREE_TYPE (tmp), 0));
+  zero_cond = gfc_evaluate_now (zero_cond, &se->post);
   tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
   gfc_add_expr_to_block (&se->post, tmp);
-  gfc_add_modify (&se->post, desc, res_desc);
 
+  tmp = gfc_conv_descriptor_data_get (res_desc);
+  gfc_conv_descriptor_data_set (&se->post, desc, tmp);
+
+  /* Check that the shapes are the same between lhs and expression.  */
+  for (n = 0 ; n < rank; n++)
+    {
+      tree tmp1;
+      tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                            gfc_array_index_type, tmp, tmp1);
+      tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                            gfc_array_index_type, tmp, tmp1);
+      tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+                            gfc_array_index_type, tmp, tmp1);
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+                            boolean_type_node, tmp,
+                            gfc_index_zero_node);
+      tmp = gfc_evaluate_now (tmp, &se->post);
+      zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                  boolean_type_node, tmp,
+                                  zero_cond);
+    }
+
+  /* 'zero_cond' being true is equal to lhs not being allocated or the
+     shapes being different.  */
+  zero_cond = gfc_evaluate_now (zero_cond, &se->post);
+
+  /* Now reset the bounds returned from the function call to bounds based
+     on the lhs lbounds, except where the lhs is not allocated or the shapes
+     of 'variable and 'expr' are different. Set the offset accordingly.  */
   offset = gfc_index_zero_node;
-  tmp = gfc_index_one_node;
-  /* Now reset the bounds from zero based to unity based.  */
   for (n = 0 ; n < rank; n++)
     {
-      /* Accumulate the offset.  */
-      offset = fold_build2_loc (input_location, MINUS_EXPR,
-                               gfc_array_index_type,
-                               offset, tmp);
-      /* Now do the bounds.  */
-      gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
-      tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+      tree lbound;
+
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+      lbound = fold_build3_loc (input_location, COND_EXPR,
+                               gfc_array_index_type, zero_cond,
+                               gfc_index_one_node, lbound);
+      lbound = gfc_evaluate_now (lbound, &se->post);
+
+      tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
       tmp = fold_build2_loc (input_location, PLUS_EXPR,
-                            gfc_array_index_type,
-                            tmp, gfc_index_one_node);
+                            gfc_array_index_type, tmp, lbound);
       gfc_conv_descriptor_lbound_set (&se->post, desc,
-                                     gfc_rank_cst[n],
-                                     gfc_index_one_node);
+                                     gfc_rank_cst[n], lbound);
       gfc_conv_descriptor_ubound_set (&se->post, desc,
                                      gfc_rank_cst[n], tmp);
 
-      /* The extent for the next contribution to offset.  */
-      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                            gfc_array_index_type,
-                            gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
-                            gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
-      tmp = fold_build2_loc (input_location, PLUS_EXPR,
-                            gfc_array_index_type,
-                            tmp, gfc_index_one_node);
+      /* Accumulate the offset.  */
+      tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]);
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_array_index_type,
+                               lbound, tmp);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+                               gfc_array_index_type,
+                               offset, tmp);
+      offset = gfc_evaluate_now (offset, &se->post);
+
     }
+
   gfc_conv_descriptor_offset_set (&se->post, desc, offset);
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cdf7755350646a1cae9c00491e2f57993b44ff27..517b3d5c76b6a7a05dcf851bad919fca06c7d059 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/52012
+       * gfortran.dg/realloc_on_assign_10.f90: New test.
+       * gfortran.dg/realloc_on_assign_11.f90: New test.
+
 2012-01-12  Georg-Johann Lay  <avr@gjlay.de>
 
        Backport from mainline r183796

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90
new file mode 100644 (file)
index 0000000..787a56a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! PR52012 - with realloc_lhs active(ie. default condition) the
+! offset was wrongly calculated for a, after assignment.
+!
+! Reported by Reinhold Bader and Tobias Burnus  <burnus@gcc.gnu.org>
+! 
+program gf
+  implicit none
+  real, allocatable :: a(:,:,:)
+  real, parameter :: zero = 0.0, one = 1.0
+  real :: b(3,4,5) = zero
+  b(1,2,3) = one
+  allocate (a(size (b, 3), size (b, 2), size (b, 1)))
+  a = reshape (b, shape (a), order = [3, 2, 1])
+  if (any (a(:, 2, 1) .ne. [zero, zero, one, zero, zero])) call abort
+  if (a(3, 2, 1) /= one) call abort()
+  if (sum (abs (a)) /= one) call abort()
+end program

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90
new file mode 100644 (file)
index 0000000..ab96bb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! PR52012 - tests of automatic reallocation on assignment for variable = array_intrinsic
+!
+! Contributed by Tobias Burnus and Dominique Dhumieres
+!
+  integer, allocatable :: a(:), b(:), e(:,:)
+  integer :: c(1:5,1:5), d(1:5,1:5)
+  allocate(b(3))
+  b = [1,2,3]
+
+! Shape conforms so bounds follow allocation.
+  allocate (a(7:9))
+  a = reshape( b, shape=[size(b)])
+  if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [7,9,3,3])) call abort
+
+  deallocate (a)
+! 'a' not allocated so lbound defaults to 1.
+  a = reshape( b, shape=[size(b)])
+  if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [1,3,3,3])) call abort
+
+  deallocate (a)
+! Shape conforms so bounds follow allocation.
+  allocate (a(0:0))
+  a(0) = 1
+  if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [0,0,1,1])) call abort
+
+! 'a' not allocated so lbound defaults to 1.
+  e = matmul (c(2:5,:), d(:, 3:4))
+  if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [1,1,4,2,8,4,2])) call abort
+  deallocate (e)
+
+! Shape conforms so bounds follow allocation.
+  allocate (e(4:7, 11:12))
+  e = matmul (c(2:5,:), d(:, 3:4))
+  if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [4,11,7,12,8,4,2])) call abort
+end