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

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

	PR fortran/48462
	* trans-expr.c (arrayfunc_assign_needs_temporary): Deal with
	automatic reallocation when the lhs is a target.

	PR fortran/48746
	* trans-expr.c (fcncall_realloc_result): Make sure that the
	result dtype field is set before the function call.

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

	PR fortran/48462
	* gfortran.dg/realloc_on_assign_7.f03: Modify to test for lhs
	being a target.

	PR fortran/48746
	* gfortran.dg/realloc_on_assign_7.f03: Add subroutine pr48746.

From-SVN: r173185

gcc/fortran/ChangeLog

+2011-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* trans-expr.c (arrayfunc_assign_needs_temporary): Deal with
+	automatic reallocation when the lhs is a target.
+
+	PR fortran/48746
+	* trans-expr.c (fcncall_realloc_result): Make sure that the
+	result dtype field is set before the function call.
+
 2011-04-29  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/48810

gcc/fortran/trans-expr.c

@@ -5444,9 +5444,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
     return true;
 
   /* If we have reached here with an intrinsic function, we do not
-     need a temporary.  */
+     need a temporary except in the particular case that reallocation
+     on assignment is active and the lhs is allocatable and a target.  */
   if (expr2->value.function.isym)
-    return false;
+    return (gfc_option.flag_realloc_lhs
+	      && sym->attr.allocatable
+	      && sym->attr.target);
 
   /* If the LHS is a dummy, we need a temporary if it is not
      INTENT(OUT).  */
@@ -5545,6 +5548,9 @@ fcncall_realloc_result (gfc_se *se)
   /* 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);
@@ -5556,10 +5562,6 @@ fcncall_realloc_result (gfc_se *se)
   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->post, tmp, gfc_get_dtype (TREE_TYPE (desc)));
 }
 
 

gcc/testsuite/ChangeLog

+2011-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/48462
+	* gfortran.dg/realloc_on_assign_7.f03: Modify to test for lhs
+	being a target.
+
+	PR fortran/48746
+	* gfortran.dg/realloc_on_assign_7.f03: Add subroutine pr48746.
+
 2011-04-29  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/48810

gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03

 ! { dg-do run }
 ! Check the fix for PR48462 in which the assignments involving matmul
 ! seg faulted because a was automatically freed before the assignment.
+! Since it is related, the test for the fix of PR48746 has been added
+! as a subroutine by that name.
 !
 ! Contributed by John Nedney  <ortp21@gmail.com>
 !
@@ -8,23 +10,32 @@ program main
   implicit none
   integer, parameter :: dp = kind(0.0d0)
   real(kind=dp), allocatable :: delta(:,:)
+  real(kind=dp), allocatable, target :: a(:,:)
+  real(kind=dp), pointer :: aptr(:,:)
+
+  allocate(a(3,3))
+  aptr => a
   
   call foo
+  if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated
   call bar
+  if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated
+  call foobar
+  if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates
+
+  call pr48746
 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])
+    b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
 
     a = matmul( matmul( a, b ), b )
     delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
@@ -47,5 +58,24 @@ contains
     if (any (delta > 1d-12)) call abort
     if (any (lbound (a) .ne. [1, 1])) call abort
   end subroutine
+  subroutine foobar
+    integer :: i
+    a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
+  end subroutine
+  subroutine pr48746
+! This is a further wrinkle on the original problem and came about
+! because the dtype field of the result argument, passed to matmul,
+! was not being set. This is needed by matmul for the rank.
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+!
+    implicit none
+    integer, parameter :: m=10, n=12, count=4
+    real :: optmatmul(m, n)
+    real :: a(m, count), b(count, n), c(m, n)
+    real, dimension(:,:), allocatable :: tmp
+    call random_number(a)
+    call random_number(b)
+    tmp = matmul(a,b)
+  end subroutine
 end program main
-