re PR fortran/63205 ([OOP] Wrongly rejects type = class (for identical declared type))
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:
parent
898c81f831
commit
43a68a9df5
@ -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>
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 *);
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
119
gcc/testsuite/gfortran.dg/class_to_type_4.f90
Normal 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
|
Loading…
Reference in New Issue
Block a user