Dear All,
These are both quite trivial fixes and can be understood from
ChangeLogs and comments in the patch.
Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.6?
Cheers
Paul
2011-04-29 Paul Thomas <[email protected]>
PR fortran/48462
* trans-expr.c (arrayfunc_assign_needs_temporary): Deal with
automatic reallocation when the lhs is a target.
PR fortran/48462
* trans-expr.c (fcncall_realloc_result): Make sure that the
result dtype field is set before the function call.
2011-04-29 Paul Thomas <[email protected]>
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.
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 <[email protected]>
!
*************** 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 <[email protected]>
+ !
+ 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
