re PR fortran/48462 (realloc on assignment: matmul Segmentation Fault with Allocatable Array)

2011-04-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48462
	* trans-expr.c (fcncall_realloc_result): Renamed version of
	realloc_lhs_bounds_for_intrinsic_call that does not touch the
	descriptor bounds anymore but makes a temporary descriptor to
	hold the result.
	(gfc_trans_arrayfunc_assign): Modify the reference to above
	renamed function.

2011-04-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48462
	* gfortran.dg/realloc_on_assign_7.f03: New test.

From-SVN: r172636

gcc/fortran/ChangeLog

@@ -1,3 +1,13 @@
+2011-04-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* trans-expr.c (fcncall_realloc_result): Renamed version of
+	realloc_lhs_bounds_for_intrinsic_call that does not touch the
+	descriptor bounds anymore but makes a temporary descriptor to
+	hold the result.
+	(gfc_trans_arrayfunc_assign): Modify the reference to above
+	renamed function.
+
 2011-05-17  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/48624

gcc/fortran/trans-expr.c

@@ -5528,55 +5528,38 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
 }
 
 
+/* 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,
+   in case it appears in an argument expression and transfer the
+   result to the original descriptor.  */
+
 static void
-realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se)
 {
   tree desc;
+  tree res_desc;
   tree tmp;
-  tree offset;
-  int n;
 
-  /* Use the allocation done by the library.  */
+  /* 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);
+  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 data to
+     it.  */
   tmp = gfc_conv_descriptor_data_get (desc);
   tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
-  gfc_add_expr_to_block (&se->pre, tmp);
-  gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+  gfc_add_expr_to_block (&se->post, tmp);
+  tmp = gfc_conv_descriptor_data_get (res_desc);
+  gfc_conv_descriptor_data_set (&se->post, desc, tmp);
+
   /* 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)));
-
-  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]);
-      tmp = fold_build2_loc (input_location, PLUS_EXPR,
-			     gfc_array_index_type,
-			     tmp, gfc_index_one_node);
-      gfc_conv_descriptor_lbound_set (&se->post, desc,
-				      gfc_rank_cst[n],
-				      gfc_index_one_node);
-      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);
-    }
-  gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+  gfc_add_modify (&se->post, tmp, gfc_get_dtype (TREE_TYPE (desc)));
 }
 
 
@@ -5646,7 +5629,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 	  ss->is_alloc_lhs = 1;
 	}
       else
-	realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+	fcncall_realloc_result (&se);
     }
 
   gfc_conv_function_expr (&se, expr2);

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2011-04-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* gfortran.dg/realloc_on_assign_7.f03: New test.
+
 2011-04-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/48602

gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03

@@ -0,0 +1,51 @@
+! { dg-do run }
+! Check the fix for PR48462 in which the assignments involving matmul
+! seg faulted because a was automatically freed before the assignment.
+!
+! Contributed by John Nedney  <ortp21@gmail.com>
+!
+program main
+  implicit none
+  integer, parameter :: dp = kind(0.0d0)
+  real(kind=dp), allocatable :: delta(:,:)
+  
+  call foo
+  call bar
+contains
+!
+! Original reduced version from comment #2
+  subroutine foo
+    implicit none
+    real(kind=dp), allocatable :: a(:,:)
+    real(kind=dp), allocatable :: b(:,:)
+
+    allocate(a(3,3))
+    allocate(b(3,3))
+    allocate(delta(3,3))
+
+    b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
+    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+
+    a = matmul( matmul( a, b ), b )
+    delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
+    if (any (delta > 1d-12)) call abort
+    if (any (lbound (a) .ne. [1, 1])) call abort
+  end subroutine
+!
+! Check that all is well when the shape of 'a' changes.
+  subroutine bar
+    implicit none
+    real(kind=dp), allocatable :: a(:,:)
+    real(kind=dp), allocatable :: b(:,:)
+
+    b = reshape ([1d0, 1d0, 1d0], [3,1])
+    a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+
+    a = matmul( a, matmul( a, b ) )
+
+    delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
+    if (any (delta > 1d-12)) call abort
+    if (any (lbound (a) .ne. [1, 1])) call abort
+  end subroutine
+end program main
+