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, 35 insertions, 7 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e15d6e1..e5a49bc 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4904,14 +4904,19 @@ resolve_ref (gfc_expr *expr)
 	    {
 	      /* F03:C614.  */
 	      if (ref->u.c.component->attr.pointer
-		  || ref->u.c.component->attr.proc_pointer)
+		  || ref->u.c.component->attr.proc_pointer
+		  || (ref->u.c.component->ts.type == BT_CLASS
+			&& CLASS_DATA (ref->u.c.component)->attr.pointer))
 		{
 		  gfc_error ("Component to the right of a part reference "
 			     "with nonzero rank must not have the POINTER "
 			     "attribute at %L", &expr->where);
 		  return FAILURE;
 		}
-	      else if (ref->u.c.component->attr.allocatable)
+	      else if (ref->u.c.component->attr.allocatable
+			|| (ref->u.c.component->ts.type == BT_CLASS
+			    && CLASS_DATA (ref->u.c.component)->attr.allocatable))
+
 		{
 		  gfc_error ("Component to the right of a part reference "
 			     "with nonzero rank must not have the ALLOCATABLE "
@@ -5081,9 +5086,15 @@ resolve_variable (gfc_expr *e)
     }
 
   /* If this is an associate-name, it may be parsed with an array reference
-     in error even though the target is scalar.  Fail directly in this case.  */
-  if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
-    return FAILURE;
+     in error even though the target is scalar.  Fail directly in this case.
+     TODO Understand why class scalar expressions must be excluded.  */
+  if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
+    {
+      if (sym->ts.type == BT_CLASS)
+	gfc_fix_class_refs (e);
+      if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
+	return FAILURE;
+    }
 
   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
     sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
@@ -7941,7 +7952,7 @@ gfc_type_is_extensible (gfc_symbol *sym)
 }
 
 
-/* Resolve an associate name:  Resolve target and ensure the type-spec is
+/* Resolve an associate-name:  Resolve target and ensure the type-spec is
    correct as well as possibly the array-spec.  */
 
 static void
@@ -7997,8 +8008,25 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->attr.dimension = 0;
       return;
     }
-  if (target->rank > 0)
+
+  /* We cannot deal with class selectors that need temporaries.  */
+  if (target->ts.type == BT_CLASS
+	&& gfc_ref_needs_temporary_p (target->ref))
+    {
+      gfc_error ("CLASS selector at %L needs a temporary which is not "
+		 "yet implemented", &target->where);
+      return;
+    }
+
+  if (target->ts.type != BT_CLASS && target->rank > 0)
     sym->attr.dimension = 1;
+  else if (target->ts.type == BT_CLASS)
+    gfc_fix_class_refs (target);
+
+  /* The associate-name will have a correct type by now. Make absolutely
+     sure that it has not picked up a dimension attribute.  */
+  if (sym->ts.type == BT_CLASS)
+    sym->attr.dimension = 0;
 
   if (sym->attr.dimension)
     {