[Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

This is the last of three regressions caused by my introduction of
reallocation on assignment.  The comments in the patch adequately
explain what is being done.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.6?

Paul

2011-04-17  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-17  Paul Thomas  <pault@gcc.gnu.org>

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

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 172607)
--- gcc/fortran/trans-expr.c	(working copy)
*************** realloc_lhs_loop_for_fcn_call (gfc_se *s
*** 5528,5582 ****
  }
  
  
  static void
! realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
  {
    tree desc;
    tree tmp;
-   tree offset;
-   int n;
  
!   /* Use the allocation done by the library.  */
    desc = build_fold_indirect_ref_loc (input_location, se->expr);
    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);
    /* 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);
  }
  
  
--- 5528,5565 ----
  }
  
  
+ /* 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
! fcncall_realloc_result (gfc_se *se)
  {
    tree desc;
+   tree res_desc;
    tree tmp;
  
!   /* 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->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)));
  }
  
  
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5646,5652 ****
  	  ss->is_alloc_lhs = 1;
  	}
        else
! 	realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
      }
  
    gfc_conv_function_expr (&se, expr2);
--- 5629,5635 ----
  	  ss->is_alloc_lhs = 1;
  	}
        else
! 	fcncall_realloc_result (&se);
      }
  
    gfc_conv_function_expr (&se, expr2);
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 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
+