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

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 173130)
--- gcc/fortran/trans-expr.c	(working copy)
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5444,5452 ****
      return true;
  
    /* If we have reached here with an intrinsic function, we do not
!      need a temporary.  */
    if (expr2->value.function.isym)
!     return false;
  
    /* If the LHS is a dummy, we need a temporary if it is not
       INTENT(OUT).  */
--- 5444,5455 ----
      return true;
  
    /* If we have reached here with an intrinsic function, we do not
!      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 (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).  */
*************** fcncall_realloc_result (gfc_se *se)
*** 5547,5552 ****
--- 5550,5558 ----
    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);
+   /* Unallocated, the descriptor does not have a dtype.  */
+   tmp = gfc_conv_descriptor_dtype (res_desc);
+   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    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
*************** fcncall_realloc_result (gfc_se *se)
*** 5556,5565 ****
    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)));
  }
  
  
--- 5562,5567 ----
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 173130)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(working copy)
***************
*** 1,6 ****
--- 1,8 ----
  ! { 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>
  !
*************** program main
*** 8,30 ****
    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
--- 10,41 ----
    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 :: b(:,:)
  
      allocate(b(3,3))
      allocate(delta(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
*************** contains
*** 47,51 ****
      if (any (delta > 1d-12)) call abort
      if (any (lbound (a) .ne. [1, 1])) call abort
    end subroutine
  end program main
- 
--- 58,81 ----
      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