PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992

2013-01-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/PR53876
	PR fortran/PR54990
	PR fortran/PR54992
	* trans-array.c (build_array_ref): Check the TYPE_CANONICAL
	to see if it is GFC_CLASS_TYPE_P.
	* trans-expr.c (gfc_get_vptr_from_expr): The same.
	(gfc_conv_class_to_class): If the types are not the same,
	cast parmese->expr to the type of ctree.
	* trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of
	CLASS components must be set.

2013-01-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/PR53876
	PR fortran/PR54990
	PR fortran/PR54992
	* gfortran.dg/class_array_15.f03: New test.

From-SVN: r194953

gcc/fortran/ChangeLog

+2013-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/PR53876
+	PR fortran/PR54990
+	PR fortran/PR54992
+	* trans-array.c (build_array_ref): Check the TYPE_CANONICAL
+	to see if it is GFC_CLASS_TYPE_P.
+	* trans-expr.c (gfc_get_vptr_from_expr): The same.
+	(gfc_conv_class_to_class): If the types are not the same,
+	cast parmese->expr to the type of ctree.
+	* trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of
+	CLASS components must be set.
+
 2013-01-06  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/42769

gcc/fortran/trans-array.c

 /* Array translation routines
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011, 2012
+   2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -3099,31 +3099,40 @@ static tree
 build_array_ref (tree desc, tree offset, tree decl)
 {
   tree tmp;
+  tree type;
+
+  /* Class container types do not always have the GFC_CLASS_TYPE_P
+     but the canonical type does.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+      && TREE_CODE (desc) == COMPONENT_REF)
+    {
+      type = TREE_TYPE (TREE_OPERAND (desc, 0));
+      if (TYPE_CANONICAL (type)
+	  && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
+	type = TYPE_CANONICAL (type);
+    }
+  else
+    type = NULL;
 
   /* Class array references need special treatment because the assigned
      type size needs to be used to point to the element.  */
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
-	&& TREE_CODE (desc) == COMPONENT_REF
-	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+  if (type && GFC_CLASS_TYPE_P (type))
     {
-      tree type = gfc_get_element_type (TREE_TYPE (desc));
+      type = gfc_get_element_type (TREE_TYPE (desc));
       tmp = TREE_OPERAND (desc, 0);
       tmp = gfc_get_class_array_ref (offset, tmp);
       tmp = fold_convert (build_pointer_type (type), tmp);
       tmp = build_fold_indirect_ref_loc (input_location, tmp);
+      return tmp;
     }
-  else
-    {
+
   tmp = gfc_conv_array_data (desc);
   tmp = build_fold_indirect_ref_loc (input_location, tmp);
   tmp = gfc_build_array_ref (tmp, offset, decl);
-    }
-
   return tmp;
 }
 
 
-
 /* Build an array reference.  se->expr already holds the array descriptor.
    This should be either a variable, indirect variable reference or component
    reference.  For arrays which do not have a descriptor, se->expr will be

gcc/fortran/trans-expr.c

@@ -198,16 +198,31 @@ gfc_vtable_final_get (tree decl)
 #undef VTABLE_FINAL_FIELD
 
 
-/* Obtain the vptr of the last class reference in an expression.  */
+/* Obtain the vptr of the last class reference in an expression.
+   Return NULL_TREE if no class reference is found.  */
 
 tree
 gfc_get_vptr_from_expr (tree expr)
 {
-  tree tmp = expr;
-  while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
-    tmp = TREE_OPERAND (tmp, 0);
-  tmp = gfc_class_vptr_get (tmp);
-  return tmp;
+  tree tmp;
+  tree type;
+
+  for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
+    {
+      type = TREE_TYPE (tmp);
+      while (type)
+	{
+	  if (GFC_CLASS_TYPE_P (type))
+	    return gfc_class_vptr_get (tmp);
+	  if (type != TYPE_CANONICAL (type))
+	    type = TYPE_CANONICAL (type);
+	  else
+	    type = NULL_TREE;
+	}
+      if (TREE_CODE (tmp) == VAR_DECL)
+	break;
+    }
+  return NULL_TREE;
 }
 
 
@@ -594,7 +609,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
     }
   else
     {
-      if (CLASS_DATA (e)->attr.codimension)
+      if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
 	parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 					TREE_TYPE (ctree), parmse->expr);
       gfc_add_modify (&block, ctree, parmse->expr);
@@ -1562,6 +1577,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       c->norestrict_decl = f2;
       field = f2;
     }
+
   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			 decl, field, NULL_TREE);
 

gcc/fortran/trans-types.c

 /* Backend support for Fortran 95 basic types and derived types.
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010, 2011, 2012
+   2010, 2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -2532,6 +2532,15 @@ gfc_get_derived_type (gfc_symbol * derived)
 	  field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
 						    ptr_mode, true);
 
+      /* Ensure that the CLASS language specific flag is set.  */
+      if (c->ts.type == BT_CLASS)
+	{
+	  if (POINTER_TYPE_P (field_type))
+	    GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+	  else
+	    GFC_CLASS_TYPE_P (field_type) = 1;
+	}
+
       field = gfc_add_field_to_struct (typenode,
 				       get_identifier (c->name),
 				       field_type, &chain);

gcc/testsuite/ChangeLog

+2013-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/PR53876
+	PR fortran/PR54990
+	PR fortran/PR54992
+	* gfortran.dg/class_array_15.f03: New test.
+
 2013-01-06  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/42769

gcc/testsuite/gfortran.dg/class_array_15.f03

+! { dg-do run }
+!
+! Tests the fixes for three bugs with the same underlying cause.  All are regressions
+! that come about because class array elements end up with a different tree type
+! to the class array.  In addition, the language specific flag that marks a class
+! container is not being set.
+!
+! PR53876 contributed by Prince Ogunbade  <pogos77@hotmail.com>
+! PR54990 contributed by Janus Weil  <janus@gcc.gnu.org>
+! PR54992 contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+! The two latter bugs were reported by Andrew Benson
+! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
+!
+module G_Nodes
+  type :: nc
+    type(tn), pointer :: hostNode
+  end type nc
+  type, extends(nc) :: ncBh
+  end type ncBh
+  type, public, extends(ncBh) :: ncBhStd
+    double precision :: massSeedData
+  end type ncBhStd
+  type, public :: tn
+    class (ncBh), allocatable, dimension(:) :: cBh
+  end type tn
+  type(ncBhStd) :: defaultBhC
+contains
+  subroutine Node_C_Bh_Move(targetNode)
+    implicit none
+    type (tn  ), intent(inout) , target       :: targetNode
+    class(ncBh), allocatable   , dimension(:) :: instancesTemporary
+! These two lines resulted in the wrong result:
+    allocate(instancesTemporary(2),source=defaultBhC)
+    call Move_Alloc(instancesTemporary,targetNode%cBh)
+! These two lines gave the correct result:
+!!deallocate(targetNode%cBh)
+!!allocate(targetNode%cBh(2))
+    targetNode%cBh(1)%hostNode => targetNode
+    targetNode%cBh(2)%hostNode => targetNode
+    return
+  end subroutine Node_C_Bh_Move
+  function bhGet(self,instance)
+    implicit none
+    class (ncBh), pointer               :: bhGet
+    class (tn  ), intent(inout), target :: self
+    integer     , intent(in   )         :: instance
+    bhGet => self%cBh(instance)
+    return
+  end function bhGet
+end module G_Nodes
+
+  call pr53876
+  call pr54990
+  call pr54992
+end
+
+subroutine pr53876
+  IMPLICIT NONE
+  TYPE :: individual
+    integer :: icomp ! Add an extra component to test offset
+    REAL, DIMENSION(:), ALLOCATABLE :: genes
+  END TYPE
+  CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
+  allocate (indv(2), source = [individual(1, [99,999]), &
+                               individual(2, [999,9999])])
+  CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
+CONTAINS
+  SUBROUTINE display_indv(self)
+    CLASS(individual),  INTENT(IN) :: self
+    if (any(self%genes .ne. [999,9999]) )call abort
+  END SUBROUTINE
+END
+
+subroutine pr54990
+  implicit none
+  type :: ncBhStd
+    integer :: i
+  end type
+  type, extends(ncBhStd) :: ncBhStde
+    integer :: i2(2)
+  end type
+  type :: tn
+    integer :: i ! Add an extra component to test offset
+    class (ncBhStd), allocatable, dimension(:) :: cBh
+  end type
+  integer :: i
+  type(tn), target :: a
+  allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
+  select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
+    type is (ncBhStd)
+      call abort
+    type is (ncBhStde)
+      if (q%i .ne. 198) call abort ! This tests that the component really gets the
+  end select                       ! language specific flag denoting a class type
+end
+
+subroutine pr54992  ! This test remains as the original.
+  use G_Nodes
+  implicit none
+  type (tn), target  :: b
+  class(ncBh), pointer :: bh
+  class(ncBh), allocatable, dimension(:) :: t
+  allocate(b%cBh(1),source=defaultBhC)
+  b%cBh(1)%hostNode => b
+! #1 this worked
+  if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
+  call Node_C_Bh_Move(b)
+! #2 this worked
+  if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
+  if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
+! #3 this did not
+  bh => bhGet(b,instance=1)
+  if (loc (b) .ne. loc(bh%hostNode)) call abort
+  bh => bhGet(b,instance=2)
+  if (loc (b) .ne. loc(bh%hostNode)) call abort
+end