+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-01-29 Andre Vehreschild <vehre@gmx.de>, Janus Weil <janus@gcc.gnu.org>
+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>
}
+/* 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
/* 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
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 *);
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. */
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]);
}
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)
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
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. */
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);
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)
int n;
int dimen;
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
/* 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_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);
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--)
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);
{
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;
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);
}
}
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;
}
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;
&& 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. */
/* 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);
&& !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);
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
+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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff