OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/47586 ([F03] allocatable components: deep copy missing)

Browse Source 
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
This commit is contained in:
Mikael Morin 2012-08-14 16:45:55 +00:00
parent d7fee03dfc
commit bbeffd6b40
5 changed files with 148 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2012-08-14 Mikael Morin <mikael@gcc.gnu.org>
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 <mikael@gcc.gnu.org>
* decl.c (match_ppc_decl): Copy the procedure interface's symbol

45
gcc/fortran/trans-expr.c
View File

@ -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;
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2012-08-14 Mikael Morin <mikael@gcc.gnu.org>
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 <saugustine@google.com>
* g++.dg/debug/dwarf2/pubnames-2.C: Adjust.

3
gcc/testsuite/gfortran.dg/typebound_proc_20.f90
View File

@ -1,5 +1,4 @@
! { dg-do compile }
! TODO: make runtime testcase once bug is fixed
! { dg-do run }
!
! PR fortran/47455
!

90
gcc/testsuite/gfortran.dg/typebound_proc_27.f03 Normal file
View File

@ -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 <thenlich@users.sourceforge.net>
! Reduced by Tobias Burnus <burnus@net-b.de>
!
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" } }