Hi all, hi Paul,
Paul thanks for the review. Committed as r225507.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 223641)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5877,5882 ****
--- 5877,5896 ----
fntype = TREE_TYPE (TREE_TYPE (se->expr));
se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
+ /* Allocatable scalar function results must be freed and nullified
+ after use. This necessitates the creation of a temporary to
+ hold the result to prevent duplicate calls. */
+ if (!byref && sym->ts.type != BT_CHARACTER
+ && sym->attr.allocatable && !sym->attr.dimension)
+ {
+ tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify (&se->pre, tmp, se->expr);
+ se->expr = tmp;
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&post, tmp);
+ gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
+ }
+
/* If we have a pointer function, but we don't want a pointer, e.g.
something like
x = f()
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 223641)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5214,5219 ****
--- 5214,5220 ----
false, false);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
+
/* Prevent aliasing, i.e., se.expr may be already a
variable declaration. */
if (!VAR_P (se.expr))
*************** gfc_trans_allocate (gfc_code * code)
*** 5223,5230 ****
se.expr);
/* We need a regular (non-UID) symbol here, therefore give a
prefix. */
! var = gfc_create_var (TREE_TYPE (tmp), "atmp");
gfc_add_modify_loc (input_location, &block, var, tmp);
tmp = var;
}
else
--- 5224,5243 ----
se.expr);
/* We need a regular (non-UID) symbol here, therefore give a
prefix. */
! var = gfc_create_var (TREE_TYPE (tmp), "expr3");
gfc_add_modify_loc (input_location, &block, var, tmp);
+
+ /* Deallocate any allocatable components after all the allocations
+ and assignments of expr3 have been completed. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && code->expr3->rank == 0
+ && code->expr3->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+ var, 0);
+ gfc_add_expr_to_block (&post, tmp);
+ }
+
tmp = var;
}
else
Index: gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 (working copy)
***************
*** 0 ****
--- 1,70 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR66079. The original problem was with the first
+ ! allocate statement. The rest of this testcase fixes problems found
+ ! whilst working on it!
+ !
+ ! Reported by Damian Rouson <dam...@sourceryinstitute.org>
+ !
+ type subdata
+ integer, allocatable :: b
+ endtype
+ ! block
+ call newRealVec
+ ! end block
+ contains
+ subroutine newRealVec
+ type(subdata), allocatable :: d, e, f
+ character(:), allocatable :: g, h, i
+ character(8), allocatable :: j
+ allocate(d,source=subdata(1)) ! memory was lost, now OK
+ allocate(e,source=d) ! OK
+ allocate(f,source=create (99)) ! memory was lost, now OK
+ if (d%b .ne. 1) call abort
+ if (e%b .ne. 1) call abort
+ if (f%b .ne. 99) call abort
+ allocate (g, source = greeting1("good day"))
+ if (g .ne. "good day") call abort
+ allocate (h, source = greeting2("hello"))
+ if (h .ne. "hello") call abort
+ allocate (i, source = greeting3("hiya!"))
+ if (i .ne. "hiya!") call abort
+ call greeting4 (j, "Goodbye ") ! Test that dummy arguments are OK
+ if (j .ne. "Goodbye ") call abort
+ end subroutine
+
+ function create (arg) result(res)
+ integer :: arg
+ type(subdata), allocatable :: res, res1
+ allocate(res, res1, source = subdata(arg))
+ end function
+
+ function greeting1 (arg) result(res) ! memory was lost, now OK
+ character(*) :: arg
+ Character(:), allocatable :: res
+ allocate(res, source = arg)
+ end function
+
+ function greeting2 (arg) result(res)
+ character(5) :: arg
+ Character(:), allocatable :: res
+ allocate(res, source = arg)
+ end function
+
+ function greeting3 (arg) result(res)
+ character(5) :: arg
+ Character(5), allocatable :: res, res1
+ allocate(res, res1, source = arg) ! Caused an ICE
+ if (res1 .ne. res) call abort
+ end function
+
+ subroutine greeting4 (res, arg)
+ character(8), intent(in) :: arg
+ Character(8), allocatable, intent(out) :: res
+ allocate(res, source = arg) ! Caused an ICE
+ end subroutine
+ end
+ ! { dg-final { scan-tree-dump-times "builtin_malloc" 20 "original" } }
+ ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
