diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index db918291b10..e6e915d2a5e 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -4924,6 +4924,24 @@ parse_associate (void) in case of association to a derived-type. */ sym->ts = a->target->ts; + /* Don’t share the character length information between associate + variable and target if the length is not a compile-time constant, + as we don’t want to touch some other character length variable when + we try to initialize the associate variable’s character length + variable. + We do it here rather than later so that expressions referencing the + associate variable will automatically have the correctly setup length + information. If we did it at resolution stage the expressions would + use the original length information, and the variable a new different + one, but only the latter one would be correctly initialized at + translation stage, and the former one would need some additional setup + there. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && !(sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) + sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + /* Check if the target expression is array valued. This cannot always be done by looking at target.rank, because that might not have been set yet. Therefore traverse the chain of refs, looking for the last diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 0b55961f083..5522be75199 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -9232,7 +9232,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!sym->ts.u.cl) sym->ts.u.cl = target->ts.u.cl; - if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE + if (sym->ts.deferred && sym->ts.u.cl == target->ts.u.cl) { sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); @@ -9251,8 +9251,11 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) && target->expr_type != EXPR_VARIABLE) { - sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); - sym->ts.deferred = 1; + if (!sym->ts.deferred) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + sym->ts.deferred = 1; + } /* This is reset in trans-stmt.cc after the assignment of the target expression to the associate name. */ diff --git a/gcc/testsuite/gfortran.dg/associate_58.f90 b/gcc/testsuite/gfortran.dg/associate_58.f90 new file mode 100644 index 00000000000..9c24f35c0d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_58.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/104570 +! The following used to cause an ICE because the string length +! evaluation of the (y) expression was not prepared to handle +! a non-scalar expression. + +program p + character(:), allocatable :: x(:) + x = ['abc'] + call s +contains + subroutine s + associate (y => x) + associate (z => (y)) + print *, z + end associate + end associate + end +end +