From a6b22eea5b059f9eab1a6b13e2bea86bc3077906 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 19 Nov 2017 19:50:50 +0000 Subject: [PATCH] re PR fortran/78990 (ICE when assigning polymorphic array function result) 2017-11-19 Paul Thomas PR fortran/78990 * expr.c (gfc_is_class_array_function): Renamed from 'gfc_is_alloc_class_array_function' and modified to return true for pointers as well as allocatable results. * gfortran.h : Change of name for prototype of above function. * trans-array.c (gfc_add_loop_ss_code): Force finalization of class array results. (build_class_array_ref): Change assertion into a condition. (build_class_array_ref): Set the se class_vptr for class array function results. (gfc_walk_function_expr): Reference gfc_is_class_array_function as above. * trans-decl.c (get_proc_result): Move it up before gfc_trans_deferred_vars. (gfc_trans_deferred_vars): Nullify explicit return class arrays on entry. * trans-expr.c (gfc_conv_class_to_class): Allow conversion of class array functions that have an se class_vptr and use it for the result vptr. (gfc_conv_subref_array_arg): Rename reference to the above function. (gfc_conv_procedure_call): Ditto. Add the se pre block to the loop pre block before the function is evaluated. Do not finalize class pointer results. (arrayfunc_assign_needs_temporary, gfc_trans_assignment_1) More renamed references. * trans-intrinsic.c (gfc_conv_intrinsic_size): Ditto. 2017-11-19 Paul Thomas PR fortran/78990 * gfortran.dg/class_67.f90: New test. From-SVN: r254936 --- gcc/fortran/ChangeLog | 30 ++++++++++++++ gcc/fortran/expr.c | 5 ++- gcc/fortran/gfortran.h | 2 +- gcc/fortran/resolve.c | 3 ++ gcc/fortran/trans-array.c | 14 ++++--- gcc/fortran/trans-decl.c | 50 +++++++++++++++-------- gcc/fortran/trans-expr.c | 38 ++++++++++++------ gcc/fortran/trans-intrinsic.c | 2 +- gcc/testsuite/ChangeLog | 7 +++- gcc/testsuite/gfortran.dg/class_67.f90 | 55 ++++++++++++++++++++++++++ 10 files changed, 168 insertions(+), 38 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_67.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2e8bbd82ce1..5dea20437e2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,33 @@ +2017-11-19 Paul Thomas + + PR fortran/78990 + * expr.c (gfc_is_class_array_function): Renamed from + 'gfc_is_alloc_class_array_function' and modified to return true + for pointers as well as allocatable results. + * gfortran.h : Change of name for prototype of above function. + * trans-array.c (gfc_add_loop_ss_code): Force finalization of + class array results. + (build_class_array_ref): Change assertion into a condition. + (build_class_array_ref): Set the se class_vptr for class array + function results. + (gfc_walk_function_expr): Reference gfc_is_class_array_function + as above. + * trans-decl.c (get_proc_result): Move it up before + gfc_trans_deferred_vars. + (gfc_trans_deferred_vars): Nullify explicit return class arrays + on entry. + * trans-expr.c (gfc_conv_class_to_class): Allow conversion of + class array functions that have an se class_vptr and use it + for the result vptr. + (gfc_conv_subref_array_arg): Rename reference to the above + function. + (gfc_conv_procedure_call): Ditto. Add the se pre block to the + loop pre block before the function is evaluated. Do not + finalize class pointer results. + (arrayfunc_assign_needs_temporary, gfc_trans_assignment_1) More + renamed references. + * trans-intrinsic.c (gfc_conv_intrinsic_size): Ditto. + 2017-11-18 Janne Blomqvist PR fortran/83036 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index e1c0caccdc1..428fce1ad04 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4844,14 +4844,15 @@ gfc_is_alloc_class_scalar_function (gfc_expr *expr) /* Determine if an expression is a function with an allocatable class array result. */ bool -gfc_is_alloc_class_array_function (gfc_expr *expr) +gfc_is_class_array_function (gfc_expr *expr) { if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym && expr->value.function.esym->result && expr->value.function.esym->result->ts.type == BT_CLASS && CLASS_DATA (expr->value.function.esym->result)->attr.dimension - && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) + && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable + || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) return true; return false; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a57676a2be1..97db5b054e4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3195,7 +3195,7 @@ gfc_param_spec_type gfc_spec_list_type (gfc_actual_arglist *, gfc_symbol *); gfc_component * gfc_get_proc_ptr_comp (gfc_expr *); bool gfc_is_proc_ptr_comp (gfc_expr *); bool gfc_is_alloc_class_scalar_function (gfc_expr *); -bool gfc_is_alloc_class_array_function (gfc_expr *); +bool gfc_is_class_array_function (gfc_expr *); bool gfc_ref_this_image (gfc_ref *ref); bool gfc_is_coindexed (gfc_expr *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bdb4015b34d..9a814017c36 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8740,6 +8740,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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; + /* F2008: C803 The selector expression must not be coindexed. */ if (gfc_is_coindexed (code->expr2)) { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 93ce68e2a52..789e81ac929 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2791,6 +2791,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gfc_init_se (&se, NULL); se.loop = loop; se.ss = ss; + if (gfc_is_class_array_function (expr)) + expr->must_finalize = 1; gfc_conv_expr (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); gfc_add_block_to_block (&outer_loop->post, &se.post); @@ -3241,7 +3243,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index) { if (expr == NULL || (expr->ts.type != BT_CLASS - && !gfc_is_alloc_class_array_function (expr) + && !gfc_is_class_array_function (expr) && !gfc_is_class_array_ref (expr, NULL))) return false; @@ -3271,12 +3273,12 @@ build_class_array_ref (gfc_se *se, tree base, tree index) } if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function - && expr->symtree->n.sym == expr->symtree->n.sym->result) + && expr->symtree->n.sym == expr->symtree->n.sym->result + && expr->symtree->n.sym->backend_decl == current_function_decl) { - gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl); decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); } - else if (expr && gfc_is_alloc_class_array_function (expr)) + else if (expr && gfc_is_class_array_function (expr)) { size = NULL_TREE; decl = NULL_TREE; @@ -3299,6 +3301,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index) if (decl == NULL_TREE) return false; + + se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); } else if (class_ref == NULL) { @@ -10527,7 +10531,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) if (!sym) sym = expr->symtree->n.sym; - if (gfc_is_alloc_class_array_function (expr)) + if (gfc_is_class_array_function (expr)) return gfc_get_array_ss (ss, expr, CLASS_DATA (expr->value.function.esym->result)->as->rank, GFC_SS_FUNCTION); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 60e7d8f79ee..5c248d06e57 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4161,6 +4161,24 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init, return tmp; } + +/* Get the result expression for a procedure. */ + +static tree +get_proc_result (gfc_symbol* sym) +{ + if (sym->attr.subroutine || sym == sym->result) + { + if (current_fake_result_decl != NULL) + return TREE_VALUE (current_fake_result_decl); + + return NULL_TREE; + } + + return sym->result->backend_decl; +} + + /* Generate function entry and exit code, and add it to the function body. This includes: Allocation and initialization of array variables. @@ -4271,6 +4289,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) else gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX); } + else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym)) + { + /* Nullify explicit return class arrays on entry. */ + tree type; + tmp = get_proc_result (proc_sym); + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + { + gfc_start_block (&init); + tmp = gfc_class_data_get (tmp); + type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); + gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + } + } + /* Initialize the INTENT(OUT) derived type dummy arguments. This should be done here so that the offsets and lbounds of arrays @@ -6067,23 +6100,6 @@ create_main_function (tree fndecl) } -/* Get the result expression for a procedure. */ - -static tree -get_proc_result (gfc_symbol* sym) -{ - if (sym->attr.subroutine || sym == sym->result) - { - if (current_fake_result_decl != NULL) - return TREE_VALUE (current_fake_result_decl); - - return NULL_TREE; - } - - return sym->result->backend_decl; -} - - /* Generate an appropriate return-statement for a procedure. */ tree diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c5e1d72bd04..92d37ec0901 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -960,6 +960,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, } if ((ref == NULL || class_ref == ref) + && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE) && (!class_ts.u.derived->components->as || class_ts.u.derived->components->as->rank != -1)) return; @@ -1030,8 +1031,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, First we have to find the corresponding class reference. */ tmp = NULL_TREE; - if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + if (gfc_is_class_array_function (e) + && parmse->class_vptr != NULL_TREE) + tmp = parmse->class_vptr; + else if (class_ref == NULL + && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) { tmp = e->symtree->n.sym->backend_decl; @@ -1063,7 +1067,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE) tmp = build_fold_indirect_ref_loc (input_location, tmp); - vptr = gfc_class_vptr_get (tmp); + if (!(gfc_is_class_array_function (e) && parmse->class_vptr)) + vptr = gfc_class_vptr_get (tmp); + else + vptr = tmp; + gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), vptr)); @@ -4435,7 +4443,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, /* Reset the offset for the function call since the loop is zero based on the data pointer. Note that the temp comes first in the loop chain since it is added second. */ - if (gfc_is_alloc_class_array_function (expr)) + if (gfc_is_class_array_function (expr)) { tmp = loop.ss->loop_chain->info->data.array.descriptor; gfc_conv_descriptor_offset_set (&loop.pre, tmp, @@ -4484,7 +4492,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, dimen = rse.ss->dimen; /* Skip the write-out loop for this case. */ - if (gfc_is_alloc_class_array_function (expr)) + if (gfc_is_class_array_function (expr)) goto class_array_fcn; /* Calculate the bounds of the scalarization. */ @@ -4778,7 +4786,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gcc_assert ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension) - || gfc_is_alloc_class_array_function (expr)); + || gfc_is_class_array_function (expr)); gcc_assert (se->loop != NULL); /* Access the previously obtained result. */ gfc_conv_tmp_array_ref (se); @@ -5462,7 +5470,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); - else if (gfc_is_alloc_class_array_function (e) + else if (gfc_is_class_array_function (e) && fsym && fsym->ts.type == BT_DERIVED) /* See previous comment. For function actual argument, the write out is not needed so the intent is set as @@ -6304,7 +6312,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, call the finalization function of the temporary. Note that the nullification of allocatable components needed by the result is done in gfc_trans_assignment_1. */ - if (expr && ((gfc_is_alloc_class_array_function (expr) + if (expr && ((gfc_is_class_array_function (expr) && se->ss && se->ss->loop) || gfc_is_alloc_class_scalar_function (expr)) && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) @@ -6315,6 +6323,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, int n; if (se->ss && se->ss->loop) { + gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); tmp = gfc_class_data_get (se->expr); info->descriptor = tmp; @@ -6337,6 +6346,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (expr->value.function.esym->result)->attr); } + if ((gfc_is_class_array_function (expr) + || gfc_is_alloc_class_scalar_function (expr)) + && CLASS_DATA (expr->value.function.esym->result)->attr.pointer) + goto no_finalization; + final_fndecl = gfc_class_vtab_final_get (se->expr); is_final = fold_build2_loc (input_location, NE_EXPR, logical_type_node, @@ -6367,6 +6381,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_call_free (tmp); gfc_add_expr_to_block (&se->post, tmp); } + +no_finalization: expr->must_finalize = 0; } @@ -8887,7 +8903,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) gfc_symbol *sym = expr1->symtree->n.sym; /* Play it safe with class functions assigned to a derived type. */ - if (gfc_is_alloc_class_array_function (expr2) + if (gfc_is_class_array_function (expr2) && expr1->ts.type == BT_DERIVED) return true; @@ -9894,7 +9910,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, rss = NULL; if ((expr1->ts.type == BT_DERIVED) - && (gfc_is_alloc_class_array_function (expr2) + && (gfc_is_class_array_function (expr2) || gfc_is_alloc_class_scalar_function (expr2))) expr2->must_finalize = 1; @@ -10101,7 +10117,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, a scalar to array assignment, this is done in gfc_trans_scalar_assign as part of the deep copy. */ if (!scalar_to_array && expr1->ts.type == BT_DERIVED - && (gfc_is_alloc_class_array_function (expr2) + && (gfc_is_class_array_function (expr2) || gfc_is_alloc_class_scalar_function (expr2))) { tmp = rse.expr; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index ed4496c845d..b7c57210b8c 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -6603,7 +6603,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) gfc_add_class_array_ref (actual->expr); argse.data_not_needed = 1; - if (gfc_is_alloc_class_array_function (actual->expr)) + if (gfc_is_class_array_function (actual->expr)) { /* For functions that return a class array conv_expr_descriptor is not able to get the descriptor right. Therefore this special case. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fe7a5284689..ebdf42bea5f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-11-19 Paul Thomas + + PR fortran/78990 + * gfortran.dg/class_67.f90: New test. + 2017-11-19 Jan Hubicka PR target/82713 @@ -270,7 +275,7 @@ * g++.dg/torture/pr82985.C: Likewise. 2017-11-15 Sebastian Peryt - + PR target/82941 PR target/82942 * gcc.target/i386/pr82941-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/class_67.f90 b/gcc/testsuite/gfortran.dg/class_67.f90 new file mode 100644 index 00000000000..20029939d64 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_67.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Test the fix for PR78990 in which the scalarization of the assignment +! in the main program failed for two reasons: (i) The conversion of 'v1' +! into a class actual was being done after the call to 'return_t1', giving +! rise to the ICE reported in comment #1; and (ii) The 'info' descriptor, +! required for scalarization was not set, which gave rise to the ICE noted +! by the contributor. +! +! Contributed by Chris Macmackin +! +module test_type + implicit none + + type t1 + integer :: i + contains + procedure :: assign + generic :: assignment(=) => assign + end type t1 + +contains + + elemental subroutine assign(this,rhs) + class(t1), intent(inout) :: this + class(t1), intent(in) :: rhs + this%i = rhs%i + end subroutine assign + + function return_t1(arg) + class(t1), dimension(:), intent(in) :: arg + class(t1), dimension(:), allocatable :: return_t1 + allocate(return_t1(size(arg)), source=arg) + end function return_t1 + + function return_t1_p(arg) + class(t1), dimension(:), intent(in), target :: arg + class(t1), dimension(:), pointer :: return_t1_p + return_t1_p => arg + end function return_t1_p +end module test_type + +program test + use test_type + implicit none + + type(t1), dimension(3) :: v1, v2 + v1%i = [1,2,3] + v2 = return_t1(v1) + if (any (v2%i .ne. v1%i)) call abort + + v1%i = [4,5,6] + v2 = return_t1_p(v1) + if (any (v2%i .ne. v1%i)) call abort +end program test -- 2.30.2