OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/63205 ([OOP] Wrongly rejects type = class (for identical declared type))

Browse Source 
2015-02-06  Paul Thomas  <pault@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-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/63205
	* gfortran.dg/class_to_type_4.f90: New test

From-SVN: r220482
This commit is contained in:
Paul Thomas 2015-02-06 18:15:01 +00:00
parent 898c81f831
commit 43a68a9df5
7 changed files with 395 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
gcc/fortran/ChangeLog
View File

@ -1,16 +1,47 @@
2015-02-06 Paul Thomas <pault@gcc.gnu.org>
2015-01-29 Andre Vehreschild <vehre@gmx.de>, Janus Weil <janus@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-29 Andre Vehreschild <vehre@gmx.de>
Janus Weil <janus@gcc.gnu.org>
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 <vehre@gmx.de>
* 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 <burnus@net-b.de>

34
gcc/fortran/expr.c
View File

@ -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

5
gcc/fortran/gfortran.h
View File

@ -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 *);

46
gcc/fortran/trans-array.c
View File

@ -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)

150
gcc/fortran/trans-expr.c
View File

@ -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
{
/* 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

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2015-02-06 Paul Thomas <pault@gcc.gnu.org>
PR fortran/63205
* gfortran.dg/class_to_type_4.f90: New test
2015-01-29 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/unlimited_polymorphic_22.f90: New test.
2015-02-06 Jakub Jelinek <jakub@redhat.com>
PR rtl-optimization/64957

119
gcc/testsuite/gfortran.dg/class_to_type_4.f90 Normal file
View File

@ -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 <burnus@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