From: Paul Thomas Date: Mon, 15 Oct 2018 16:31:15 +0000 (+0000) Subject: re PR fortran/87566 (ICE with class(*) and select) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e60f68ec460bc5b33a6f75caac9667bf978f37d8;p=gcc.git re PR fortran/87566 (ICE with class(*) and select) 2018-10-15 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-15 Paul Thomas Tobias Burnus PR fortran/87566 * gfortran.dg/select_type_44.f90: New test. * gfortran.dg/associate_42.f90: New test. Co-Authored-By: Tobias Burnus From-SVN: r265171 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4ee065a19a0..4c5f17ad66a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2018-10-15 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-12 Tobias Burnus PR fortran/87597 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 87e65df5f4e..56ab595b352 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8675,6 +8675,18 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) 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 { @@ -8875,9 +8887,24 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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; + 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; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 37052b612d4..7a5091b7f85 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -394,7 +394,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) e->ref = NULL; } - base_expr = gfc_expr_to_initialize (e); + base_expr = gfc_copy_expr (e); /* Restore the original tail expression. */ if (class_ref) @@ -1131,7 +1131,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, /* Return the len component, except in the case of scalarized array references, where the dynamic type cannot change. */ - if (!elemental && full_array && copyback) + if (!elemental && full_array && copyback + && (UNLIMITED_POLY (e) || VAR_P (tmp))) gfc_add_modify (&parmse->post, tmp, fold_convert (TREE_TYPE (tmp), ctree)); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index df20c3c93dd..f08abb18189 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-10-15 Paul Thomas + Tobias Burnus + + PR fortran/87566 + * gfortran.dg/select_type_44.f90: New test. + * gfortran.dg/associate_42.f90: New test. + 2018-10-15 Bin Cheng PR tree-optimization/87022 diff --git a/gcc/testsuite/gfortran.dg/associate_42.f90 b/gcc/testsuite/gfortran.dg/associate_42.f90 new file mode 100644 index 00000000000..359224de50c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_42.f90 @@ -0,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() + 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 diff --git a/gcc/testsuite/gfortran.dg/select_type_44.f90 b/gcc/testsuite/gfortran.dg/select_type_44.f90 new file mode 100644 index 00000000000..8a5b5709b5a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_44.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR87566 +! +! Contributed by Antony Lewis +! + 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