Dear All,
This patch enables the passing of an allocatable class object, scalar
or array, to a derived type of the declared type, either in an
assignment or as an actual argument. Much of the effort went into
sorting out the finalization call so that the 'left over' allocatable
components added by the dynamic type do not leak memory. At the
moment, the existence of the finalization function is tested for. A
check to see if the dynamic type is the same as the declared type
could be added.
Note that adding the 'must_finalize' field to gfc_expr will be useful
in enabling the missing mandatory finalization calls.
There are still interrogation marks about the patch; especially in
build_class_array_ref, where I do not understand why the added code
does not work in general, except for hidden function results.
Nonetheless, the code does not leak memory, apart perhaps from the
compound derived type constructors, with allocatable components that
already show leaks elsewhere. It is also well ringfenced and so should
not cause any regressions... touch wood!
Bootstraps and regtests on x86_64/FC21 - OK for trunk?
Paul
2015-01-27 Paul Thomas <pa...@gcc.gnu.org>
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-27 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/63205
* gfortran.dg/class_to_type_4.f90: New test
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 208092)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct gfc_expr
*** 1753,1758 ****
--- 1753,1761 ----
/* 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
*************** bool gfc_expr_check_typed (gfc_expr*, gf
*** 2804,2809 ****
--- 2807,2814 ----
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 *);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 208092)
--- gcc/fortran/expr.c (working copy)
*************** gfc_is_proc_ptr_comp (gfc_expr *expr)
*** 4274,4279 ****
--- 4274,4313 ----
}
+ /* 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
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 208092)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 2458,2464 ****
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
! if (expr->ts.type != BT_CHARACTER)
{
/* Move the evaluation of scalar expressions outside the
scalarization loop, except for WHERE assignments. */
--- 2458,2465 ----
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
! 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. */
*************** conv_array_index_offset (gfc_se * se, gf
*** 2939,2945 ****
stride = gfc_conv_descriptor_stride_get (info->descriptor,
gfc_rank_cst[dim]);
! if (!integer_zerop (info->delta[dim]))
index = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, index, info->delta[dim]);
}
--- 2940,2946 ----
stride = gfc_conv_descriptor_stride_get (info->descriptor,
gfc_rank_cst[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]);
}
*************** build_class_array_ref (gfc_se *se, tree
*** 2968,2974 ****
gfc_ref *class_ref;
gfc_typespec *ts;
! if (expr == NULL || expr->ts.type != BT_CLASS)
return false;
if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
--- 2969,2977 ----
gfc_ref *class_ref;
gfc_typespec *ts;
! 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)
*************** build_class_array_ref (gfc_se *se, tree
*** 3002,3007 ****
--- 3005,3034 ----
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
*************** build_class_array_ref (gfc_se *se, tree
*** 3017,3022 ****
--- 3044,3055 ----
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. */
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3059,3065 ****
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))
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
--- 3092,3098 ----
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 (info->offset && !integer_zerop (info->offset))
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
*** 8915,8920 ****
--- 8948,8958 ----
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)
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 208092)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 3583,3590 ****
int n;
int dimen;
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
--- 3583,3588 ----
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 3644,3649 ****
--- 3642,3657 ----
/* 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)
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 3683,3688 ****
--- 3691,3702 ----
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);
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 3706,3712 ****
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--)
--- 3720,3725 ----
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 3765,3770 ****
--- 3778,3785 ----
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);
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3907,3915 ****
{
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
! || (comp && comp->attr.dimension));
gcc_assert (se->loop != NULL);
-
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
return 0;
--- 3922,3930 ----
{
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->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;
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4497,4502 ****
--- 4512,4529 ----
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);
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5213,5219 ****
}
}
else
! gfc_add_block_to_block (&se->post, &post);
return has_alternate_specifier;
}
--- 5240,5319 ----
}
}
else
! {
! /* 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;
}
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 7019,7024 ****
--- 7119,7129 ----
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;
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 7887,7892 ****
--- 7992,8003 ----
&& 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. */
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 7955,7960 ****
--- 8066,8079 ----
/* 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);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 7978,7983 ****
--- 8097,8106 ----
&& !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);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 7993,7998 ****
--- 8116,8138 ----
&& 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
Index: gcc/testsuite/gfortran.dg/class_to_type_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/class_to_type_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/class_to_type_4.f90 (revision 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 <bur...@gcc.gnu.org>
+ !
+
+ 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
