re PR fortran/47180 ([OOP] EXTENDS_TYPE_OF returns the wrong result for disassociated polymorphic pointers)

2011-01-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47180
	* trans-expr.c (gfc_trans_class_assign): For a polymorphic NULL pointer
	assignment, set the _vptr component to the declared type.


2011-01-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47180
	* gfortran.dg/extends_type_of_2.f03: New.

From-SVN: r168524

4 files changed, 60 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5be47c6..b7f5afe 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2011-01-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47180
+	* trans-expr.c (gfc_trans_class_assign): For a polymorphic NULL pointer
+	assignment, set the _vptr component to the declared type.
+
 2011-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/46017
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3e994aa..fa58376 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6121,24 +6121,23 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
   if (expr2->ts.type != BT_CLASS)
     {
       /* Insert an additional assignment which sets the '_vptr' field.  */
+      gfc_symbol *vtab;
+      gfc_symtree *st;
+
       lhs = gfc_copy_expr (expr1);
       gfc_add_vptr_component (lhs);
+
       if (expr2->ts.type == BT_DERIVED)
-	{
-	  gfc_symbol *vtab;
-	  gfc_symtree *st;
-	  vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
-	  gcc_assert (vtab);
-	  rhs = gfc_get_expr ();
-	  rhs->expr_type = EXPR_VARIABLE;
-	  gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
-	  rhs->symtree = st;
-	  rhs->ts = vtab->ts;
-	}
+	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
       else if (expr2->expr_type == EXPR_NULL)
-	rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
-      else
-	gcc_unreachable ();
+	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+      gcc_assert (vtab);
+
+      rhs = gfc_get_expr ();
+      rhs->expr_type = EXPR_VARIABLE;
+      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+      rhs->symtree = st;
+      rhs->ts = vtab->ts;
 
       tmp = gfc_trans_pointer_assignment (lhs, rhs);
       gfc_add_expr_to_block (&block, tmp);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1c3d417..ea5cac7 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47180
+	* gfortran.dg/extends_type_of_2.f03: New.
+
 2011-01-05  Ulrich Weigand  <Ulrich.Weigand@de.ibm.com>
 
 	* gcc.dg/stack-usage-1.c (SIZE): Provide proper value for __SPU__.
diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_2.f03 b/gcc/testsuite/gfortran.dg/extends_type_of_2.f03
new file mode 100644
index 0000000..f882cb1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/extends_type_of_2.f03
@@ -0,0 +1,36 @@
+! { dg-do run }
+!
+! PR 47180: [OOP] EXTENDS_TYPE_OF returns the wrong result for disassociated polymorphic pointers 
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+
+type t1
+  integer :: a
+end type t1
+
+type, extends(t1):: t11
+  integer :: b
+end type t11
+
+type(t1)  , target  :: a1
+type(t11) , target  :: a11
+class(t1) , pointer :: b1
+class(t11), pointer :: b11
+
+b1  => NULL()
+b11 => NULL()
+
+if (.not. extends_type_of(b1 , a1)) call abort()
+if (.not. extends_type_of(b11, a1)) call abort()
+if (.not. extends_type_of(b11,a11)) call abort()
+
+b1  => a1
+b11 => a11
+
+if (.not. extends_type_of(b1 , a1)) call abort()
+if (.not. extends_type_of(b11, a1)) call abort()
+if (.not. extends_type_of(b11,a11)) call abort()
+
+end