The attached patch fixes the PR and most of the remaining, if not all,
problems associated with deferred string length targets in the
associate construct.
Bootstraps and regtests on FC23/x86_64 - OK for trunk?
Paul
2017-09-29 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/77296
* resolve.c (resolve_assoc_var): Deferred character type
associate names must not receive an integer conatant length.
* symbol.c (gfc_is_associate_pointer): Deferred character
length functions also require an associate pointer.
* trans-decl.c (gfc_get_symbol_decl): Deferred character
length functions or derived type components require the assoc
name to have variable string length.
* trans-stmt.c (trans_associate_var): Set the string length of
deferred string length associate names. The address expression
is not needed for allocatable, pointer or dummy targets. Change
the comment about defered string length targets.
2017-09-29 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/77296
* gfortran.dg/associate_32.f03 : New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 253101)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8530,8536 ****
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
! if (!sym->ts.u.cl->length)
sym->ts.u.cl->length
= gfc_get_int_expr (gfc_default_integer_kind,
NULL, target->value.character.length);
--- 8530,8536 ----
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
! if (!sym->ts.u.cl->length && !sym->ts.deferred)
sym->ts.u.cl->length
= gfc_get_int_expr (gfc_default_integer_kind,
NULL, target->value.character.length);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 253101)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_is_associate_pointer (gfc_symbol* sy
*** 5054,5059 ****
--- 5054,5065 ----
if (sym->ts.type == BT_CLASS)
return true;
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && sym->assoc->target
+ && sym->assoc->target->expr_type == EXPR_FUNCTION)
+ return true;
+
if (!sym->assoc->variable)
return false;
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 253101)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1695,1700 ****
--- 1695,1708 ----
if (sym->ts.type == BT_CHARACTER)
{
if (sym->attr.associate_var
+ && sym->ts.deferred
+ && sym->assoc && sym->assoc->target
+ && ((sym->assoc->target->expr_type == EXPR_VARIABLE
+ && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
+ || sym->assoc->target->expr_type == EXPR_FUNCTION))
+ sym->ts.u.cl->backend_decl = NULL_TREE;
+
+ if (sym->attr.associate_var
&& sym->ts.u.cl->backend_decl
&& VAR_P (sym->ts.u.cl->backend_decl))
length = gfc_index_zero_node;
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 253101)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1533,1538 ****
--- 1533,1539 ----
bool need_len_assign;
bool whole_array = true;
gfc_ref *ref;
+ symbol_attribute attr;
gcc_assert (sym->assoc);
e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1592,1597 ****
--- 1593,1609 ----
gfc_conv_expr_descriptor (&se, e);
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && !sym->attr.select_type_temporary
+ && VAR_P (sym->ts.u.cl->backend_decl)
+ && se.string_length != sym->ts.u.cl->backend_decl)
+ {
+ gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+ fold_convert (gfc_charlen_type_node,
+ se.string_length));
+ }
+
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if ((!sym->assoc->variable && !cst_array_ctor)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1758,1765 ****
need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
}
! tmp = TREE_TYPE (sym->backend_decl);
! tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
--- 1770,1804 ----
need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
}
! if (sym->ts.type == BT_CHARACTER
! && sym->ts.deferred
! && !sym->attr.select_type_temporary
! && VAR_P (sym->ts.u.cl->backend_decl)
! && se.string_length != sym->ts.u.cl->backend_decl)
! {
! gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
! fold_convert (gfc_charlen_type_node,
! se.string_length));
! if (e->expr_type == EXPR_FUNCTION)
! {
! tmp = gfc_call_free (sym->backend_decl);
! gfc_add_expr_to_block (&se.post, tmp);
! }
! }
!
! attr = gfc_expr_attr (e);
! if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
! && (attr.allocatable || attr.pointer || attr.dummy))
! {
! /* These are pointer types already. */
! tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
! }
! else
! {
! tmp = TREE_TYPE (sym->backend_decl);
! tmp = gfc_build_addr_expr (tmp, se.expr);
! }
!
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1784,1790 ****
gfc_init_se (&se, NULL);
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
{
! /* What about deferred strings? */
gcc_assert (!e->symtree->n.sym->ts.deferred);
tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
}
--- 1823,1829 ----
gfc_init_se (&se, NULL);
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
{
! /* Deferred strings are dealt with in the preceeding. */
gcc_assert (!e->symtree->n.sym->ts.deferred);
tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
}
Index: gcc/testsuite/gfortran.dg/associate_32.f03
===================================================================
*** gcc/testsuite/gfortran.dg/associate_32.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/associate_32.f03 (working copy)
***************
*** 0 ****
--- 1,93 ----
+ ! { dg-do run }
+ !
+ ! Tests fix for PR77296 and other bugs found on the way.
+ !
+ ! Contributed by Matt Thompson <matthew.thomp...@nasa.gov>
+ !
+ program test
+
+ implicit none
+ type :: str_type
+ character(len=:), allocatable :: str
+ end type
+
+ character(len=:), allocatable :: s, sd(:)
+ character(len=2), allocatable :: sf, sfd(:)
+ character(len=6) :: str
+ type(str_type) :: string
+
+ s = 'ab'
+ associate(ss => s)
+ if (ss .ne. 'ab') call abort ! This is the original bug.
+ ss = 'c'
+ end associate
+ if (s .ne. 'c ') call abort ! No reallocation within ASSOCIATE block!
+
+ sf = 'c'
+ associate(ss => sf)
+ if (ss .ne. 'c ') call abort ! This the bug in comment #2 of the PR.
+ ss = 'cd'
+ end associate
+
+ sd = [s, sf]
+ associate(ss => sd)
+ if (any (ss .ne. ['c ','cd'])) call abort
+ end associate
+
+ sfd = [sd,'ef']
+ associate(ss => sfd)
+ if (any (ss .ne. ['c ','cd','ef'])) call abort
+ ss = ['gh']
+ end associate
+ if (any (sfd .ne. ['gh','cd','ef'])) call abort ! No reallocation!
+
+ string%str = 'xyz'
+ associate(ss => string%str)
+ if (ss .ne. 'xyz') call abort
+ ss = 'c'
+ end associate
+ if (string%str .ne. 'c ') call abort ! No reallocation!
+
+ str = "foobar"
+ call test_char (5 , str)
+ IF (str /= "abcder") call abort
+
+ associate(ss => foo())
+ if (ss .ne. 'pqrst') call abort
+ end associate
+
+ associate(ss => bar())
+ if (ss(2) .ne. 'uvwxy') call abort
+ end associate
+
+ ! The deallocation is not strictly necessary but it does allow
+ ! other memory leakage to be tested for.
+ deallocate (s, sd, sf, sfd, string%str)
+ contains
+
+ ! This is a modified version of the subroutine in associate_1.f03.
+ ! 'str' is now a dummy.
+ SUBROUTINE test_char (n, str)
+ INTEGER, INTENT(IN) :: n
+
+ CHARACTER(LEN=n) :: str
+
+ ASSOCIATE (my => str)
+ IF (LEN (my) /= n) call abort
+ IF (my /= "fooba") call abort
+ my = "abcde"
+ END ASSOCIATE
+ IF (str /= "abcde") call abort
+ END SUBROUTINE test_char
+
+ function foo() result(res)
+ character (len=:), pointer :: res
+ allocate (res, source = 'pqrst')
+ end function
+
+ function bar() result(res)
+ character (len=:), allocatable :: res(:)
+ allocate (res, source = ['pqrst','uvwxy'])
+ end function
+
+ end program test
