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

5 files changed, 148 insertions, 2 deletions

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  <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
 	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  <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.
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  <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" } }
+