From bfa204b8b474475379cf40f066c25f63ab43d5f1 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Wed, 18 Jan 2012 20:52:48 +0000
Subject: [PATCH] re PR fortran/51634 ([OOP] ICE with polymorphic operators)
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.
From-SVN: r183287
---
gcc/fortran/ChangeLog | 6 ++
gcc/fortran/trans-expr.c | 12 +++-
gcc/testsuite/ChangeLog | 6 ++
.../gfortran.dg/typebound_operator_12.f03 | 45 ++++++++++++++
.../gfortran.dg/typebound_operator_13.f03 | 59 +++++++++++++++++++
5 files changed, 127 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_12.f03
create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_13.f03
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cbe12fada7ac..db01c0cfbe23 100644
--- 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 b41935add47e..15b6797c12b9 100644
--- 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 e79f00b58aca..1d982ecebe9c 100644
--- 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
index 000000000000..3496ed38639d
--- /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
index 000000000000..e1371c8a8178
--- /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" } }
+
--
GitLab