From f90642b60dbe411df162174646348f4a7d5e1a63 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 30 Apr 2011 12:00:50 +0000 Subject: [PATCH] 2011-04-30 Paul Thomas PR fortran/48462 PR fortran/48746 * trans-expr.c ( arrayfunc_assign_needs_temporary): Need a temp if automatic reallocation on assignement is active, the lhs is a target and the rhs an intrinsic function. (realloc_lhs_bounds_for_intrinsic_call): Rename as next. (fcncall_realloc_result): Renamed version of above function. Free the original descriptor data after the function call.Set the bounds and the offset so that the lbounds are one. (gfc_trans_arrayfunc_assign): Call renamed function. 2011-04-30 Paul Thomas PR fortran/48462 PR fortran/48746 * gfortran.dg/realloc_on_assign_7.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173214 138bc75d-0d04-0410-961f-82ee72b054a4 index da7cfba..1d678e6 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). */ @@ -5528,23 +5531,38 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss) } +/* 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 -realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank) +fcncall_realloc_result (gfc_se *se, int rank) { tree desc; + tree res_desc; tree tmp; tree offset; int n; - /* Use the allocation done by the library. */ + /* 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); - 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))); + 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 to + the lhs descriptor. */ + 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); + gfc_add_modify (&se->post, desc, res_desc); offset = gfc_index_zero_node; tmp = gfc_index_one_node; @@ -5580,7 +5598,6 @@ realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank) } - /* Try to translate array(:) = func (...), where func is a transformational array function, without using a temporary. Returns NULL if this isn't the case. */ @@ -5645,7 +5662,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ss->is_alloc_lhs = 1; } else - realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank); + fcncall_realloc_result (&se, expr1->rank); } gfc_conv_function_expr (&se, expr2); new file mode 100644 index 0000000..f871d27 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 @@ -0,0 +1,84 @@ +! { 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 +! +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 :: 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 + 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 + 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 +! + 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) + if (any (lbound (tmp) .ne. [1,1])) call abort + if (any (ubound (tmp) .ne. [10,12])) call abort + end subroutine +end program main + -- 1.7.0.4