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-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>
@@ -124,7 +124,7 @@ int gfc_atomic_logical_kind;
 
 /* The kind size used for record offsets. If the target system supports
    kind=8, this will be set to 8, otherwise it is set to 4.  */
-int gfc_intio_kind; 
+int gfc_intio_kind;
 
 /* The integer kind used to store character lengths.  */
 int gfc_charlen_int_kind;
@@ -138,7 +138,7 @@ gfc_try
 gfc_check_any_c_kind (gfc_typespec *ts)
 {
   int i;
-  
+
   for (i = 0; i < ISOCBINDING_NUMBER; i++)
     {
       /* Check for any C interoperable kind for the given type/kind in ts.
@@ -400,7 +400,7 @@ gfc_init_kinds (void)
       i_index += 1;
     }
 
-  /* Set the kind used to match GFC_INT_IO in libgfortran.  This is 
+  /* Set the kind used to match GFC_INT_IO in libgfortran.  This is
      used for large file access.  */
 
   if (saw_i8)
@@ -408,8 +408,8 @@ gfc_init_kinds (void)
   else
     gfc_intio_kind = 4;
 
-  /* If we do not at least have kind = 4, everything is pointless.  */  
-  gcc_assert(saw_i4);  
+  /* If we do not at least have kind = 4, everything is pointless.  */
+  gcc_assert(saw_i4);
 
   /* Set the maximum integer kind.  Used with at least BOZ constants.  */
   gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
@@ -550,7 +550,7 @@ gfc_init_kinds (void)
   else
     gfc_default_real_kind = gfc_real_kinds[0].kind;
 
-  /* Choose the default double kind.  If -fdefault-real and -fdefault-double 
+  /* Choose the default double kind.  If -fdefault-real and -fdefault-double
      are specified, we use kind=8, if it's available.  If -fdefault-real is
      specified without -fdefault-double, we use kind=16, if it's available.
      Otherwise we do not change anything.  */
@@ -1624,10 +1624,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
 	  type = build_pointer_type (type);
 
 	  if (restricted)
-	    type = build_qualified_type (type, TYPE_QUAL_RESTRICT);	
+	    type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
 
 	  GFC_ARRAY_TYPE_P (type) = 1;
-	  TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); 
+	  TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
 	}
 
       return type;
@@ -2286,7 +2286,7 @@ gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
      a derived type, we need a copy of its component declarations.
      This is done by recursing into gfc_get_derived_type and
      ensures that the component's component declarations have
-     been built.  If it is a character, we need the character 
+     been built.  If it is a character, we need the character
      length, as well.  */
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
@@ -2367,7 +2367,7 @@ gfc_get_derived_type (gfc_symbol * derived)
          BT_INTEGER that needs to fit a void * for the purpose of the
          iso_c_binding derived types.  */
       derived->ts.f90_type = BT_VOID;
-      
+
       return derived->backend_decl;
     }
 
@@ -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);
@@ -2832,7 +2841,7 @@ gfc_get_function_type (gfc_symbol * sym)
 	   && sym->ts.kind == gfc_default_real_kind
 	   && !sym->attr.always_explicit)
     {
-      /* Special case: f2c calling conventions require that (scalar) 
+      /* Special case: f2c calling conventions require that (scalar)
 	 default REAL functions return the C type double instead.  f2c
 	 compatibility is only an issue with functions that don't
 	 require an explicit interface, as only these could be

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