re PR fortran/44696 ([OOP] ASSOCIATED fails on polymorphic variables)

2010-06-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44696
	* trans-intrinsic.c (gfc_conv_associated): Handle polymorphic variables
	passed as second argument of ASSOCIATED.

2010-06-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44696
	* gfortran.dg/associated_target_4.f90: New.

From-SVN: r161554

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 34c8f64..a838747 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2010-06-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/44696
+       * trans-intrinsic.c (gfc_conv_associated): Handle polymorphic variables
+       passed as second argument of ASSOCIATED.
+
 2010-06-29  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/44582

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9f63ebf..06fd538 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4416,6 +4416,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   else
     {
       /* An optional target.  */
+      if (arg2->expr->ts.type == BT_CLASS)
+       gfc_add_component_ref (arg2->expr, "$data");
       ss2 = gfc_walk_expr (arg2->expr);
 
       nonzero_charlen = NULL_TREE;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6bdd576..5a23fe0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-06-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/44696
+       * gfortran.dg/associated_target_4.f90: New.
+
 2010-06-29  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/44582

diff --git a/gcc/testsuite/gfortran.dg/associated_target_4.f90 b/gcc/testsuite/gfortran.dg/associated_target_4.f90
new file mode 100644 (file)
index 0000000..24f3317
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associated_target_4.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! PR 44696: [OOP] ASSOCIATED fails on polymorphic variables
+!
+! Original test case by Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+program rte1
+  implicit none
+  type::node_type
+     class(node_type),pointer::parent,child
+     integer::id
+  end type node_type
+  class(node_type),pointer::root
+  allocate(root)
+  allocate(root%child)
+  root%child%parent=>root
+  root%id=1
+  root%child%id=2
+  print *,root%child%id," is child of ",root%id,":"
+  print *,root%child%parent%id,root%id
+  if (.not. associated(root%child%parent,root)) call abort()
+end program rte1