re PR fortran/41600 ([OOP] SELECT TYPE with associate-name => exp: Arrays not supported)

2012-05-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* trans-array.c (build_array_ref): New static function.
	(gfc_conv_array_ref, gfc_get_dataptr_offset): Call it.
	* trans-expr.c (gfc_get_vptr_from_expr): New function.
	(gfc_conv_derived_to_class): Add a new argument for a caller
	supplied vptr and use it if it is not NULL.
	(gfc_conv_procedure_call): Add NULL to call to above.
	symbol.c (gfc_is_associate_pointer): Return true if symbol is
	a class object.
	* trans-stmt.c (trans_associate_var): Handle class associate-
	names.
	* expr.c (gfc_get_variable_expr): Supply the array-spec if
	possible.
	* trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P
	for class types.
	* trans.h : Add prototypes for gfc_get_vptr_from_expr and
	gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P.
	* resolve.c (resolve_variable): For class arrays, ensure that
	the target expression has all the necessary _data references.
	(resolve_assoc_var): Throw a "not yet implemented" error for
	class array selectors that need a temporary.
	* match.c (copy_ts_from_selector_to_associate,
	select_derived_set_tmp, select_class_set_tmp): New functions.
	(select_type_set_tmp): Call one of last two new functions.
	(gfc_match_select_type): Copy_ts_from_selector_to_associate is
	called if associate-name is typed.

	PR fortran/53191
	* resolve.c (resolve_ref): C614 applied to class expressions.


2012-05-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41600
	* gfortran.dg/select_type_26.f03 : New test.
	* gfortran.dg/select_type_27.f03 : New test.

	PR fortran/53191
	* gfortran.dg/select_type_28.f03 : New test.

From-SVN: r187192

1 files changed, 155 insertions, 40 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 15edfc3..3d11918 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5112,6 +5112,78 @@ gfc_match_select (void)
 }
 
 
+/* Transfer the selector typespec to the associate name.  */
+
+static void
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+{
+  gfc_ref *ref;
+  gfc_symbol *assoc_sym;
+
+  assoc_sym = associate->symtree->n.sym;
+
+  /* Ensure that any array reference is resolved.  */
+  gfc_resolve_expr (selector);
+
+  /* At this stage the expression rank and arrayspec dimensions have
+     not been completely sorted out. We must get the expr2->rank
+     right here, so that the correct class container is obtained.  */
+  ref = selector->ref;
+  while (ref && ref->next)
+    ref = ref->next;
+
+  if (selector->ts.type == BT_CLASS
+	&& CLASS_DATA (selector)->as
+	&& ref && ref->type == REF_ARRAY)
+    {
+      if (ref->u.ar.type == AR_FULL)
+	selector->rank = CLASS_DATA (selector)->as->rank;
+      else if (ref->u.ar.type == AR_SECTION)
+	selector->rank = ref->u.ar.dimen;
+      else
+	selector->rank = 0;
+    }
+
+  if (selector->ts.type != BT_CLASS)
+    {
+      /* The correct class container has to be available.  */
+      if (selector->rank)
+	{
+	  assoc_sym->attr.dimension = 1;
+	  assoc_sym->as = gfc_get_array_spec ();
+	  assoc_sym->as->rank = selector->rank;
+	  assoc_sym->as->type = AS_DEFERRED;
+	}
+      else
+	assoc_sym->as = NULL;
+
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->ts.u.derived = selector->ts.u.derived;
+      assoc_sym->attr.pointer = 1;
+      gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+			      &assoc_sym->as, false);
+    }
+  else
+    {
+      /* The correct class container has to be available.  */
+      if (selector->rank)
+	{
+	  assoc_sym->attr.dimension = 1;
+	  assoc_sym->as = gfc_get_array_spec ();
+	  assoc_sym->as->rank = selector->rank;
+	  assoc_sym->as->type = AS_DEFERRED;
+	}
+      else
+	assoc_sym->as = NULL;
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+      assoc_sym->attr.pointer = 1;
+      gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
+			      &assoc_sym->as, false);
+    }
+}
+
+
 /* Push the current selector onto the SELECT TYPE stack.  */
 
 static void
@@ -5126,64 +5198,103 @@ select_type_push (gfc_symbol *sel)
 }
 
 
-/* Set the temporary for the current SELECT TYPE selector.  */
+/* Set the temporary for the current derived type SELECT TYPE selector.  */
 
-static void
-select_type_set_tmp (gfc_typespec *ts)
+static gfc_symtree *
+select_derived_set_tmp (gfc_typespec *ts)
 {
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_symtree *tmp;
   
-  if (!ts)
+  sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+  gfc_add_type (tmp->n.sym, ts, NULL);
+
+  /* Copy across the array spec to the selector.  */
+  if (select_type_stack->selector->ts.type == BT_CLASS
+      && select_type_stack->selector->attr.class_ok
+      && (CLASS_DATA (select_type_stack->selector)->attr.dimension
+	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
     {
-      select_type_stack->tmp = NULL;
-      return;
+      tmp->n.sym->attr.dimension
+		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
+      tmp->n.sym->attr.codimension
+		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
+      tmp->n.sym->as
+	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
     }
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  tmp->n.sym->attr.select_type_temporary = 1;
+
+  return tmp;
+}
+
+
+/* Set the temporary for the current class SELECT TYPE selector.  */
+
+static gfc_symtree *
+select_class_set_tmp (gfc_typespec *ts)
+{
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp;
   
-  if (!gfc_type_is_extensible (ts->u.derived))
-    return;
+  if (select_type_stack->selector->ts.type == BT_CLASS
+      && !select_type_stack->selector->attr.class_ok)
+    return NULL;
 
-  if (ts->type == BT_CLASS)
-    sprintf (name, "__tmp_class_%s", ts->u.derived->name);
-  else
-    sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+  sprintf (name, "__tmp_class_%s", ts->u.derived->name);
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
 
-/* Copy across the array spec to the selector, taking care as to
-   whether or not it is a class object or not.  */
+/* Copy across the array spec to the selector.  */
   if (select_type_stack->selector->ts.type == BT_CLASS
-      && select_type_stack->selector->attr.class_ok
       && (CLASS_DATA (select_type_stack->selector)->attr.dimension
 	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
     {
-      if (ts->type == BT_CLASS)
-	{
-	  CLASS_DATA (tmp->n.sym)->attr.dimension
+      tmp->n.sym->attr.pointer = 1;
+      tmp->n.sym->attr.dimension
 		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
-	  CLASS_DATA (tmp->n.sym)->attr.codimension
+      tmp->n.sym->attr.codimension
 		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
-	  CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
-	  CLASS_DATA (tmp->n.sym)->as
-			= CLASS_DATA (select_type_stack->selector)->as;
-	}
-      else
-	{
-	  tmp->n.sym->attr.dimension
-		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
-	  tmp->n.sym->attr.codimension
-		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
-	  tmp->n.sym->as = gfc_get_array_spec ();
-	  tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
-	}
+      tmp->n.sym->as
+	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
     }
 
   gfc_set_sym_referenced (tmp->n.sym);
   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
   tmp->n.sym->attr.select_type_temporary = 1;
+  gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+			  &tmp->n.sym->as, false);
+
+  return tmp;
+}
+
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+  gfc_symtree *tmp;
+
+  if (!ts)
+    {
+      select_type_stack->tmp = NULL;
+      return;
+    }
+  
+  if (!gfc_type_is_extensible (ts->u.derived))
+    return;
+
+  /* Logic is a LOT clearer with separate functions for class and derived
+     type temporaries! There are not many more lines of code either.  */
   if (ts->type == BT_CLASS)
-    gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
-			    &tmp->n.sym->as, false);
+    tmp = select_class_set_tmp (ts);
+  else
+    tmp = select_derived_set_tmp (ts);
+
+  if (tmp == NULL)
+    return;
 
   /* Add an association for it, so the rest of the parser knows it is
      an associate-name.  The target will be set during resolution.  */
@@ -5194,7 +5305,7 @@ select_type_set_tmp (gfc_typespec *ts)
   select_type_stack->tmp = tmp;
 }
 
-
+  
 /* Match a SELECT TYPE statement.  */
 
 match
@@ -5204,6 +5315,7 @@ gfc_match_select_type (void)
   match m;
   char name[GFC_MAX_SYMBOL_LEN];
   bool class_array;
+  gfc_symbol *sym;
 
   m = gfc_match_label ();
   if (m == MATCH_ERROR)
@@ -5225,13 +5337,16 @@ gfc_match_select_type (void)
 	  m = MATCH_ERROR;
 	  goto cleanup;
 	}
+
+      sym = expr1->symtree->n.sym;
       if (expr2->ts.type == BT_UNKNOWN)
-	expr1->symtree->n.sym->attr.untyped = 1;
+	sym->attr.untyped = 1;
       else
-	expr1->symtree->n.sym->ts = expr2->ts;
-      expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
-      expr1->symtree->n.sym->attr.referenced = 1;
-      expr1->symtree->n.sym->attr.class_ok = 1;
+	copy_ts_from_selector_to_associate (expr1, expr2);
+
+      sym->attr.flavor = FL_VARIABLE;
+      sym->attr.referenced = 1;
+      sym->attr.class_ok = 1;
     }
   else
     {