re PR fortran/47180 ([OOP] EXTENDS_TYPE_OF returns the wrong result for…

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

gcc/fortran/ChangeLog

+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

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);

gcc/testsuite/ChangeLog

+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__.

gcc/testsuite/gfortran.dg/extends_type_of_2.f03

+! { 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