Tobias started this patch and I finished it in answering a question
that he had about a problem with the gimplifier. Along the way, I
tried the associate version of the select type test case and found
that it failed in a different way. The chunk in resolve_assoc_var
fixes that.
Bootstrapped and regtested on FC28/x86_64 - OK for trunk?
On checking to see if any other associate problems had been fixed, I
noticed, as had Dominique, that PR83146 was fixed. I committed the
testcase to trunk as revision 265148 to make sure that it remained so.
Paul
2018-10-14 Paul Thomas
Tobias Burnus
PR fortran/87566
* resolve.c (resolve_assoc_var): Add missing array spec for
class associate names.
(resolve_select_type): Handle case where last typed component
of the selector has a different type to the expression.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
call to gfc_expr_to_initialize with call to gfc_copy_expr.
(gfc_conv_class_to_class): Guard assignment to 'len' field
against case where zero constant is supplied.
2018-10-14 Paul Thomas
Tobias Burnus
PR fortran/87566
* gfortran.dg/select_type_44.f90: New test.
* gfortran.dg/associate_42.f90: New test.
Index: gcc/fortran/resolve.c
===
*** gcc/fortran/resolve.c (revision 264948)
--- gcc/fortran/resolve.c (working copy)
*** resolve_assoc_var (gfc_symbol* sym, bool
*** 8675,8680
--- 8675,8692
if (as->corank != 0)
sym->attr.codimension = 1;
}
+ else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+ {
+ if (!CLASS_DATA (sym)->as)
+ CLASS_DATA (sym)->as = gfc_get_array_spec ();
+ as = CLASS_DATA (sym)->as;
+ as->rank = target->rank;
+ as->type = AS_DEFERRED;
+ as->corank = gfc_get_corank (target);
+ CLASS_DATA (sym)->attr.dimension = 1;
+ if (as->corank != 0)
+ CLASS_DATA (sym)->attr.codimension = 1;
+ }
}
else
{
*** resolve_select_type (gfc_code *code, gfc
*** 8875,8883
if (code->expr2)
{
! if (code->expr1->symtree->n.sym->attr.untyped)
! code->expr1->symtree->n.sym->ts = code->expr2->ts;
! selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
--- 8887,8910
if (code->expr2)
{
! gfc_ref *ref2 = NULL;
! for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
! if (ref->type == REF_COMPONENT
! && ref->u.c.component->ts.type == BT_CLASS)
! ref2 = ref;
!
! if (ref2)
! {
! if (code->expr1->symtree->n.sym->attr.untyped)
! code->expr1->symtree->n.sym->ts = ref->u.c.component->ts;
! selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
! }
! else
! {
! if (code->expr1->symtree->n.sym->attr.untyped)
! code->expr1->symtree->n.sym->ts = code->expr2->ts;
! selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
! }
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
Index: gcc/fortran/trans-expr.c
===
*** gcc/fortran/trans-expr.c (revision 264948)
--- gcc/fortran/trans-expr.c (working copy)
*** gfc_find_and_cut_at_last_class_ref (gfc_
*** 394,400
e->ref = NULL;
}
! base_expr = gfc_expr_to_initialize (e);
/* Restore the original tail expression. */
if (class_ref)
--- 394,400
e->ref = NULL;
}
! base_expr = gfc_copy_expr (e);
/* Restore the original tail expression. */
if (class_ref)
*** gfc_conv_class_to_class (gfc_se *parmse,
*** 1131,1137
/* Return the len component, except in the case of scalarized array
references, where the dynamic type cannot change. */
! if (!elemental && full_array && copyback)
gfc_add_modify (>post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}
--- 1131,1138
/* Return the len component, except in the case of scalarized array
references, where the dynamic type cannot change. */
! if (!elemental && full_array && copyback
! && (UNLIMITED_POLY (e) || VAR_P (tmp)))
gfc_add_modify (>post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}
Index: gcc/testsuite/gfortran.dg/associate_42.f90
===
*** gcc/testsuite/gfortran.dg/associate_42.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/associate_42.f90 (working copy)
***
*** 0
--- 1,41
+ ! { dg-do run }
+ !
+ ! Tests the fix for a bug that was found in the course of fixing PR87566.
+ !
+ ! Contributed by Paul Thomas
+ !
+ call AddArray
+ contains
+ subroutine AddArray()
+
