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 <pa...@gcc.gnu.org> Tobias Burnus <bur...@gcc.gnu.org> 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 <pa...@gcc.gnu.org> Tobias Burnus <bur...@gcc.gnu.org> 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 (&parmse->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 (&parmse->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 <pa...@gcc.gnu.org> + ! + call AddArray + contains + subroutine AddArray() + type Object_array_pointer + class(*), pointer :: p(:) => null() + end type Object_array_pointer + + type (Object_array_pointer) :: obj + character(3), target :: tgt1(2) = ['one','two'] + character(5), target :: tgt2(2) = ['three','four '] + real, target :: tgt3(3) = [1.0,2.0,3.0] + + obj%p => tgt1 + associate (point => obj%p) + select type (point) ! Used to ICE here. + type is (character(*)) + if (any (point .ne. tgt1)) stop 1 + end select + point => tgt2 + end associate + + select type (z => obj%p) + type is (character(*)) + if (any (z .ne. tgt2)) stop 2 + end select + + obj%p => tgt3 + associate (point => obj%p) + select type (point) + type is (real) + if (any (point .ne. tgt3)) stop 3 + end select + end associate + end subroutine AddArray + end Index: gcc/testsuite/gfortran.dg/select_type_44.f90 =================================================================== *** gcc/testsuite/gfortran.dg/select_type_44.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/select_type_44.f90 (working copy) *************** *** 0 **** --- 1,42 ---- + ! { dg-do run } + ! + ! Test the fix for PR87566 + ! + ! Contributed by Antony Lewis <ant...@cosmologist.info> + ! + call AddArray + contains + subroutine AddArray() + type Object_array_pointer + class(*), pointer :: p(:) => null() + end type Object_array_pointer + class(*), pointer :: Pt => null() + type (Object_array_pointer) :: obj + character(3), target :: tgt1(2) = ['one','two'] + character(5), target :: tgt2(2) = ['three','four '] + + allocate (Pt, source = Object_array_pointer ()) + select type (Pt) + type is (object_array_pointer) + Pt%p => tgt1 + end select + + select type (Pt) + class is (object_array_pointer) + select type (Point=> Pt%P) + type is (character(*)) + if (any (Point .ne. tgt1)) stop 1 + Point = ['abc','efg'] + end select + end select + + select type (Pt) + class is (object_array_pointer) + select type (Point=> Pt%P) + type is (character(*)) + if (any (Point .ne. ['abc','efg'])) stop 2 + end select + end select + + end subroutine AddArray + end