From de514d407ef8af0b0ba377d8934348702cf87d05 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 21 Oct 2016 12:50:56 +0000 Subject: [PATCH] re PR fortran/69566 ([OOP] Failure of SELECT TYPE with unlimited polymorphic function result) 2016-10-21 Paul Thomas PR fortran/69566 * resolve.c (fixup_array_ref): New function. (resolve_select_type): Gather up the rank and array reference, if any, from the selector. Fix up the 'associate name' and the 'associate entities' as necessary. * trans-expr.c (gfc_conv_class_to_class): If the symbol backend decl is a FUNCTION_DECL, use the 'fake_result_decl' instead. 2016-10-21 Paul Thomas PR fortran/69566 * gfortran.dg/select_type_37.f03: New test. From-SVN: r241403 --- gcc/fortran/ChangeLog | 10 +++ gcc/fortran/resolve.c | 79 ++++++++++++++++++- gcc/fortran/trans-expr.c | 5 ++ gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/select_type_37.f03 | 83 ++++++++++++++++++++ 5 files changed, 181 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_37.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b13be23b8f1..b9b742e22bc 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2016-10-21 Paul Thomas + + PR fortran/69566 + * resolve.c (fixup_array_ref): New function. + (resolve_select_type): Gather up the rank and array reference, + if any, from the selector. Fix up the 'associate name' and the + 'associate entities' as necessary. + * trans-expr.c (gfc_conv_class_to_class): If the symbol backend + decl is a FUNCTION_DECL, use the 'fake_result_decl' instead. + 2016-10-20 Steven G. Kargl * array.c (gfc_match_array_constructor): Remove set, but unused diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 87178a41333..c4426f81320 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8327,6 +8327,48 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) } +/* Ensure that SELECT TYPE expressions have the correct rank and a full + array reference, where necessary. The symbols are artificial and so + the dimension attribute and arrayspec can also be set. In addition, + sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS. + This is corrected here as well.*/ + +static void +fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, + int rank, gfc_ref *ref) +{ + gfc_ref *nref = (*expr1)->ref; + gfc_symbol *sym1 = (*expr1)->symtree->n.sym; + gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; + (*expr1)->rank = rank; + if (sym1->ts.type == BT_CLASS) + { + if ((*expr1)->ts.type != BT_CLASS) + (*expr1)->ts = sym1->ts; + + CLASS_DATA (sym1)->attr.dimension = 1; + if (CLASS_DATA (sym1)->as == NULL && sym2) + CLASS_DATA (sym1)->as + = gfc_copy_array_spec (CLASS_DATA (sym2)->as); + } + else + { + sym1->attr.dimension = 1; + if (sym1->as == NULL && sym2) + sym1->as = gfc_copy_array_spec (sym2->as); + } + + for (; nref; nref = nref->next) + if (nref->next == NULL) + break; + + if (ref && nref && nref->type != REF_ARRAY) + nref->next = gfc_copy_ref (ref); + else if (ref && !nref) + (*expr1)->ref = gfc_copy_ref (ref); +} + + /* Resolve a SELECT TYPE statement. */ static void @@ -8341,6 +8383,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) gfc_namespace *ns; int error = 0; int charlen = 0; + int rank = 0; + gfc_ref* ref = NULL; ns = code->ext.block.ns; gfc_resolve (ns); @@ -8468,6 +8512,31 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) else code->ext.block.assoc = NULL; + /* Ensure that the selector rank and arrayspec are available to + correct expressions in which they might be missing. */ + if (code->expr2 && code->expr2->rank) + { + rank = code->expr2->rank; + for (ref = code->expr2->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + if (ref && ref->type == REF_ARRAY) + ref = gfc_copy_ref (ref); + + /* Fixup expr1 if necessary. */ + if (rank) + fixup_array_ref (&code->expr1, code->expr2, rank, ref); + } + else if (code->expr1->rank) + { + rank = code->expr1->rank; + for (ref = code->expr1->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + if (ref && ref->type == REF_ARRAY) + ref = gfc_copy_ref (ref); + } + /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; @@ -8533,7 +8602,12 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); st->n.sym->assoc->target->where = code->expr1->where; if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) - gfc_add_data_component (st->n.sym->assoc->target); + { + gfc_add_data_component (st->n.sym->assoc->target); + /* Fixup the target expression if necessary. */ + if (rank) + fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref); + } new_st = gfc_get_code (EXEC_BLOCK); new_st->ext.block.ns = gfc_build_block_ns (ns); @@ -8672,6 +8746,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = old_ns; + if (ref) + free (ref); + resolve_select (code, true); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6b974db5e7f..2f8ea22e643 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1033,8 +1033,13 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { tmp = e->symtree->n.sym->backend_decl; + + if (TREE_CODE (tmp) == FUNCTION_DECL) + tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + slen = integer_zero_node; } else diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 771daa35ba3..83414ed3833 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-10-21 Paul Thomas + + PR fortran/69566 + * gfortran.dg/select_type_37.f03: New test. + 2016-10-21 Senthil Kumar Selvaraj PR target/71627 diff --git a/gcc/testsuite/gfortran.dg/select_type_37.f03 b/gcc/testsuite/gfortran.dg/select_type_37.f03 new file mode 100644 index 00000000000..c9fd23cea3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_37.f03 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! Checks the fix for PR69556 in which using implicit function results +! in SELECT TYPE caused all sorts of problems, especially in the form +! in 'return_pointer1' with "associate_name => selector". The original +! PR is encapsulated in 'return_pointer'. Explicit results, such as in +! 'return_pointer2' always worked. +! +! Contributed by James Greenhalgh +! +program pr69556 + class(*), pointer :: ptr(:) + character(40) :: buffer1, buffer2 + real :: cst1(2) = [1.0, 2.0] + real :: cst2(2) = [3.0, 4.0] + real :: cst3(2) = [5.0, 6.0] + + write (buffer1, *) cst1 + if (.not.associated(return_pointer1(cst1))) call abort + if (trim (buffer1) .ne. trim (buffer2)) call abort + select type (ptr) + type is (real) + if (any (ptr .ne. cst2)) call abort + end select + deallocate (ptr) + + write (buffer1, *) cst2 + if (.not.associated(return_pointer(cst2))) call abort + if (trim (buffer1) .ne. trim (buffer2)) call abort + select type (ptr) + type is (real) + if (any (ptr .ne. cst3)) call abort + end select + deallocate (ptr) + + write (buffer1, *) cst1 + if (.not.associated(return_pointer2(cst1))) call abort + if (trim (buffer1) .ne. trim (buffer2)) call abort + select type (ptr) + type is (real) + if (any (ptr .ne. cst2)) call abort + end select + deallocate (ptr) + +contains + + function return_pointer2(arg) result (res) ! Explicit result always worked. + class(*), pointer :: res(:) + real, intent(inout) :: arg(:) + allocate (res, source = arg) + ptr => res ! Check association and cleanup + select type (z => res) + type is (real(4)) + write (buffer2, *) z ! Check associate expression is OK. + z = cst2 ! Check associate is OK for lvalue. + end select + end function + + function return_pointer1(arg) + class(*), pointer :: return_pointer1(:) + real, intent(inout) :: arg(:) + allocate (return_pointer1, source = arg) + ptr => return_pointer1 + select type (z => return_pointer1) ! This caused a segfault in compilation. + type is (real(4)) + write (buffer2, *) z + z = cst2 + end select + end function + + function return_pointer(arg) ! The form in the PR. + class(*), pointer :: return_pointer(:) + real, intent(inout) :: arg(:) + allocate (return_pointer, source = cst2) + ptr => return_pointer + select type (return_pointer) + type is (real(4)) ! Associate-name ‘__tmp_REAL_4’ at (1) is used as array + write (buffer2, *) return_pointer + return_pointer = cst3 + end select + end function +end program + -- 2.30.2