2012-01-18 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/51634
	* trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
	components of temporary class arguments.

2012-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51634
	* gfortran.dg/typebound_operator_12.f03: New.
	* gfortran.dg/typebound_operator_13.f03: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183287 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cbe12fa..db01c0c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2012-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/51634
+       * trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
+       components of temporary class arguments.
+
 2012-01-17  Tobias Burnus  <burnus@net-b.de>
            Janne Blomqvist  <jb@gcc.gnu.org>
 

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b41935a..15b6797 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3736,7 +3736,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       /* Allocated allocatable components of derived types must be
         deallocated for non-variable scalars.  Non-variable arrays are
         dealt with in trans-array.c(gfc_conv_array_parameter).  */
-      if (e && e->ts.type == BT_DERIVED
+      if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
            && e->ts.u.derived->attr.alloc_comp
            && !(e->symtree && e->symtree->n.sym->attr.pointer)
            && (e->expr_type != EXPR_VARIABLE && !e->rank))
@@ -3768,6 +3768,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              gfc_add_expr_to_block (&se->post, local_tmp);
            }
 
+         if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
+           {
+             /* The derived type is passed to gfc_deallocate_alloc_comp.
+                Therefore, class actuals can handled correctly but derived
+                types passed to class formals need the _data component.  */
+             tmp = gfc_class_data_get (tmp);
+             if (!CLASS_DATA (fsym)->attr.dimension)
+               tmp = build_fold_indirect_ref_loc (input_location, tmp);
+           }
+
          tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
 
          gfc_add_expr_to_block (&se->post, tmp);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e79f00b..1d982ec 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/51634
+       * gfortran.dg/typebound_operator_12.f03: New.
+       * gfortran.dg/typebound_operator_13.f03: New.
+
 2012-01-18  Paolo Carlini  <paolo.carlini@oracle.com>
 
        PR c++/51225

diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_12.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_12.f03
new file mode 100644 (file)
index 0000000..3496ed3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_12.f03
@@ -0,0 +1,45 @@
+! { dg-do run }
+! PR51634 - Handle allocatable components correctly in expressions 
+! involving typebound operators. See comment 2 of PR.
+!
+! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+! 
+module soop_stars_class
+  implicit none
+  type soop_stars
+    real, dimension(:), allocatable :: position,velocity
+  contains
+    procedure :: total
+    procedure :: product
+    generic :: operator(+) => total
+    generic :: operator(*) => product
+  end type
+contains
+  type(soop_stars) function product(lhs,rhs)
+    class(soop_stars) ,intent(in) :: lhs
+    real ,intent(in) :: rhs
+    product%position = lhs%position*rhs
+    product%velocity = lhs%velocity*rhs
+  end function
+
+  type(soop_stars) function total(lhs,rhs)
+    class(soop_stars) ,intent(in) :: lhs,rhs
+    total%position = lhs%position + rhs%position
+    total%velocity = lhs%velocity + rhs%velocity
+  end function
+end module
+
+program main
+  use soop_stars_class ,only : soop_stars
+  implicit none
+  type(soop_stars) :: fireworks
+  real :: dt
+  fireworks%position = [1,2,3]
+  fireworks%velocity = [4,5,6]
+  dt = 5
+  fireworks = fireworks + fireworks*dt
+  if (any (fireworks%position .ne. [6, 12, 18])) call abort
+  if (any (fireworks%velocity .ne. [24, 30, 36])) call abort
+end program
+! { dg-final { cleanup-modules "soop_stars_class" } }
+

diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_13.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_13.f03
new file mode 100644 (file)
index 0000000..e1371c8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_13.f03
@@ -0,0 +1,59 @@
+! { dg-do run }
+! PR51634 - Handle allocatable components correctly in expressions 
+! involving typebound operators. From comment 2 of PR but using
+! classes throughout.
+!
+! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+! 
+module soop_stars_class
+  implicit none
+  type soop_stars
+    real, dimension(:), allocatable :: position,velocity
+  contains
+    procedure :: total
+    procedure :: mult
+    procedure :: assign
+    generic :: operator(+) => total
+    generic :: operator(*) => mult
+    generic :: assignment(=) => assign
+  end type
+contains
+  function mult(lhs,rhs)
+    class(soop_stars) ,intent(in) :: lhs
+    real ,intent(in) :: rhs
+    class(soop_stars), allocatable :: mult
+    type(soop_stars) :: tmp
+    tmp = soop_stars (lhs%position*rhs, lhs%velocity*rhs)
+    allocate (mult, source = tmp)
+  end function
+
+  function total(lhs,rhs)
+    class(soop_stars) ,intent(in) :: lhs,rhs
+    class(soop_stars), allocatable :: total
+    type(soop_stars) :: tmp
+    tmp = soop_stars (lhs%position + rhs%position, &
+                      lhs%velocity + rhs%velocity)
+    allocate (total, source = tmp)
+  end function
+
+  subroutine assign(lhs,rhs)
+    class(soop_stars), intent(in) :: rhs
+    class(soop_stars), intent(out) :: lhs
+    lhs%position = rhs%position
+    lhs%velocity = rhs%velocity
+  end subroutine
+end module
+
+program main
+  use soop_stars_class ,only : soop_stars
+  implicit none
+  class(soop_stars), allocatable :: fireworks
+  real :: dt
+  allocate (fireworks, source = soop_stars ([1,2,3], [4,5,6]))
+  dt = 5
+  fireworks = fireworks + fireworks*dt
+  if (any (fireworks%position .ne. [6, 12, 18])) call abort
+  if (any (fireworks%velocity .ne. [24, 30, 36])) call abort
+end program
+! { dg-final { cleanup-modules "soop_stars_class" } }
+