From bbeffd6b40a97a661e78e10556a5b5f3edc4d78f Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Tue, 14 Aug 2012 16:45:55 +0000 Subject: [PATCH] re PR fortran/47586 ([F03] allocatable components: deep copy missing) fortran/ PR fortran/47586 * trans-expr.c (expr_is_variable): Handle regular, procedure pointer, and typebound functions returning a data pointer. testsuite/ PR fortran/47586 * gfortran.dg/typebound_proc_20.f90: Enable runtime test. * gfortran.dg/typebound_proc_27.f03: New test. From-SVN: r190394 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/trans-expr.c | 45 +++++++++++++ gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/typebound_proc_20.f90 | 3 +- gcc/testsuite/gfortran.dg/typebound_proc_27.f03 | 90 +++++++++++++++++++++++++ 5 files changed, 148 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_27.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f89d3a5..7161b62 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,11 @@ 2012-08-14 Mikael Morin + PR fortran/47586 + * trans-expr.c (expr_is_variable): Handle regular, procedure pointer, + and typebound functions returning a data pointer. + +2012-08-14 Mikael Morin + * decl.c (match_ppc_decl): Copy the procedure interface's symbol as procedure interface's result. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 53fdf45..4f7d0262 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6961,6 +6961,8 @@ static bool expr_is_variable (gfc_expr *expr) { gfc_expr *arg; + gfc_component *comp; + gfc_symbol *func_ifc; if (expr->expr_type == EXPR_VARIABLE) return true; @@ -6972,7 +6974,50 @@ expr_is_variable (gfc_expr *expr) return expr_is_variable (arg); } + /* A data-pointer-returning function should be considered as a variable + too. */ + if (expr->expr_type == EXPR_FUNCTION + && expr->ref == NULL) + { + if (expr->value.function.isym != NULL) + return false; + + if (expr->value.function.esym != NULL) + { + func_ifc = expr->value.function.esym; + goto found_ifc; + } + else + { + gcc_assert (expr->symtree); + func_ifc = expr->symtree->n.sym; + goto found_ifc; + } + + gcc_unreachable (); + } + + comp = gfc_get_proc_ptr_comp (expr); + if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION) + && comp) + { + func_ifc = comp->ts.interface; + goto found_ifc; + } + + if (expr->expr_type == EXPR_COMPCALL) + { + gcc_assert (!expr->value.compcall.tbp->is_generic); + func_ifc = expr->value.compcall.tbp->u.specific->n.sym; + goto found_ifc; + } + return false; + +found_ifc: + gcc_assert (func_ifc->attr.function + && func_ifc->result != NULL); + return func_ifc->result->attr.pointer; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1050588..8d1fea7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-08-14 Mikael Morin + + PR fortran/47586 + * gfortran.dg/typebound_proc_20.f90: Enable runtime test. + * gfortran.dg/typebound_proc_27.f03: New test. + 2012-08-14 Sterling Augustine * g++.dg/debug/dwarf2/pubnames-2.C: Adjust. diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 index b63daf9..47c131c 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 @@ -1,5 +1,4 @@ -! { dg-do compile } -! TODO: make runtime testcase once bug is fixed +! { dg-do run } ! ! PR fortran/47455 ! diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 new file mode 100644 index 0000000..28c44df --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 @@ -0,0 +1,90 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/47586 +! Missing deep copy for data pointer returning functions when the type +! has allocatable components +! +! Original testcase by Thomas Henlich +! Reduced by Tobias Burnus +! + +module m + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type proc_t + procedure(find_x), nopass, pointer :: ppc => null() + contains + procedure, nopass :: tbp => find_x + end type proc_t + +contains + + function find_x(that) + type(tx), target :: that + type(tx), pointer :: find_x + find_x => that + end function find_x + +end module m + +program prog + + use m + + type(tx) :: this + type(tx), target :: that + type(tx), pointer :: p + + type(proc_t) :: tab + + allocate(that%i(2)) + that%i = [3, 7] + p => that + this = that ! (1) direct assignment: works (deep copy) + that%i = [2, -5] + !print *,this%i + if(any (this%i /= [3, 7])) call abort() + this = p ! (2) using a pointer works as well + that%i = [10, 1] + !print *,this%i + if(any (this%i /= [2, -5])) call abort() + this = find_x(that) ! (3) pointer function: used to fail (deep copy missing) + that%i = [4, 6] + !print *,this%i + if(any (this%i /= [10, 1])) call abort() + this = tab%tbp(that) ! other case: typebound procedure + that%i = [8, 9] + !print *,this%i + if(any (this%i /= [4, 6])) call abort() + tab%ppc => find_x + this = tab%ppc(that) ! other case: procedure pointer component + that%i = [-1, 2] + !print *,this%i + if(any (this%i /= [8, 9])) call abort() + +end program prog + +! +! We add another check for deep copy by looking at the dump. +! We use realloc on assignment here: if we do a deep copy for the assignment +! to `this', we have a reallocation of `this%i'. +! Thus, the total number of malloc calls should be the number of assignment to +! `that%i' + the number of assignments to `this' + the number of allocate +! statements. +! It is assumed that if the number of allocate is right, the number of +! deep copies is right too. +! { dg-final { scan-tree-dump-times "__builtin_malloc" 12 "original" } } + +! +! Realloc are only used for assignments to `that%i'. Don't know why. +! { dg-final { scan-tree-dump-times "__builtin_realloc" 6 "original" } } +! + +! No leak: Only assignments to `this' use malloc. Assignments to `that%i' +! take the realloc path after the first assignment, so don't count as a malloc. +! { dg-final { scan-tree-dump-times "__builtin_free" 7 "original" } } +! +! { dg-final { cleanup-tree-dump "original" } } + -- 2.7.4