From de514d407ef8af0b0ba377d8934348702cf87d05 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 21 Oct 2016 12:50:56 +0000 Subject: 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 +++ 3 files changed, 93 insertions(+), 1 deletion(-) (limited to 'gcc/fortran') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b13be23..b9b742e 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 87178a4..c4426f8 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 6b974db..2f8ea22 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 -- cgit v1.1