re PR fortran/41587 ([OOP] ICE with ALLOCATABLE CLASS components)

2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/41587
	PR fortran/46356
	PR fortran/51754
	PR fortran/50981
	* class.c (insert_component_ref, class_data_ref_missing,
	gfc_fix_class_refs): New functions.
	* gfortran.h (gfc_fix_class_refs): New prototype.
	* trans-expr.c (gfc_conv_expr): Remove special case handling and call
	gfc_fix_class_refs instead.

2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/41587
	* gfortran.dg/class_array_10.f03: New test.

	PR fortran/46356
	* gfortran.dg/class_array_11.f03: New test.

	PR fortran/51754
	* gfortran.dg/class_array_12.f03: New test.

From-SVN: r183853

8 files changed, 224 insertions, 6 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 459e4e4..db369ab 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/41587
+	PR fortran/46356
+	PR fortran/51754
+	PR fortran/50981
+	* class.c (insert_component_ref, class_data_ref_missing,
+	gfc_fix_class_refs): New functions.
+	* gfortran.h (gfc_fix_class_refs): New prototype.
+	* trans-expr.c (gfc_conv_expr): Remove special case handling and call
+	gfc_fix_class_refs instead.
+
 2012-02-02  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/52012
@@ -22,7 +34,7 @@
 	(mio_typebound_proc): Read/write is_operator from/to the
 	.mod file.
 
-2012-02-01  Tobias Burnus
+2012-02-01  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/52059
 	* trans-expr.c (gfc_conv_procedure_call): Add array ref
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 0d47979..bfa8740 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -52,6 +52,129 @@ along with GCC; see the file COPYING3.  If not see
 #include "constructor.h"
 
 
+/* Inserts a derived type component reference in a data reference chain.
+    TS: base type of the ref chain so far, in which we will pick the component
+    REF: the address of the GFC_REF pointer to update
+    NAME: name of the component to insert
+   Note that component insertion makes sense only if we are at the end of
+   the chain (*REF == NULL) or if we are adding a missing "_data" component
+   to access the actual contents of a class object.  */
+
+static void
+insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
+{
+  gfc_symbol *type_sym;
+  gfc_ref *new_ref;
+
+  gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
+  type_sym = ts->u.derived;
+
+  new_ref = gfc_get_ref ();
+  new_ref->type = REF_COMPONENT;
+  new_ref->next = *ref;
+  new_ref->u.c.sym = type_sym;
+  new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
+  gcc_assert (new_ref->u.c.component);
+
+  if (new_ref->next)
+    {
+      gfc_ref *next = NULL;
+
+      /* We need to update the base type in the trailing reference chain to
+	 that of the new component.  */
+
+      gcc_assert (strcmp (name, "_data") == 0);
+
+      if (new_ref->next->type == REF_COMPONENT)
+	next = new_ref->next;
+      else if (new_ref->next->type == REF_ARRAY
+	       && new_ref->next->next
+	       && new_ref->next->next->type == REF_COMPONENT)
+	next = new_ref->next->next;
+
+      if (next != NULL)
+	{
+	  gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
+		      || new_ref->u.c.component->ts.type == BT_DERIVED);
+	  next->u.c.sym = new_ref->u.c.component->ts.u.derived;
+	}
+    }
+
+  *ref = new_ref;
+}
+
+
+/* Tells whether we need to add a "_data" reference to access REF subobject
+   from an object of type TS.  If FIRST_REF_IN_CHAIN is set, then the base
+   object accessed by REF is a variable; in other words it is a full object,
+   not a subobject.  */
+
+static bool
+class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
+{
+  /* Only class containers may need the "_data" reference.  */
+  if (ts->type != BT_CLASS)
+    return false;
+
+  /* Accessing a class container with an array reference is certainly wrong.  */
+  if (ref->type != REF_COMPONENT)
+    return true;
+
+  /* Accessing the class container's fields is fine.  */
+  if (ref->u.c.component->name[0] == '_')
+    return false;
+
+  /* At this point we have a class container with a non class container's field
+     component reference.  We don't want to add the "_data" component if we are
+     at the first reference and the symbol's type is an extended derived type.
+     In that case, conv_parent_component_references will do the right thing so
+     it is not absolutely necessary.  Omitting it prevents a regression (see
+     class_41.f03) in the interface mapping mechanism.  When evaluating string
+     lengths depending on dummy arguments, we create a fake symbol with a type
+     equal to that of the dummy type.  However, because of type extension,
+     the backend type (corresponding to the actual argument) can have a
+     different (extended) type.  Adding the "_data" component explicitly, using
+     the base type, confuses the gfc_conv_component_ref code which deals with
+     the extended type.  */
+  if (first_ref_in_chain && ts->u.derived->attr.extension)
+    return false;
+
+  /* We have a class container with a non class container's field component
+     reference that doesn't fall into the above.  */
+  return true;
+}
+
+
+/* Browse through a data reference chain and add the missing "_data" references
+   when a subobject of a class object is accessed without it.
+   Note that it doesn't add the "_data" reference when the class container
+   is the last element in the reference chain.  */
+
+void
+gfc_fix_class_refs (gfc_expr *e)
+{
+  gfc_typespec *ts;
+  gfc_ref **ref;
+
+  if ((e->expr_type != EXPR_VARIABLE
+       && e->expr_type != EXPR_FUNCTION)
+      || (e->expr_type == EXPR_FUNCTION
+	  && e->value.function.isym != NULL))
+    return;
+
+  ts = &e->symtree->n.sym->ts;
+
+  for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
+    {
+      if (class_data_ref_missing (ts, *ref, ref == &e->ref))
+	insert_component_ref (ts, ref, "_data");
+
+      if ((*ref)->type == REF_COMPONENT)
+	ts = &(*ref)->u.c.component->ts;
+    }
+}
+
+
 /* Insert a reference to the component of the given name.
    Only to be used with CLASS containers and vtables.  */
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 757a4e5..a5edd13 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2919,6 +2919,7 @@ gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
 				      size_t*, size_t*, size_t*);
 
 /* class.c */
+void gfc_fix_class_refs (gfc_expr *e);
 void gfc_add_component_ref (gfc_expr *, const char *);
 void gfc_add_class_array_ref (gfc_expr *);
 #define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b0fc79c..608e85f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5486,10 +5486,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
         }
     }
 
-  /* TODO: make this work for general class array expressions.  */
-  if (expr->ts.type == BT_CLASS
-	&& expr->ref && expr->ref->type == REF_ARRAY)
-    gfc_add_component_ref (expr, "_data");
+  gfc_fix_class_refs (expr);
 
   switch (expr->expr_type)
     {
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0254804..e47725a 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2012-02-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/41587
+	* gfortran.dg/class_array_10.f03: New test.
+
+	PR fortran/46356
+	* gfortran.dg/class_array_11.f03: New test.
+
+	PR fortran/51754
+	* gfortran.dg/class_array_12.f03: New test.
+
 2012-02-02  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/52012
@@ -42,7 +53,7 @@
 	PR fortran/52024
 	* gfortran.dg/typebound_operator_14.f90: New.
 
-2012-02-01  Tobias Burnus
+2012-02-01  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/52059
 	* gfortran.dg/elemental_function_1.f90: New.
diff --git a/gcc/testsuite/gfortran.dg/class_array_10.f03 b/gcc/testsuite/gfortran.dg/class_array_10.f03
new file mode 100644
index 0000000..8ca8e0b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_10.f03
@@ -0,0 +1,18 @@
+! { dg-do compile}
+!
+! PR fortran/41587
+! This program was leading to an ICE related to class allocatable arrays
+!
+! Contributed by Dominique D'Humieres <dominiq@lps.ens.fr>
+
+type t0
+  integer :: j = 42
+end type t0
+type t
+  integer :: i
+  class(t0), allocatable :: foo(:)
+end type t
+type(t) :: k
+allocate(t0 :: k%foo(3))
+print *, k%foo%j
+end
diff --git a/gcc/testsuite/gfortran.dg/class_array_11.f03 b/gcc/testsuite/gfortran.dg/class_array_11.f03
new file mode 100644
index 0000000..6e1bdb0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_11.f03
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! PR fortran/46356
+! This program was leading to an ICE related to class arrays
+!
+! Original testcase by Ian Harvey <ian_harvey@bigpond.com>
+! Reduced by Janus Weil <Janus@gcc.gnu.org>
+
+  IMPLICIT NONE
+
+  TYPE :: ParentVector
+    INTEGER :: a
+  END TYPE ParentVector  
+
+CONTAINS       
+
+  SUBROUTINE vector_operation(pvec)     
+    CLASS(ParentVector), INTENT(INOUT) :: pvec(:)
+    print *,pvec(1)%a
+  END SUBROUTINE
+
+END
+
diff --git a/gcc/testsuite/gfortran.dg/class_array_12.f03 b/gcc/testsuite/gfortran.dg/class_array_12.f03
new file mode 100644
index 0000000..2a1e440
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_12.f03
@@ -0,0 +1,33 @@
+! { dg-do compile }
+!
+! PR fortran/51754
+! This program was leading to an ICE related to class arrays
+!
+! Contributed by Andrew Benson <abenson@caltech.edu>
+
+module test
+  private
+
+  type :: componentB
+  end type componentB
+
+  type :: treeNode
+     class(componentB), allocatable, dimension(:) :: componentB
+  end type treeNode
+
+contains
+
+  function BGet(self)
+    implicit none
+    class(componentB), pointer :: BGet
+    class(treeNode), target, intent(in) :: self
+    select type (self)
+    class is (treeNode)
+       BGet => self%componentB(1)
+    end select
+    return
+  end function BGet
+
+end module test
+
+! { dg-final { cleanup-modules "test" } }