From e86bbccfb3293972c2ce36049ae6aa1ff6f9645b Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 11 Jun 2015 15:49:32 +0000 Subject: [PATCH] 2015-06-11 Paul Thomas PR fortran/66079 * trans-expr.c (gfc_conv_procedure_call): Allocatable scalar function results must be freed and nullified after use. Create a temporary to hold the result to prevent duplicate calls. * trans-stmt.c (gfc_trans_allocate): Rename temporary variable as 'source'. Deallocate allocatable components of non-variable 'source's. 2015-06-11 Paul Thomas PR fortran/66079 * gfortran.dg/allocatable_scalar_13.f90: New test git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@224383 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 12 +++- gcc/fortran/trans-expr.c | 14 +++++ gcc/fortran/trans-stmt.c | 15 ++++- gcc/testsuite/ChangeLog | 7 ++- .../gfortran.dg/allocatable_scalar_13.f90 | 70 ++++++++++++++++++++++ 5 files changed, 115 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 57a9997ad90..662e3d2f98a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2015-06-11 Paul Thomas + + PR fortran/66079 + * trans-expr.c (gfc_conv_procedure_call): Allocatable scalar + function results must be freed and nullified after use. Create + a temporary to hold the result to prevent duplicate calls. + * trans-stmt.c (gfc_trans_allocate): Rename temporary variable + as 'source'. Deallocate allocatable components of non-variable + 'source's. + 2015-06-11 Pierre-Marie de Rodat * f95-lang.c (gfc_create_decls): Register the main translation unit @@ -258,7 +268,7 @@ PR fortran/66044 * decl.c(gfc_match_entry): Change a gfc_internal_error() into - a gfc_error() + a gfc_error() 2015-05-18 Steven G. Kargl diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1c880bc8ccc..e3f49f59703 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5871,6 +5871,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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() diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index a7f39d0ad40..69750dfa010 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5207,6 +5207,7 @@ gfc_trans_allocate (gfc_code * code) 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)) @@ -5216,8 +5217,20 @@ gfc_trans_allocate (gfc_code * code) se.expr); /* We need a regular (non-UID) symbol here, therefore give a prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + var = gfc_create_var (TREE_TYPE (tmp), "source"); 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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f5abd3d4de7..d46ba74e500 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-06-11 Paul Thomas + + PR fortran/66079 + * gfortran.dg/allocatable_scalar_13.f90: New test + 2015-06-11 Marek Polacek * gcc.dg/fold-xor-3.c: New test. @@ -666,7 +671,7 @@ 2015-05-27 Honggyu Kim PR target/65358 - * gcc.dg/pr65358.c: New test. + * gcc.dg/pr65358.c: New test. 2015-05-27 Andre Vehreschild diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 new file mode 100644 index 00000000000..bc6f01739f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 @@ -0,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 +! + 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" } } + -- 2.11.4.GIT