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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@187192 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 346 insertions, 67 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a9b4195499d..a9f1cecc462 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,35 @@
+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  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR fortran/49010
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index d9614413e67..93d5df65455 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3821,6 +3821,9 @@ gfc_get_variable_expr (gfc_symtree *var)
       e->ref = gfc_get_ref ();
       e->ref->type = REF_ARRAY;
       e->ref->u.ar.type = AR_FULL;
+      e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
+					     ? CLASS_DATA (var->n.sym)->as
+					     : var->n.sym->as);
     }
 
   return e;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 15edfc36db1..3d119180a73 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
     {
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e15d6e12d7d..e5a49bcd561 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)
     {
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 46e5f56feee..6ca4ca33014 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4882,6 +4882,9 @@ gfc_is_associate_pointer (gfc_symbol* sym)
   if (!sym->assoc)
     return false;
 
+  if (sym->ts.type == BT_CLASS)
+    return true;
+
   if (!sym->assoc->variable)
     return false;
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b54c95b4087..b24d1c323ed 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3068,6 +3068,36 @@ add_to_offset (tree *cst_offset, tree *offset, tree t)
     }
 }
 
+
+static tree
+build_array_ref (tree desc, tree offset, tree decl)
+{
+  tree tmp;
+
+  /* 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))))
+    {
+      tree 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);
+    }
+  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
@@ -3195,10 +3225,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
     offset = fold_build2_loc (input_location, PLUS_EXPR,
 			      gfc_array_index_type, offset, cst_offset);
 
-  /* Access the calculated element.  */
-  tmp = gfc_conv_array_data (se->expr);
-  tmp = build_fold_indirect_ref (tmp);
-  se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
+  se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
 }
 
 
@@ -6010,10 +6037,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 	return;
     }
 
-  tmp = gfc_conv_array_data (desc);
-  tmp = build_fold_indirect_ref_loc (input_location,
-				 tmp);
-  tmp = gfc_build_array_ref (tmp, offset, NULL);
+  tmp = build_array_ref (desc, offset, NULL);
 
   /* Offset the data pointer for pointer assignments from arrays with
      subreferences; e.g. my_integer => my_type(:)%integer_component.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7092bc2f153..8045b1f029b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -147,11 +147,25 @@ gfc_vtable_copy_get (tree decl)
 #undef VTABLE_COPY_FIELD
 
 
+/* Obtain the vptr of the last class reference in an expression.  */
+
+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;
+}
+ 
+
 /* Takes a derived type expression and returns the address of a temporary
-   class object of the 'declared' type.  */ 
-static void
+   class object of the 'declared' type.  If vptr is not NULL, this is
+   used for the temporary class object.  */ 
+void
 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
-			   gfc_typespec class_ts)
+			   gfc_typespec class_ts, tree vptr)
 {
   gfc_symbol *vtab;
   gfc_ss *ss;
@@ -167,11 +181,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
   /* Set the vptr.  */
   ctree =  gfc_class_vptr_get (var);
 
-  /* Remember the vtab corresponds to the derived type
-     not to the class declared type.  */
-  vtab = gfc_find_derived_vtab (e->ts.u.derived);
-  gcc_assert (vtab);
-  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  if (vptr != NULL_TREE)
+    {
+      /* Use the dynamic vptr.  */
+      tmp = vptr;
+    }
+  else
+    {
+      /* In this case the vtab corresponds to the derived type and the
+	 vptr must point to it.  */
+      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      gcc_assert (vtab);
+      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+    }
   gfc_add_modify (&parmse->pre, ctree,
 		  fold_convert (TREE_TYPE (ctree), tmp));
 
@@ -3531,7 +3553,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
 	  gfc_init_se (&parmse, se);
-	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
 	}
       else if (se->ss && se->ss->info->useflags)
 	{
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 12a1390e2aa..323fca382c3 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1140,6 +1140,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   gfc_expr *e;
   tree tmp;
   bool class_target;
+  tree desc;
+  tree offset;
+  tree dim;
+  int n;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1191,8 +1195,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 			    gfc_finish_block (&se.post));
     }
 
-  /* CLASS arrays just need the descriptor to be directly assigned.  */
-  else if (class_target && sym->attr.dimension)
+  /* Derived type temporaries, arising from TYPE IS, just need the
+     descriptor of class arrays to be assigned directly.  */
+  else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension)
     {
       gfc_se se;
 
@@ -1217,7 +1222,47 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gcc_assert (!sym->attr.dimension);
 
       gfc_init_se (&se, NULL);
-      gfc_conv_expr (&se, e);
+
+      /* Class associate-names come this way because they are
+	 unconditionally associate pointers and the symbol is scalar.  */
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+	{
+	  /* For a class array we need a descriptor for the selector.  */
+	  gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e));
+
+	  /* Obtain a temporary class container for the result.  */ 
+	  gfc_conv_class_to_class (&se, e, sym->ts, false);
+	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  /* Set the offset.  */
+	  desc = gfc_class_data_get (se.expr);
+	  offset = gfc_index_zero_node;
+	  for (n = 0; n < e->rank; n++)
+	    {
+	      dim = gfc_rank_cst[n];
+	      tmp = fold_build2_loc (input_location, MULT_EXPR,
+				     gfc_array_index_type,
+				     gfc_conv_descriptor_stride_get (desc, dim),
+				     gfc_conv_descriptor_lbound_get (desc, dim));
+	      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				        gfc_array_index_type,
+				        offset, tmp);
+	    }
+	  gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
+	}
+      else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
+	       && CLASS_DATA (e)->attr.dimension)
+	{
+	  /* This is bound to be a class array element.  */
+	  gfc_conv_expr_reference (&se, e);
+	  /* Get the _vptr component of the class object.  */ 
+	  tmp = gfc_get_vptr_from_expr (se.expr);
+	  /* Obtain a temporary class container for the result.  */
+	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
+	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+	}
+      else
+	gfc_conv_expr (&se, e);
 
       tmp = TREE_TYPE (sym->backend_decl);
       tmp = gfc_build_addr_expr (tmp, se.expr);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 0f2912de1af..21a94fd6f06 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1106,6 +1106,9 @@ gfc_typenode_for_spec (gfc_typespec * spec)
     case BT_CLASS:
       basetype = gfc_get_derived_type (spec->u.derived);
 
+      if (spec->type == BT_CLASS)
+	GFC_CLASS_TYPE_P (basetype) = 1;
+
       /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
          type and kind to fit a (void *) and the basetype returned was a
          ptr_type_node.  We need to pass up this new information to the
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 08a67325274..3b77281568a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -348,8 +348,10 @@ tree gfc_vtable_size_get (tree);
 tree gfc_vtable_extends_get (tree);
 tree gfc_vtable_def_init_get (tree);
 tree gfc_vtable_copy_get (tree);
+tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
 
 /* Initialize an init/cleanup block.  */
@@ -827,6 +829,8 @@ struct GTY((variable_size)) lang_decl {
 #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
 /* Fortran POINTER type.  */
 #define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
+/* Fortran CLASS type.  */
+#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
 /* The GFC_TYPE_ARRAY_* members are present in both descriptor and
    descriptorless array types.  */
 #define GFC_TYPE_ARRAY_LBOUND(node, dim) \