diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 14 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 | 38 |
4 files changed, 61 insertions, 10 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4b84b20..0f7db3a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +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 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 73d8a5f..1582833 100644 --- a/gcc/fortran/trans-expr.c +++ b/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))); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 85a4461..42ea961 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +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 diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 index 8de46c0..ca9a2d9 100644 --- a/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 @@ -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> ! @@ -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 - |