===================================================================
*************** gfc_conv_procedure_call (gfc_se * se, gf
for (arg = args, argc = 0; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
+ bool finalized = false;
+
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
*************** gfc_conv_procedure_call (gfc_se * se, gf
&& e->ts.type == BT_CLASS
&& !CLASS_DATA (e)->attr.dimension
&& !CLASS_DATA (e)->attr.codimension)
! parmse.expr = gfc_class_data_get (parmse.expr);
/* Wrap scalar variable in a descriptor. We need to convert
the address of a pointer back to the pointer itself before,
&& e->ts.type == BT_CLASS
&& !CLASS_DATA (e)->attr.dimension
&& !CLASS_DATA (e)->attr.codimension)
! {
! parmse.expr = gfc_class_data_get (parmse.expr);
! /* The result is a class temporary, whose _data component
! must be freed to avoid a memory leak. */
! if (e->expr_type == EXPR_FUNCTION
! && CLASS_DATA (e)->attr.allocatable)
! {
! tree zero;
!
! gfc_expr *var;
!
! /* Borrow the function symbol to make a call to
! gfc_add_finalizer_call and then restore it. */
! tmp = e->symtree->n.sym->backend_decl;
! e->symtree->n.sym->backend_decl
! = TREE_OPERAND (parmse.expr, 0);
! e->symtree->n.sym->attr.flavor = FL_VARIABLE;
! var = gfc_lval_expr_from_sym (e->symtree->n.sym);
! finalized = gfc_add_finalizer_call (&parmse.post,
! var);
! gfc_free_expr (var);
! e->symtree->n.sym->backend_decl = tmp;
! e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
!
! /* Then free the class _data. */
! zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
! tmp = fold_build2_loc (input_location, NE_EXPR,
! logical_type_node,
! parmse.expr, zero);
! tmp = build3_v (COND_EXPR, tmp,
! gfc_call_free (parmse.expr),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&parmse.post, tmp);
! gfc_add_modify (&parmse.post, parmse.expr, zero);
! }
! }
/* Wrap scalar variable in a descriptor. We need to convert
the address of a pointer back to the pointer itself before,
*************** gfc_conv_procedure_call (gfc_se * se, gf
tmp = build_fold_indirect_ref_loc (input_location, tmp);
}
! tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
!
! gfc_prepend_expr_to_block (&post, tmp);
}
/* Add argument checking of passing an unallocated/NULL actual to
tmp = build_fold_indirect_ref_loc (input_location, tmp);
}
! if (!finalized && !e->must_finalize)
! {
! if ((e->ts.type == BT_CLASS
! && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
! || e->ts.type == BT_DERIVED)
! tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
! parm_rank);
! else if (e->ts.type == BT_CLASS)
! tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
! tmp, parm_rank);
! gfc_prepend_expr_to_block (&post, tmp);
! }
}
/* Add argument checking of passing an unallocated/NULL actual to
*************** gfc_conv_procedure_call (gfc_se * se, gf
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
! final_fndecl,
fold_convert (TREE_TYPE (final_fndecl),
null_pointer_node));
final_fndecl = build_fold_indirect_ref_loc (input_location,
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
! final_fndecl,
fold_convert (TREE_TYPE (final_fndecl),
null_pointer_node));
final_fndecl = build_fold_indirect_ref_loc (input_location,
*************** gfc_conv_procedure_call (gfc_se * se, gf
gfc_build_addr_expr (NULL, tmp),
gfc_class_vtab_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 (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 (tmp);
gfc_add_expr_to_block (&se->post, tmp);
}
-
- no_finalization:
- expr->must_finalize = 0;
}
gfc_add_block_to_block (&se->post, &post);
}
gfc_build_addr_expr (NULL, tmp),
gfc_class_vtab_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_prepend_expr_to_block (&se->ss->loop->post, tmp);
! tmp = fold_build2_loc (input_location, NE_EXPR,
! logical_type_node,
! info->data,
! fold_convert (TREE_TYPE (info->data),
! null_pointer_node));
! tmp = fold_build3_loc (input_location, COND_EXPR,
! void_type_node, tmp,
! gfc_call_free (info->data),
! build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->ss->loop->post, tmp);
}
else
{
! tree classdata;
! gfc_prepend_expr_to_block (&se->post, tmp);
! classdata = gfc_class_data_get (se->expr);
! tmp = fold_build2_loc (input_location, NE_EXPR,
! logical_type_node,
! classdata,
! fold_convert (TREE_TYPE (classdata),
! null_pointer_node));
! tmp = fold_build3_loc (input_location, COND_EXPR,
! void_type_node, tmp,
! gfc_call_free (classdata),
! build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
}
}
+ no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
*************** gfc_conv_expr_reference (gfc_se * se, gf
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, var, se->expr);
}
! gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, var, se->expr);
}
!
! if (!expr->must_finalize)
! gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
comp = gfc_get_proc_ptr_comp (expr2);
! gcc_assert (expr2->value.function.isym
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
! && expr2->value.function.esym->result->attr.dimension));
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
comp = gfc_get_proc_ptr_comp (expr2);
!
! if (!(expr2->value.function.isym
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
! && expr2->value.function.esym->result->attr.dimension)))
! return NULL;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
gfc_add_block_to_block (&loop.post, &rse.post);
}
+ tmp = NULL_TREE;
+
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
*************** gfc_trans_assignment_1 (gfc_expr * expr1
code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
tmp = gfc_conv_intrinsic_subroutine (&code);
}
! else
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
gfc_expr_is_variable (expr2)
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
tmp = gfc_conv_intrinsic_subroutine (&code);
}
! else if (!is_poly_assign && expr2->must_finalize
! && expr1->ts.type == BT_CLASS
! && expr2->ts.type == BT_CLASS)
! {
! /* This case comes about when the scalarizer provides array element
! references. Use the vptr copy function, since this does a deep
! copy of allocatable components, without which the finalizer call */
! tmp = gfc_get_vptr_from_expr (rse.expr);
! if (tmp != NULL_TREE)
! {
! tree fcn = gfc_vptr_copy_get (tmp);
! if (POINTER_TYPE_P (TREE_TYPE (fcn)))
! fcn = build_fold_indirect_ref_loc (input_location, fcn);
! tmp = build_call_expr_loc (input_location,
! fcn, 2,
! gfc_build_addr_expr (NULL, rse.expr),
! gfc_build_addr_expr (NULL, lse.expr));
! }
! }
!
! /* If nothing else works, do it the old fashioned way! */
! if (tmp == NULL_TREE)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
gfc_expr_is_variable (expr2)
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
+
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
===================================================================
*************** gfc_trans_allocate (gfc_code * code)
enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
+ stmtblock_t final_block;
tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
bool needs_caf_sync, caf_refs_comp;
*************** gfc_trans_allocate (gfc_code * code)
gfc_init_block (&block);
gfc_init_block (&post);
+ gfc_init_block (&final_block);
/* STAT= (and maybe ERRMSG=) is present. */
if (code->expr1)
*************** gfc_trans_allocate (gfc_code * code)
is_coarray = gfc_is_coarray (code->expr3);
+ if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
+ && (gfc_is_class_array_function (code->expr3)
+ || gfc_is_alloc_class_scalar_function (code->expr3)))
+ code->expr3->must_finalize = 1;
+
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
al = al->next)
*************** gfc_trans_allocate (gfc_code * code)
temp_obj_created = temp_var_needed = !VAR_P (se.expr);
}
gfc_add_block_to_block (&block, &se.pre);
! gfc_add_block_to_block (&post, &se.post);
/* Special case when string in expr3 is zero. */
if (code->expr3->ts.type == BT_CHARACTER
temp_obj_created = temp_var_needed = !VAR_P (se.expr);
}
gfc_add_block_to_block (&block, &se.pre);
! if (code->expr3->must_finalize)
! gfc_add_block_to_block (&final_block, &se.post);
! else
! gfc_add_block_to_block (&post, &se.post);
/* Special case when string in expr3 is zero. */
if (code->expr3->ts.type == BT_CHARACTER
*************** gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &post);
+ if (code->expr3 && code->expr3->must_finalize)
+ gfc_add_block_to_block (&block, &final_block);
return gfc_finish_block (&block);
}
===================================================================
***************
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR86481
+ !
+ ! Contributed by Rich Townsend <townsend@astro.wisc.edu>
+ !
+ program simple_leak
+
+ implicit none
+
+ type, abstract :: foo_t
+ end type foo_t
+
+ type, extends(foo_t) :: foo_a_t
+ real(8), allocatable :: a(:)
+ end type foo_a_t
+
+ type, extends(foo_t) :: bar_t
+ class(foo_t), allocatable :: f
+ end type bar_t
+
+ integer, parameter :: N = 2
+ integer, parameter :: D = 3
+
+ type(bar_t) :: b(N)
+ integer :: i
+
+ do i = 1, N
+ b(i) = func_bar(D)
+ end do
+
+ do i = 1, N
+ deallocate (b(i)%f)
+ end do
+
+ contains
+
+ function func_bar (D) result (b)
+
+ integer, intent(in) :: D
+ type(bar_t) :: b
+
+ allocate(b%f, SOURCE=func_foo(D))
+
+ end function func_bar
+
+ !****
+
+ function func_foo (D) result (f)
+
+ integer, intent(in) :: D
+ class(foo_t), allocatable :: f
+
+ allocate(f, SOURCE=func_foo_a(D)) ! Lose one of these for each allocation
+
+ end function func_foo
+
+ !****
+
+ function func_foo_a (D) result (f)
+
+ integer, intent(in) :: D
+ type(foo_a_t) :: f
+
+ allocate(f%a(D)) ! Lose one of these for each allocation => N*D*elem_size(f%a)
+
+ end function func_foo_a
+
+ end program simple_leak
+ ! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
===================================================================
***************
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR80477
+ !
+ ! Contributed by Stefano Zaghi <stefano.zaghi@cnr.it>
+ !
+ module a_type_m
+ implicit none
+ type :: a_type_t
+ real :: x
+ endtype
+ contains
+ subroutine assign_a_type(lhs, rhs)
+ type(a_type_t), intent(inout) :: lhs
+ type(a_type_t), intent(in) :: rhs
+ lhs%x = rhs%x
+ end subroutine
+
+ function add_a_type(lhs, rhs) result( res )
+ type(a_type_t), intent(in) :: lhs
+ type(a_type_t), intent(in) :: rhs
+ class(a_type_t), allocatable :: res
+ allocate (a_type_t :: res)
+ res%x = lhs%x + rhs%x
+ end function
+ end module
+
+ program polymorphic_operators_memory_leaks
+ use a_type_m
+ implicit none
+ type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+ call assign_a_type (a, add_a_type(a,b)) ! generated a memory leak
+ end
+ ! { dg-final { scan-tree-dump-times "builtin_free" 1 "original" } }
+ ! { dg-final { scan-tree-dump-times "builtin_malloc" 1 "original" } }
===================================================================
***************
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for the array version of PR80477
+ !
+ ! Contributed by Stefano Zaghi <stefano.zaghi@cnr.it>
+ !
+ module a_type_m
+ implicit none
+ type :: a_type_t
+ real :: x
+ real, allocatable :: y(:)
+ endtype
+ contains
+ subroutine assign_a_type(lhs, rhs)
+ type(a_type_t), intent(inout) :: lhs
+ type(a_type_t), intent(in) :: rhs(:)
+ lhs%x = rhs(1)%x + rhs(2)%x
+ end subroutine
+
+ function add_a_type(lhs, rhs) result( res )
+ type(a_type_t), intent(in) :: lhs
+ type(a_type_t), intent(in) :: rhs
+ class(a_type_t), allocatable :: res(:)
+ allocate (a_type_t :: res(2))
+ allocate (res(1)%y(1))
+ allocate (res(2)%y(1))
+ res(1)%x = lhs%x
+ res(2)%x = rhs%x
+ end function
+ end module
+
+ program polymorphic_operators_memory_leaks
+ use a_type_m
+ implicit none
+ type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+ call assign_a_type (a, add_a_type(a,b))
+ print *, a%x
+ end
+ ! { dg-final { scan-tree-dump-times "builtin_free" 6 "original" } }
+ ! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } }
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for an additional bug found while fixing PR80477
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ module a_type_m
+ implicit none
+ type :: a_type_t
+ real :: x
+ real, allocatable :: y(:)
+ endtype
+ contains
+ subroutine assign_a_type(lhs, rhs)
+ type(a_type_t), intent(inout) :: lhs
+ type(a_type_t), intent(in) :: rhs(:)
+ lhs%x = rhs(1)%x + rhs(2)%x
+ lhs%y = rhs(1)%y + rhs(2)%y
+ end subroutine
+
+ function add_a_type(lhs, rhs) result( res )
+ type(a_type_t), intent(in) :: lhs
+ type(a_type_t), intent(in) :: rhs
+ class(a_type_t), allocatable :: res(:)
+ allocate (a_type_t :: res(2))
+ allocate (res(1)%y(1), source = [10.0])
+ allocate (res(2)%y(1), source = [20.0])
+ res(1)%x = lhs%x + rhs%x
+ res(2)%x = rhs%x + rhs%x
+ end function
+ end module
+
+ program polymorphic_operators_memory_leaks
+ use a_type_m
+ implicit none
+ type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+ class(a_type_t), allocatable :: res(:)
+
+ res = add_a_type(a,b) ! Remarkably, this ICEd - found while debugging the PR.
+ call assign_a_type (a, res)
+ if (int (res(1)%x + res(2)%x) .ne. int (a%x)) stop 1
+ if (int (sum (res(1)%y + res(2)%y)) .ne. int (sum (a%y))) stop 1
+ deallocate (a%y)
+ deallocate (res)
+ end