> Oddly, the failing test in associate_35.f90 is the only one that works
> in 7-branch. I have left the PR open and changed the title
> accordingly.
The attached patch fixes this. OK for trunk?
Paul
2018-02-16 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/84115
* resolve.c (resolve_assoc_var): If a non-constant target expr.
has no string length expression, make the associate variable
into a deferred length, allocatable symbol.
* trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to
the symbol.
* trans-stmt.c (trans_associate_var): Null and free scalar
associate names that are allocatable. After assignment, remove
the allocatable attribute to prevent reallocation.
2018-02-16 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/84115
* gfortran.dg/associate_35.f90: Remove error, add stop n's and
change to run.
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 257682)
--- gcc/fortran/primary.c (working copy)
*************** gfc_match_varspec (gfc_expr *primary, in
*** 2082,2088 ****
{
bool permissible;
! /* These target expressions can ge resolved at any time. */
permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
&& (tgt_expr->symtree->n.sym->attr.use_assoc
|| tgt_expr->symtree->n.sym->attr.host_assoc
--- 2082,2088 ----
{
bool permissible;
! /* These target expressions can be resolved at any time. */
permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
&& (tgt_expr->symtree->n.sym->attr.use_assoc
|| tgt_expr->symtree->n.sym->attr.host_assoc
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 257682)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8635,8641 ****
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
if (!sym->ts.u.cl)
! sym->ts.u.cl = target->ts.u.cl;
if (!sym->ts.u.cl->length && !sym->ts.deferred)
{
--- 8635,8654 ----
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
if (!sym->ts.u.cl)
! {
! if (target->expr_type != EXPR_CONSTANT
! && !target->ts.u.cl->length)
! {
! sym->ts.u.cl = gfc_get_charlen();
! sym->ts.deferred = 1;
!
! /* This is reset in trans-stmt.c after the assignment
! of the target expression to the associate name. */
! sym->attr.allocatable = 1;
! }
! else
! sym->ts.u.cl = target->ts.u.cl;
! }
if (!sym->ts.u.cl->length && !sym->ts.deferred)
{
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 257682)
--- gcc/fortran/trans-array.c (working copy)
*************** bool
*** 9470,9498 ****
gfc_is_reallocatable_lhs (gfc_expr *expr)
{
gfc_ref * ref;
if (!expr->ref)
return false;
/* An allocatable class variable with no reference. */
! if (expr->symtree->n.sym->ts.type == BT_CLASS
! && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
&& expr->ref->next == NULL)
return true;
/* An allocatable variable. */
! if (expr->symtree->n.sym->attr.allocatable
&& expr->ref
&& expr->ref->type == REF_ARRAY
&& expr->ref->u.ar.type == AR_FULL)
return true;
/* All that can be left are allocatable components. */
! if ((expr->symtree->n.sym->ts.type != BT_DERIVED
! && expr->symtree->n.sym->ts.type != BT_CLASS)
! || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
return false;
/* Find a component ref followed by an array reference. */
--- 9470,9501 ----
gfc_is_reallocatable_lhs (gfc_expr *expr)
{
gfc_ref * ref;
+ gfc_symbol *sym;
if (!expr->ref)
return false;
+ sym = expr->symtree->n.sym;
+
/* An allocatable class variable with no reference. */
! if (sym->ts.type == BT_CLASS
! && CLASS_DATA (sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
&& expr->ref->next == NULL)
return true;
/* An allocatable variable. */
! if (sym->attr.allocatable
&& expr->ref
&& expr->ref->type == REF_ARRAY
&& expr->ref->u.ar.type == AR_FULL)
return true;
/* All that can be left are allocatable components. */
! if ((sym->ts.type != BT_DERIVED
! && sym->ts.type != BT_CLASS)
! || !sym->ts.u.derived->attr.alloc_comp)
return false;
/* Find a component ref followed by an array reference. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 257682)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 657,663 ****
}
/* Array references with vector subscripts and non-variable
expressions
! need be coverted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
{
for (dim = 0; dim < e->rank; ++dim)
--- 657,663 ----
}
/* Array references with vector subscripts and non-variable
expressions
! need be converted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
{
for (dim = 0; dim < e->rank; ++dim)
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 257682)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1926,1934 ****
--- 1926,1951 ----
{
gfc_expr *lhs;
tree res;
+ gfc_se se;
+
+ gfc_init_se (&se, NULL);
+
+ /* resolve.c converts some associate names to allocatable so that
+ allocation can take place automatically in gfc_trans_assignment.
+ The frontend prevents them from being either allocated,
+ deallocated or reallocated. */
+ if (sym->attr.allocatable)
+ {
+ tmp = sym->backend_decl;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
lhs = gfc_lval_expr_from_sym (sym);
res = gfc_trans_assignment (lhs, e, false, true);
+ gfc_add_expr_to_block (&se.pre, res);
tmp = sym->backend_decl;
if (e->expr_type == EXPR_FUNCTION
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1948,1955 ****
--- 1965,1989 ----
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
tmp, 0);
}
+ else if (sym->attr.allocatable)
+ {
+ tmp = sym->backend_decl;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+
+ /* A simple call to free suffices here. */
+ tmp = gfc_call_free (tmp);
+
+ /* Make sure that reallocation on assignment cannot occur. */
+ sym->attr.allocatable = 0;
+ }
+ else
+ tmp = NULL_TREE;
+ res = gfc_finish_block (&se.pre);
gfc_add_init_cleanup (block, res, tmp);
+ gfc_free_expr (lhs);
}
/* Set the stringlength, when needed. */
Index: gcc/testsuite/gfortran.dg/associate_35.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_35.f90 (revision 257682)
--- gcc/testsuite/gfortran.dg/associate_35.f90 (working copy)
***************
*** 1,6 ****
! ! { dg-do compile }
!
! ! Test the fix for PR84115 comment #1 (except for s1(x)!).
!
! Contributed by G Steinmetz <gs...@t-online.de>
!
--- 1,6 ----
! ! { dg-do run }
!
! ! Test the fix for PR84115 comment #1.
!
! Contributed by G Steinmetz <gs...@t-online.de>
!
***************
*** 14,35 ****
contains
subroutine s1(x)
character(:), allocatable :: x
! associate (y => x//x) ! { dg-error "type character and non-constant
length" }
! print *, y
end associate
end
subroutine s2(x)
character(:), allocatable :: x
associate (y => [x])
! print *, y
end associate
end
subroutine s3(x)
character(:), allocatable :: x
associate (y => [x,x])
! print *, y
end associate
end
end
--- 14,35 ----
contains
subroutine s1(x)
character(:), allocatable :: x
! associate (y => x//x)
! if (y .ne. x//x) stop 1
end associate
end
subroutine s2(x)
character(:), allocatable :: x
associate (y => [x])
! if (any(y .ne. [x])) stop 2
end associate
end
subroutine s3(x)
character(:), allocatable :: x
associate (y => [x,x])
! if (any(y .ne. [x,x])) stop 3
end associate
end
end
