From: pault Date: Sun, 30 Jan 2011 17:50:01 +0000 (+0000) Subject: 2011-01-30 Paul Thomas X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=2de379fb8af6ff6269c87daf13c487c6d40e3664;p=thirdparty%2Fgcc.git 2011-01-30 Paul Thomas PR fortran/47523 * trans-expr.c (gfc_trans_assignment_1): If the rhs is an op expr and is assigned to a deferred character length scalar, make sure that the function is called before reallocation, so that the length is available. Include procedure pointer and procedure pointer component rhs as well. 2011-01-30 Paul Thomas PR fortran/47523 * trans-expr.c (gfc_trans_assignment_1): If the rhs is an op expr and is assigned to a deferred character length scalar, make sure that the function is called before reallocation, so that the length is available. Include procedure pointer and procedure pointer component rhs as well. PR fortran/45170 PR fortran/35810 PR fortran/47350 * gfortran.dg/allocatable_function_5.f90: New test not added by mistake on 2011-01-28. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@169413 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b1df4053d52b..ce56256017b8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2011-01-30 Paul Thomas + + PR fortran/47523 + * trans-expr.c (gfc_trans_assignment_1): If the rhs is an op + expr and is assigned to a deferred character length scalar, + make sure that the function is called before reallocation, + so that the length is available. Include procedure pointer + and procedure pointer component rhs as well. + + PR fortran/45170 + PR fortran/35810 + PR fortran/47350 + * gfortran.dg/allocatable_function_5.f90: New test not added by + mistake on 2011-01-28. + 2011-01-29 Tobias Burnus PR fortran/47531 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9bbe791d88bf..96828020689c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5977,6 +5977,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, stmtblock_t body; bool l_is_temp; bool scalar_to_array; + bool def_clen_func; tree string_length; int n; @@ -6097,10 +6098,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* For a deferred character length function, the function call must happen before the (re)allocation of the lhs, otherwise the character length of the result is not known. */ + def_clen_func = (((expr2->expr_type == EXPR_FUNCTION) + || (expr2->expr_type == EXPR_COMPCALL) + || (expr2->expr_type == EXPR_PPC)) + && expr2->ts.deferred); if (gfc_option.flag_realloc_lhs - && expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CHARACTER - && expr2->ts.deferred) + && (def_clen_func || expr2->expr_type == EXPR_OP) + && expr1->ts.deferred) gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ece39bc30e0b..a9e16459ecf8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-30 Paul Thomas + + PR fortran/47523 + * gfortran.dg/realloc_on_assign_5.f03: New test. + 2011-01-29 Ulrich Weigand * gfortran.dg/bessel_6.f90: XFAIL on spu-*-*. @@ -66,9 +71,8 @@ PR fortran/47350 * gfortran.dg/realloc_on_assign_3.f03: New test. * gfortran.dg/realloc_on_assign_4.f03: New test. - * gfortran.dg/realloc_on_assign_5.f90: New test. * gfortran.dg/allocatable_function_5.f90: New test. - * gfortran.dg/allocate_deferred_char_scalar_1.f90: New test. + * gfortran.dg/allocate_deferred_char_scalar_1.f03: New test. * gfortran.dg/deferred_type_param_2.f90: Remove two "not yet implemented" dg-errors. diff --git a/gcc/testsuite/gfortran.dg/allocatable_function_5.f90 b/gcc/testsuite/gfortran.dg/allocatable_function_5.f90 new file mode 100644 index 000000000000..8e7d49b0fa88 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_function_5.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Tests function return of deferred length scalars. +! +! Contributed by Paul Thomas +! +module m +contains + function mfoo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(2:4) + end function + function mbar (carg) + character (:), allocatable :: mbar + character (*) :: carg + mbar = carg(2:13) + end function +end module + + use m + character (:), allocatable :: lhs + lhs = foo ("foo calling ") + if (lhs .ne. "foo") call abort + if (len (lhs) .ne. 3) call abort + deallocate (lhs) + lhs = bar ("bar calling - baaaa!") + if (lhs .ne. "bar calling") call abort + if (len (lhs) .ne. 12) call abort + deallocate (lhs) + lhs = mfoo ("mfoo calling ") + if (lhs .ne. "foo") call abort + if (len (lhs) .ne. 3) call abort + deallocate (lhs) + lhs = mbar ("mbar calling - baaaa!") + if (lhs .ne. "bar calling") call abort + if (len (lhs) .ne. 12) call abort +contains + function foo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(1:3) + end function + function bar (carg) + character (:), allocatable :: bar + character (*) :: carg + bar = carg(1:12) + end function +end diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03 new file mode 100644 index 000000000000..db4233d5f774 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! Test the fix for PR47523 in which concatenations did not work +! correctly with assignments to deferred character length scalars. +! +! Contributed by Thomas Koenig +! +program main + implicit none + character(:), allocatable :: a, b + a = 'a' + if (a .ne. 'a') call abort + a = a // 'x' + if (a .ne. 'ax') call abort + if (len (a) .ne. 2) call abort + a = (a(2:2)) + if (a .ne. 'x') call abort + if (len (a) .ne. 1) call abort +end program main