From 43a68a9df5b97efae86b3e8ab47776dc9d7fa702 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 6 Feb 2015 18:15:01 +0000 Subject: [PATCH] re PR fortran/63205 ([OOP] Wrongly rejects type = class (for identical declared type)) 2015-02-06 Paul Thomas PR fortran/63205 * gfortran.h: Add 'must finalize' field to gfc_expr and prototypes for gfc_is_alloc_class_scalar_function and for gfc_is_alloc_class_array_function. * expr.c (gfc_is_alloc_class_scalar_function, gfc_is_alloc_class_array_function): New functions. * trans-array.c (gfc_add_loop_ss_code): Do not move the expression for allocatable class scalar functions outside the loop. (conv_array_index_offset): Cope with deltas being NULL_TREE. (build_class_array_ref): Do not return with allocatable class array functions. Add code to pick out the returned class array. Dereference if necessary and return if not a class object. (gfc_conv_scalarized_array_ref): Cope with offsets being NULL. (gfc_walk_function_expr): Return an array ss for the result of an allocatable class array function. * trans-expr.c (gfc_conv_subref_array_arg): Remove the assert that the argument should be a variable. If an allocatable class array function, set the offset to zero and skip the write-out loop in this case. (gfc_conv_procedure_call): Add allocatable class array function to the assert. Call gfc_conv_subref_array_arg for allocatable class array function arguments with derived type formal arg.. Add the code for handling allocatable class functions, including finalization calls to prevent memory leaks. (arrayfunc_assign_needs_temporary): Return if an allocatable class array function. (gfc_trans_assignment_1): Set must_finalize to rhs expression for allocatable class functions. Set scalar_to_array as needed for scalar class allocatable functions assigned to an array. Nullify the allocatable components corresponding the the lhs derived type so that the finalization does not free them. 2015-02-06 Paul Thomas PR fortran/63205 * gfortran.dg/class_to_type_4.f90: New test From-SVN: r220482 --- gcc/fortran/ChangeLog | 49 ++++-- gcc/fortran/expr.c | 34 ++++ gcc/fortran/gfortran.h | 5 + gcc/fortran/trans-array.c | 46 +++++- gcc/fortran/trans-expr.c | 152 +++++++++++++++++- gcc/testsuite/ChangeLog | 9 ++ gcc/testsuite/gfortran.dg/class_to_type_4.f90 | 119 ++++++++++++++ 7 files changed, 395 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 63198c89b7d..36772ab5115 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,16 +1,47 @@ +2015-02-06 Paul Thomas + + PR fortran/63205 + * gfortran.h: Add 'must finalize' field to gfc_expr and + prototypes for gfc_is_alloc_class_scalar_function and for + gfc_is_alloc_class_array_function. + * expr.c (gfc_is_alloc_class_scalar_function, + gfc_is_alloc_class_array_function): New functions. + * trans-array.c (gfc_add_loop_ss_code): Do not move the + expression for allocatable class scalar functions outside the + loop. + (conv_array_index_offset): Cope with deltas being NULL_TREE. + (build_class_array_ref): Do not return with allocatable class + array functions. Add code to pick out the returned class array. + Dereference if necessary and return if not a class object. + (gfc_conv_scalarized_array_ref): Cope with offsets being NULL. + (gfc_walk_function_expr): Return an array ss for the result of + an allocatable class array function. + * trans-expr.c (gfc_conv_subref_array_arg): Remove the assert + that the argument should be a variable. If an allocatable class + array function, set the offset to zero and skip the write-out + loop in this case. + (gfc_conv_procedure_call): Add allocatable class array function + to the assert. Call gfc_conv_subref_array_arg for allocatable + class array function arguments with derived type formal arg.. + Add the code for handling allocatable class functions, including + finalization calls to prevent memory leaks. + (arrayfunc_assign_needs_temporary): Return if an allocatable + class array function. + (gfc_trans_assignment_1): Set must_finalize to rhs expression + for allocatable class functions. Set scalar_to_array as needed + for scalar class allocatable functions assigned to an array. + Nullify the allocatable components corresponding the the lhs + derived type so that the finalization does not free them. -2015-01-29 Andre Vehreschild , Janus Weil +2015-01-29 Andre Vehreschild + Janus Weil PR fortran/60289 Initial patch by Janus Weil - * resolve.c (resolve_allocate_expr): Add check for comp. only when - target is not unlimited polymorphic. - * trans-stmt.c (gfc_trans_allocate): Assign correct value to _len - component of unlimited polymorphic entities. - -2015-01-29 Andre Vehreschild - - * gfortran.dg/unlimited_polymorphic_22.f90: New test. + * resolve.c (resolve_allocate_expr): Add check for comp. only + when target is not unlimited polymorphic. + * trans-stmt.c (gfc_trans_allocate): Assign correct value to + _len component of unlimited polymorphic entities. 2015-02-05 Tobias Burnus diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index e1fc1d07ee2..ab6f7a52205 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4304,6 +4304,40 @@ gfc_is_proc_ptr_comp (gfc_expr *expr) } +/* Determine if an expression is a function with an allocatable class scalar + result. */ +bool +gfc_is_alloc_class_scalar_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) + return true; + + return false; +} + + +/* Determine if an expression is a function with an allocatable class array + result. */ +bool +gfc_is_alloc_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) + return true; + + return false; +} + + /* Walk an expression tree and check each variable encountered for being typed. If strict is not set, a top-level variable is tolerated untyped in -std=gnu mode as is a basic arithmetic expression using those; this is for things in diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6b9f7dd02a6..ff0054e7029 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1969,6 +1969,9 @@ typedef struct gfc_expr /* Mark an expression as being a MOLD argument of ALLOCATE. */ unsigned int mold : 1; + /* Will require finalization after use. */ + unsigned int must_finalize : 1; + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from @@ -2988,6 +2991,8 @@ bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool); 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_ref_this_image (gfc_ref *ref); bool gfc_is_coindexed (gfc_expr *); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 08b020b42a8..642110dc41f 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2474,7 +2474,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gfc_conv_expr (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); - if (expr->ts.type != BT_CHARACTER) + if (expr->ts.type != BT_CHARACTER + && !gfc_is_alloc_class_scalar_function (expr)) { /* Move the evaluation of scalar expressions outside the scalarization loop, except for WHERE assignments. */ @@ -2955,7 +2956,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, stride = gfc_conv_descriptor_stride_get (info->descriptor, gfc_rank_cst[dim]); - if (!integer_zerop (info->delta[dim])) + if (info->delta[dim] && !integer_zerop (info->delta[dim])) index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->delta[dim]); } @@ -2984,7 +2985,9 @@ build_class_array_ref (gfc_se *se, tree base, tree index) gfc_ref *class_ref; gfc_typespec *ts; - if (expr == NULL || expr->ts.type != BT_CLASS) + if (expr == NULL + || (expr->ts.type != BT_CLASS + && !gfc_is_alloc_class_array_function (expr))) return false; if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) @@ -3018,6 +3021,30 @@ build_class_array_ref (gfc_se *se, tree base, tree index) gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl); decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); } + else if (gfc_is_alloc_class_array_function (expr)) + { + size = NULL_TREE; + decl = NULL_TREE; + for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0)) + { + tree type; + type = TREE_TYPE (tmp); + while (type) + { + if (GFC_CLASS_TYPE_P (type)) + decl = tmp; + if (type != TYPE_CANONICAL (type)) + type = TYPE_CANONICAL (type); + else + type = NULL_TREE; + } + if (TREE_CODE (tmp) == VAR_DECL) + break; + } + + if (decl == NULL_TREE) + return false; + } else if (class_ref == NULL) decl = expr->symtree->n.sym->backend_decl; else @@ -3033,6 +3060,12 @@ build_class_array_ref (gfc_se *se, tree base, tree index) class_ref->next = ref; } + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + return false; + size = gfc_vtable_size_get (decl); /* Build the address of the element. */ @@ -3075,7 +3108,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); /* Add the offset for this dimension to the stored offset for all other dimensions. */ - if (!integer_zerop (info->offset)) + if (info->offset && !integer_zerop (info->offset)) index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->offset); @@ -9049,6 +9082,11 @@ 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)) + return gfc_get_array_ss (ss, expr, + CLASS_DATA (expr->value.function.esym->result)->as->rank, + GFC_SS_FUNCTION); + /* A function that returns arrays. */ comp = gfc_get_proc_ptr_comp (expr); if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1af3696a922..d6f84ff04de 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3875,8 +3875,6 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, int n; int dimen; - gcc_assert (expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); @@ -3936,6 +3934,16 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, /* Translate the expression. */ gfc_conv_expr (&rse, expr); + /* 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)) + { + tmp = loop.ss->loop_chain->info->data.array.descriptor; + gfc_conv_descriptor_offset_set (&loop.pre, tmp, + gfc_index_zero_node); + } + gfc_conv_tmp_array_ref (&lse); if (intent != INTENT_OUT) @@ -3975,6 +3983,12 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gfc_init_loopinfo (&loop2); gfc_add_ss_to_loop (&loop2, lss); + dimen = rse.ss->dimen; + + /* Skip the write-out loop for this case. */ + if (gfc_is_alloc_class_array_function (expr)) + goto class_array_fcn; + /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop2); @@ -3998,7 +4012,6 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, outside the innermost loop, so the overall transfer could be optimized further. */ info = &rse.ss->info->data.array; - dimen = rse.ss->dimen; tmp_index = gfc_index_zero_node; for (n = dimen - 1; n > 0; n--) @@ -4057,6 +4070,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gfc_add_block_to_block (&parmse->post, &loop2.post); } +class_array_fcn: + gfc_add_block_to_block (&parmse->post, &loop.post); gfc_cleanup_loop (&loop); @@ -4199,9 +4214,9 @@ 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)); + || (comp && comp->attr.dimension) + || gfc_is_alloc_class_array_function (expr)); gcc_assert (se->loop != NULL); - /* Access the previously obtained result. */ gfc_conv_tmp_array_ref (se); return 0; @@ -4839,6 +4854,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_subref_array_arg (&parmse, e, f, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + + else if (gfc_is_alloc_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 + intent in. */ + { + e->must_finalize = 1; + gfc_conv_subref_array_arg (&parmse, e, f, + INTENT_IN, + fsym && fsym->attr.pointer); + } else gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); @@ -5576,7 +5603,80 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } else - gfc_add_block_to_block (&se->post, &post); + { + /* For a function with a class array result, save the result as + a temporary, set the info fields needed by the scalarizer and + 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) + && se->ss && se->ss->loop) + || gfc_is_alloc_class_scalar_function (expr)) + && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) + && expr->must_finalize) + { + tree final_fndecl; + tree is_final; + int n; + if (se->ss && se->ss->loop) + { + se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); + tmp = gfc_class_data_get (se->expr); + info->descriptor = tmp; + info->data = gfc_conv_descriptor_data_get (tmp); + info->offset = gfc_conv_descriptor_offset_get (tmp); + for (n = 0; n < se->ss->loop->dimen; n++) + { + tree dim = gfc_rank_cst[n]; + se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); + se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); + } + } + else + { + /* TODO Eliminate the doubling of temporaries. This + one is necessary to ensure no memory leakage. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); + tmp = gfc_class_data_get (se->expr); + tmp = gfc_conv_scalar_to_descriptor (se, tmp, + CLASS_DATA (expr->value.function.esym->result)->attr); + } + + final_fndecl = gfc_vtable_final_get (se->expr); + is_final = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + final_fndecl, + fold_convert (TREE_TYPE (final_fndecl), + null_pointer_node)); + final_fndecl = build_fold_indirect_ref_loc (input_location, + final_fndecl); + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, + gfc_build_addr_expr (NULL, tmp), + gfc_vtable_size_get (se->expr), + boolean_false_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, is_final, tmp, + build_empty_stmt (input_location)); + + if (se->ss && se->ss->loop) + { + gfc_add_expr_to_block (&se->ss->loop->post, tmp); + tmp = gfc_call_free (convert (pvoid_type_node, info->data)); + gfc_add_expr_to_block (&se->ss->loop->post, tmp); + } + else + { + gfc_add_expr_to_block (&se->post, tmp); + tmp = gfc_class_data_get (se->expr); + tmp = gfc_call_free (convert (pvoid_type_node, tmp)); + gfc_add_expr_to_block (&se->post, tmp); + } + expr->must_finalize = 0; + } + + gfc_add_block_to_block (&se->post, &post); + } return has_alternate_specifier; } @@ -7661,6 +7761,11 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) bool c = false; 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) + && expr1->ts.type == BT_DERIVED) + return true; + /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) return true; @@ -8530,6 +8635,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, && expr2->value.function.isym != NULL)) lss->is_alloc_lhs = 1; rss = NULL; + + if ((expr1->ts.type == BT_DERIVED) + && (gfc_is_alloc_class_array_function (expr2) + || gfc_is_alloc_class_scalar_function (expr2))) + expr2->must_finalize = 1; + if (lss != gfc_ss_terminator) { /* The assignment needs scalarization. */ @@ -8598,6 +8709,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Translate the expression. */ gfc_conv_expr (&rse, expr2); + /* Deal with the case of a scalar class function assigned to a derived type. */ + if (gfc_is_alloc_class_scalar_function (expr2) + && expr1->ts.type == BT_DERIVED) + { + rse.expr = gfc_class_data_get (rse.expr); + rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr); + } + /* Stabilize a string length for temporaries. */ if (expr2->ts.type == BT_CHARACTER) string_length = gfc_evaluate_now (rse.string_length, &rse.pre); @@ -8621,6 +8740,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, && !expr_is_variable (expr2) && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); + scalar_to_array |= (expr1->ts.type == BT_DERIVED + && expr1->rank + && expr1->ts.u.derived->attr.alloc_comp + && gfc_is_alloc_class_scalar_function (expr2)); if (scalar_to_array && dealloc) { tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0); @@ -8635,6 +8758,23 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred) gfc_add_block_to_block (&block, &rse.pre); + /* Nullify the allocatable components corresponding to those of the lhs + derived type, so that the finalization of the function result does not + affect the lhs of the assignment. Prepend is used to ensure that the + nullification occurs before the call to the finalizer. In the case of + 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_alloc_class_scalar_function (expr2))) + { + tmp = rse.expr; + tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0); + gfc_prepend_expr_to_block (&rse.post, tmp); + if (lss != gfc_ss_terminator && rss == gfc_ss_terminator) + gfc_add_block_to_block (&loop.post, &rse.post); + } + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, expr_is_variable (expr2) || scalar_to_array diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 48a804f00a6..921478ec5c7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2015-02-06 Paul Thomas + + PR fortran/63205 + * gfortran.dg/class_to_type_4.f90: New test + +2015-01-29 Andre Vehreschild + + * gfortran.dg/unlimited_polymorphic_22.f90: New test. + 2015-02-06 Jakub Jelinek PR rtl-optimization/64957 diff --git a/gcc/testsuite/gfortran.dg/class_to_type_4.f90 b/gcc/testsuite/gfortran.dg/class_to_type_4.f90 new file mode 100644 index 00000000000..cfa6d26339c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_4.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! +! PR fortran/63205 +! +! Check that passing a CLASS function result to a derived TYPE works +! +! Reported by Tobias Burnus +! + +program test + implicit none + type t + integer :: ii + end type t + type, extends(t) :: u + real :: rr + end type u + type, extends(t) :: v + real, allocatable :: rr(:) + end type v + type, extends(v) :: w + real, allocatable :: rrr(:) + end type w + + type(t) :: x, y(3) + type(v) :: a, b(3) + + x = func1() ! scalar to scalar - no alloc comps + if (x%ii .ne. 77) call abort + + y = func2() ! array to array - no alloc comps + if (any (y%ii .ne. [1,2,3])) call abort + + y = func1() ! scalar to array - no alloc comps + if (any (y%ii .ne. 77)) call abort + + x = func3() ! scalar daughter type to scalar - no alloc comps + if (x%ii .ne. 99) call abort + + y = func4() ! array daughter type to array - no alloc comps + if (any (y%ii .ne. [3,4,5])) call abort + + y = func3() ! scalar daughter type to array - no alloc comps + if (any (y%ii .ne. [99,99,99])) call abort + + a = func5() ! scalar to scalar - alloc comps in parent type + if (any (a%rr .ne. [10.0,20.0])) call abort + + b = func6() ! array to array - alloc comps in parent type + if (any (b(3)%rr .ne. [3.0,4.0])) call abort + + a = func7() ! scalar daughter type to scalar - alloc comps in parent type + if (any (a%rr .ne. [10.0,20.0])) call abort + + b = func8() ! array daughter type to array - alloc comps in parent type + if (any (b(3)%rr .ne. [3.0,4.0])) call abort + + b = func7() ! scalar daughter type to array - alloc comps in parent type + if (any (b(2)%rr .ne. [10.0,20.0])) call abort + +! This is an extension of class_to_type_2.f90's test using a daughter type +! instead of the declared type. + if (subpr2_array (g ()) .ne. 99 ) call abort +contains + + function func1() result(res) + class(t), allocatable :: res + allocate (res, source = t(77)) + end function func1 + + function func2() result(res) + class(t), allocatable :: res(:) + allocate (res(3), source = [u(1,1.0),u(2,2.0),u(3,3.0)]) + end function func2 + + function func3() result(res) + class(t), allocatable :: res + allocate (res, source = v(99,[99.0,99.0,99.0])) + end function func3 + + function func4() result(res) + class(t), allocatable :: res(:) + allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])]) + end function func4 + + function func5() result(res) + class(v), allocatable :: res + allocate (res, source = v(3,[10.0,20.0])) + end function func5 + + function func6() result(res) + class(v), allocatable :: res(:) + allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])]) + end function func6 + + function func7() result(res) + class(v), allocatable :: res + allocate (res, source = w(3,[10.0,20.0],[100,200])) + end function func7 + + function func8() result(res) + class(v), allocatable :: res(:) + allocate (res(3), source = [w(3,[1.0,2.0],[0.0]),w(4,[2.0,3.0],[0.0]),w(5,[3.0,4.0],[0.0])]) + end function func8 + + + integer function subpr2_array (x) + type(t) :: x(:) + if (any(x(:)%ii /= 55)) call abort + subpr2_array = 99 + end function + + function g () result(res) + integer i + class(t), allocatable :: res(:) + allocate (res(3), source = [(v (1, [1.0,2.0]), i = 1, 3)]) + res(:)%ii = 55 + end function g +end program test -- 2.30.2