re PR fortran/41539 ([OOP] Calling function which takes CLASS: Rank comparison does not work)

2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
	Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/41539
	PR fortran/43214
	PR fortran/43969
	PR fortran/44568
	PR fortran/46356
	PR fortran/46990
	PR fortran/49074
	* interface.c(symbol_rank): Return the rank of the _data
	component of class objects.
	(compare_parameter): Also compare the derived type of the class
	_data component for type mismatch.  Similarly, return 1 if the
	formal and _data ranks match.
	(compare_actual_formal): Do not compare storage sizes for class
	expressions. It is an error if an actual class array, passed to
	a formal class array is not full.
	* trans-expr.c (gfc_class_data_get, gfc_class_vptr_get,
	gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get,
	gfc_vtable_extends_get, gfc_vtable_def_init_get,
	gfc_vtable_copy_get): New functions for class API.
	(gfc_conv_derived_to_class): For an array reference in an
	elemental procedure call retain the ss to provide the
	scalarized array reference. Moved in file.
	(gfc_conv_class_to_class): New function.
        (gfc_conv_subref_array_arg): Use the type of the
	class _data component as a basetype.
	(gfc_conv_procedure_call): Ensure that class array expressions
	have both the _data reference and an array reference. Use 
	gfc_conv_class_to_class to handle class arrays for elemental
	functions in scalarized loops, class array elements and full
	class arrays. Use a call to gfc_conv_subref_array_arg in order
	that the copy-in/copy-out for passing class arrays to derived
	type arrays occurs correctly.
	(gfc_conv_expr): If it is missing, add the _data component
	between a class object or component and an array reference.
	(gfc_trans_class_array_init_assign): New function.
	(gfc_trans_class_init_assign): Call it for array expressions.
	* trans-array.c (gfc_add_loop_ss_code): Do not use a temp for
	class scalars since their size will depend on the dynamic type.
	(build_class_array_ref): New function.
	(gfc_conv_scalarized_array_ref): Call build_class_array_ref.
	(gfc_array_init_size): Add extra argument, expr3, that represents
	the SOURCE argument. If present,use this for the element size.
	(gfc_array_allocate): Also add argument expr3 and use it when
	calling gfc_array_init_size.
	(structure_alloc_comps): Enable class arrays.
	* class.c (gfc_add_component_ref): Carry over the derived type
	of the _data component.
	(gfc_add_class_array_ref): New function.
	(class_array_ref_detected): New static function.
	(gfc_is_class_array_ref): New function that calls previous.
	(gfc_is_class_scalar_expr): New function.
	(gfc_build_class_symbol): Throw not implemented error for
	assumed size class arrays.  Remove error that prevents
	CLASS arrays.
	(gfc_build_class_symbol): Prevent pointer/allocatable conflict.
	Also unset codimension.
	(gfc_find_derived_vtab): Make 'copy' elemental and set the
	intent of the arguments accordingly.: 
	* trans-array.h : Update prototype for gfc_array_allocate.
	* array.c (gfc_array_dimen_size): Return failure if class expr.
	(gfc_array_size): Likewise.
	* gfortran.h : New prototypes for gfc_add_class_array_ref,
	gfc_is_class_array_ref and gfc_is_class_scalar_expr.
	* trans-stmt.c (trans_associate_var): Exclude class targets
	from test. Move the allocation of the _vptr to an earlier time
	for class objects.
	(trans_associate_var): Assign the descriptor directly for class
	arrays.
	(gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments.
	Convert array element references into sections. Do not invoke
	gfc_conv_procedure_call, use gfc_trans_call instead.
	* expr.c (gfc_get_corank): Fix for BT_CLASS.
	(gfc_is_simply_contiguous): Exclude class from test.
	* trans.c (gfc_build_array_ref): Include class array refs.
	* trans.h : Include prototypes for class API functions that are
	new in trans-expr. Define GFC_DECL_CLASS(node).
	* resolve.c (check_typebound_baseobject ): Remove error for
	non-scalar base object.
	(resolve_allocate_expr): Ensure that class _data component is
	present. If array, call gfc_expr_to_intialize.
	(resolve_select): Remove scalar error for SELECT statement as a
	temporary measure.
	(resolve_assoc_var): Update 'target' (aka 'selector') as
	needed. Ensure that the target expression has the right rank.
	(resolve_select_type): Ensure that target expressions have a
	valid locus.
	(resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS.
	* trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where
	appropriate.
	(gfc_trans_deferred_vars): Get class arrays right.
	* match.c(select_type_set_tmp): Add array spec to temporary.
	(gfc_match_select_type): Allow class arrays.
	* check.c (array_check): Ensure that class arrays have refs.
	(dim_corank_check, dim_rank_check): Retrun success if class.
	* primary.c (gfc_match_varspec): Fix for class arrays and
	co-arrays. Make sure that class _data is present.
	(gfc_match_rvalue): Handle class arrays.
	*trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array
	reference.
	(gfc_conv_allocated): Add _data component to class expressions.
	(gfc_add_intrinsic_ss_code): ditto.
	* simplify.c (simplify_cobound): Fix for BT_CLASS.
	(simplify_bound): Return NULL for class arrays.
	(simplify_cobound): Obtain correct array_spec. Use cotype as
	appropriate. Use arrayspec for bounds.

2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
	Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/41539
	PR fortran/43214
	PR fortran/43969
	PR fortran/44568
	PR fortran/46356
	PR fortran/46990
	PR fortran/49074
	* gfortran.dg/class_array_1.f03: New.
	* gfortran.dg/class_array_2.f03: New.
	* gfortran.dg/class_array_3.f03: New.
	* gfortran.dg/class_array_4.f03: New.
	* gfortran.dg/class_array_5.f03: New.
	* gfortran.dg/class_array_6.f03: New.
	* gfortran.dg/class_array_7.f03: New.
	* gfortran.dg/class_array_8.f03: New.
	* gfortran.dg/coarray_poly_1.f90: New.
	* gfortran.dg/coarray_poly_2.f90: New.
	* gfortran.dg/coarray/poly_run_1.f90: New.
	* gfortran.dg/coarray/poly_run_2.f90: New.
	* gfortran.dg/class_to_type_1.f03: New.
	* gfortran.dg/type_to_class_1.f03: New.
	* gfortran.dg/typebound_assignment_3.f03: Remove the error.
	* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
	now 2.
	* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r182210

37 files changed, 1971 insertions, 218 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 49aacc8..c87daeb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,112 @@
+2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/41539
+	PR fortran/43214
+	PR fortran/43969
+	PR fortran/44568
+	PR fortran/46356
+	PR fortran/46990
+	PR fortran/49074
+	* interface.c(symbol_rank): Return the rank of the _data
+	component of class objects.
+	(compare_parameter): Also compare the derived type of the class
+	_data component for type mismatch.  Similarly, return 1 if the
+	formal and _data ranks match.
+	(compare_actual_formal): Do not compare storage sizes for class
+	expressions. It is an error if an actual class array, passed to
+	a formal class array is not full.
+	* trans-expr.c (gfc_class_data_get, gfc_class_vptr_get,
+	gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get,
+	gfc_vtable_extends_get, gfc_vtable_def_init_get,
+	gfc_vtable_copy_get): New functions for class API.
+	(gfc_conv_derived_to_class): For an array reference in an
+	elemental procedure call retain the ss to provide the
+	scalarized array reference. Moved in file.
+	(gfc_conv_class_to_class): New function.
+        (gfc_conv_subref_array_arg): Use the type of the
+	class _data component as a basetype.
+	(gfc_conv_procedure_call): Ensure that class array expressions
+	have both the _data reference and an array reference. Use 
+	gfc_conv_class_to_class to handle class arrays for elemental
+	functions in scalarized loops, class array elements and full
+	class arrays. Use a call to gfc_conv_subref_array_arg in order
+	that the copy-in/copy-out for passing class arrays to derived
+	type arrays occurs correctly.
+	(gfc_conv_expr): If it is missing, add the _data component
+	between a class object or component and an array reference.
+	(gfc_trans_class_array_init_assign): New function.
+	(gfc_trans_class_init_assign): Call it for array expressions.
+	* trans-array.c (gfc_add_loop_ss_code): Do not use a temp for
+	class scalars since their size will depend on the dynamic type.
+	(build_class_array_ref): New function.
+	(gfc_conv_scalarized_array_ref): Call build_class_array_ref.
+	(gfc_array_init_size): Add extra argument, expr3, that represents
+	the SOURCE argument. If present,use this for the element size.
+	(gfc_array_allocate): Also add argument expr3 and use it when
+	calling gfc_array_init_size.
+	(structure_alloc_comps): Enable class arrays.
+	* class.c (gfc_add_component_ref): Carry over the derived type
+	of the _data component.
+	(gfc_add_class_array_ref): New function.
+	(class_array_ref_detected): New static function.
+	(gfc_is_class_array_ref): New function that calls previous.
+	(gfc_is_class_scalar_expr): New function.
+	(gfc_build_class_symbol): Throw not implemented error for
+	assumed size class arrays.  Remove error that prevents
+	CLASS arrays.
+	(gfc_build_class_symbol): Prevent pointer/allocatable conflict.
+	Also unset codimension.
+	(gfc_find_derived_vtab): Make 'copy' elemental and set the
+	intent of the arguments accordingly.: 
+	* trans-array.h : Update prototype for gfc_array_allocate.
+	* array.c (gfc_array_dimen_size): Return failure if class expr.
+	(gfc_array_size): Likewise.
+	* gfortran.h : New prototypes for gfc_add_class_array_ref,
+	gfc_is_class_array_ref and gfc_is_class_scalar_expr.
+	* trans-stmt.c (trans_associate_var): Exclude class targets
+	from test. Move the allocation of the _vptr to an earlier time
+	for class objects.
+	(trans_associate_var): Assign the descriptor directly for class
+	arrays.
+	(gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments.
+	Convert array element references into sections. Do not invoke
+	gfc_conv_procedure_call, use gfc_trans_call instead.
+	* expr.c (gfc_get_corank): Fix for BT_CLASS.
+	(gfc_is_simply_contiguous): Exclude class from test.
+	* trans.c (gfc_build_array_ref): Include class array refs.
+	* trans.h : Include prototypes for class API functions that are
+	new in trans-expr. Define GFC_DECL_CLASS(node).
+	* resolve.c (check_typebound_baseobject ): Remove error for
+	non-scalar base object.
+	(resolve_allocate_expr): Ensure that class _data component is
+	present. If array, call gfc_expr_to_intialize.
+	(resolve_select): Remove scalar error for SELECT statement as a
+	temporary measure.
+	(resolve_assoc_var): Update 'target' (aka 'selector') as
+	needed. Ensure that the target expression has the right rank.
+	(resolve_select_type): Ensure that target expressions have a
+	valid locus.
+	(resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS.
+	* trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where
+	appropriate.
+	(gfc_trans_deferred_vars): Get class arrays right.
+	* match.c(select_type_set_tmp): Add array spec to temporary.
+	(gfc_match_select_type): Allow class arrays.
+	* check.c (array_check): Ensure that class arrays have refs.
+	(dim_corank_check, dim_rank_check): Retrun success if class.
+	* primary.c (gfc_match_varspec): Fix for class arrays and
+	co-arrays. Make sure that class _data is present.
+	(gfc_match_rvalue): Handle class arrays.
+	*trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array
+	reference.
+	(gfc_conv_allocated): Add _data component to class expressions.
+	(gfc_add_intrinsic_ss_code): ditto.
+	* simplify.c (simplify_cobound): Fix for BT_CLASS.
+	(simplify_bound): Return NULL for class arrays.
+	(simplify_cobound): Obtain correct array_spec. Use cotype as
+	appropriate. Use arrayspec for bounds.
+
 2011-12-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/50690
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index a1449fd..b36d517 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -2112,6 +2112,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
   gfc_ref *ref;
   int i;
 
+  if (array->ts.type == BT_CLASS)
+    return FAILURE;
+
   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
 
@@ -2190,6 +2193,9 @@ gfc_array_size (gfc_expr *array, mpz_t *result)
   int i;
   gfc_try t;
 
+  if (array->ts.type == BT_CLASS)
+    return FAILURE;
+
   switch (array->expr_type)
     {
     case EXPR_ARRAY:
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f2c4272..dca97cb 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -240,6 +240,14 @@ logical_array_check (gfc_expr *array, int n)
 static gfc_try
 array_check (gfc_expr *e, int n)
 {
+  if (e->ts.type == BT_CLASS
+	&& CLASS_DATA (e)->attr.dimension
+	&& CLASS_DATA (e)->as->rank)
+    {
+      gfc_add_class_array_ref (e);
+      return SUCCESS;
+    }
+
   if (e->rank != 0)
     return SUCCESS;
 
@@ -554,6 +562,9 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
 
   if (dim->expr_type != EXPR_CONSTANT)
     return SUCCESS;
+  
+  if (array->ts.type == BT_CLASS)
+    return SUCCESS;
 
   corank = gfc_get_corank (array);
 
@@ -587,6 +598,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
   if (dim->expr_type != EXPR_CONSTANT)
     return SUCCESS;
 
+  if (array->ts.type == BT_CLASS)
+    return SUCCESS;
+
   if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
       && array->value.function.isym->id == GFC_ISYM_SPREAD)
     rank = array->rank + 1;
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index d3f7bf3..37c653a 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -64,7 +64,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
   while (*tail != NULL)
     {
       if ((*tail)->type == REF_COMPONENT)
-	derived = (*tail)->u.c.component->ts.u.derived;
+	{
+	  if (strcmp ((*tail)->u.c.component->name, "_data") == 0
+		&& (*tail)->next
+		&& (*tail)->next->type == REF_ARRAY
+		&& (*tail)->next->next == NULL)
+	    return;
+	  derived = (*tail)->u.c.component->ts.u.derived;
+	}
       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
 	break;
       tail = &((*tail)->next);
@@ -82,6 +89,155 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
 }
 
 
+/* This is used to add both the _data component reference and an array
+   reference to class expressions.  Used in translation of intrinsic
+   array inquiry functions.  */
+
+void
+gfc_add_class_array_ref (gfc_expr *e)
+{
+  int rank =  CLASS_DATA (e)->as->rank;
+  gfc_array_spec *as = CLASS_DATA (e)->as;
+  gfc_ref *ref = NULL;
+  gfc_add_component_ref (e, "_data");
+  e->rank = rank;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (!ref->next)
+      break;
+  if (ref->type != REF_ARRAY)
+    {
+      ref->next = gfc_get_ref ();
+      ref = ref->next;
+      ref->type = REF_ARRAY;
+      ref->u.ar.type = AR_FULL;
+      ref->u.ar.as = as;	  
+    }
+}
+
+
+/* Unfortunately, class array expressions can appear in various conditions;
+   with and without both _data component and an arrayspec.  This function
+   deals with that variability.  The previous reference to 'ref' is to a
+   class array.  */
+
+static bool
+class_array_ref_detected (gfc_ref *ref, bool *full_array)
+{
+  bool no_data = false;
+  bool with_data = false;
+
+  /* An array reference with no _data component.  */
+  if (ref && ref->type == REF_ARRAY
+	&& !ref->next
+	&& ref->u.ar.type != AR_ELEMENT)
+    {
+      if (full_array)
+        *full_array = ref->u.ar.type == AR_FULL;
+      no_data = true;
+    }
+
+  /* Cover cases where _data appears, with or without an array ref.  */
+  if (ref && ref->type == REF_COMPONENT
+	&& strcmp (ref->u.c.component->name, "_data") == 0)
+    {
+      if (!ref->next)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = true;
+	}
+      else if (ref->next && ref->next->type == REF_ARRAY
+	    && !ref->next->next
+	    && ref->type == REF_COMPONENT
+	    && ref->next->type == REF_ARRAY
+	    && ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = ref->next->u.ar.type == AR_FULL;
+	}
+    }
+
+  return no_data || with_data;
+}
+
+
+/* Returns true if the expression contains a reference to a class
+   array.  Notice that class array elements return false.  */
+
+bool
+gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
+{
+  gfc_ref *ref;
+
+  if (!e->rank)
+    return false;
+
+  if (full_array)
+    *full_array= false;
+
+  /* Is this a class array object? ie. Is the symbol of type class?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& class_array_ref_detected (e->ref, full_array))
+    return true;
+
+  /* Or is this a class array component reference?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && class_array_ref_detected (ref->next, full_array))
+	return true;
+    }
+
+  return false;
+}
+
+
+/* Returns true if the expression is a reference to a class
+   scalar.  This function is necessary because such expressions
+   can be dressed with a reference to the _data component and so
+   have a type other than BT_CLASS.  */
+
+bool
+gfc_is_class_scalar_expr (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  if (e->rank)
+    return false;
+
+  /* Is this a class object?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& !CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& (e->ref == NULL
+	    || (strcmp (e->ref->u.c.component->name, "_data") == 0
+		&& e->ref->next == NULL)))
+    return true;
+
+  /* Or is the final reference BT_CLASS or _data?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)
+	    && !CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && (ref->next == NULL
+		|| (strcmp (ref->next->u.c.component->name, "_data") == 0
+		    && ref->next->next == NULL)))
+	return true;
+    }
+
+  return false;
+}
+
+
 /* Build a NULL initializer for CLASS pointers,
    initializing the _data component to NULL and
    the _vptr component to the declared type.  */
@@ -183,7 +339,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
-  
+
+  if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
+    {
+      gfc_error ("Assumed size polymorphic objects or components, such "
+		 "as that at %C, have not yet been implemented");
+      return FAILURE;
+    }
+
   if (attr->class_ok)
     /* Class container has already been built.  */
     return SUCCESS;
@@ -195,12 +358,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     /* We can not build the class container yet.  */
     return SUCCESS;
 
-  if (*as)
-    {
-      gfc_fatal_error ("Polymorphic array at %C not yet supported");
-      return FAILURE;
-    }
-
   /* Determine the name of the encapsulating type.  */
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && (*as)->rank && attr->allocatable)
@@ -277,8 +434,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   fclass->attr.extension = ts->u.derived->attr.extension + 1;
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
-  attr->allocatable = attr->pointer = attr->dimension = 0;
-  (*as) = NULL;  /* XXX */
+  attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
+  (*as) = NULL;
   return SUCCESS;
 }
 
@@ -402,7 +559,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
-  
+
   /* Find the top-level namespace (MODULE or PROGRAM).  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     if (!ns->parent)
@@ -556,6 +713,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  copy->attr.flavor = FL_PROCEDURE;
 		  copy->attr.subroutine = 1;
 		  copy->attr.if_source = IFSRC_DECL;
+		  /* This is elemental so that arrays are automatically
+		     treated correctly by the scalarizer.  */
+		  copy->attr.elemental = 1;
 		  if (ns->proc_name->attr.flavor == FL_MODULE)
 		    copy->module = ns->proc_name->name;
 		  gfc_set_sym_referenced (copy);
@@ -565,6 +725,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  src->ts.u.derived = derived;
 		  src->attr.flavor = FL_VARIABLE;
 		  src->attr.dummy = 1;
+		  src->attr.intent = INTENT_IN;
 		  gfc_set_sym_referenced (src);
 		  copy->formal = gfc_get_formal_arglist ();
 		  copy->formal->sym = src;
@@ -573,6 +734,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  dst->ts.u.derived = derived;
 		  dst->attr.flavor = FL_VARIABLE;
 		  dst->attr.dummy = 1;
+		  dst->attr.intent = INTENT_OUT;
 		  gfc_set_sym_referenced (dst);
 		  copy->formal->next = gfc_get_formal_arglist ();
 		  copy->formal->next->sym = dst;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f3c367c..d8ae04f 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4309,7 +4309,11 @@ gfc_get_corank (gfc_expr *e)
   if (!gfc_is_coarray (e))
     return 0;
 
-  corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+  if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
+    corank = e->ts.u.derived->components->as
+	     ? e->ts.u.derived->components->as->corank : 0;
+  else 
+    corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
 
   for (ref = e->ref; ref; ref = ref->next)
     {
@@ -4394,6 +4398,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
   int i;
   gfc_array_ref *ar = NULL;
   gfc_ref *ref, *part_ref = NULL;
+  gfc_symbol *sym;
 
   if (expr->expr_type == EXPR_FUNCTION)
     return expr->value.function.esym
@@ -4417,11 +4422,15 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
 	ar = &ref->u.ar;
     }
 
-  if ((part_ref && !part_ref->u.c.component->attr.contiguous
-       && part_ref->u.c.component->attr.pointer)
-      || (!part_ref && !expr->symtree->n.sym->attr.contiguous
-	  && (expr->symtree->n.sym->attr.pointer
-	      || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
+  sym = expr->symtree->n.sym;
+  if (expr->ts.type != BT_CLASS
+	&& ((part_ref
+		&& !part_ref->u.c.component->attr.contiguous
+		&& part_ref->u.c.component->attr.pointer)
+	    || (!part_ref
+		&& !sym->attr.contiguous
+		&& (sym->attr.pointer
+		      || sym->as->type == AS_ASSUMED_SHAPE))))
     return false;
 
   if (!ar || ar->type == AR_FULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 372c056..daa2896 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2911,11 +2911,14 @@ gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
 
 /* class.c */
 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")
 #define gfc_add_vptr_component(e)     gfc_add_component_ref(e,"_vptr")
 #define gfc_add_hash_component(e)     gfc_add_component_ref(e,"_hash")
 #define gfc_add_size_component(e)     gfc_add_component_ref(e,"_size")
 #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
+bool gfc_is_class_array_ref (gfc_expr *, bool *);
+bool gfc_is_class_scalar_expr (gfc_expr *);
 gfc_expr *gfc_class_null_initializer (gfc_typespec *);
 unsigned int gfc_hash_value (gfc_symbol *);
 gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6d2acce..e914c6c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1541,6 +1541,9 @@ done:
 static int
 symbol_rank (gfc_symbol *sym)
 {
+  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
+    return CLASS_DATA (sym)->as->rank;
+
   return (sym->as == NULL) ? 0 : sym->as->rank;
 }
 
@@ -1691,7 +1694,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && actual->ts.type != BT_HOLLERITH
-      && !gfc_compare_types (&formal->ts, &actual->ts))
+      && !gfc_compare_types (&formal->ts, &actual->ts)
+      && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
+	   && gfc_compare_derived_types (formal->ts.u.derived, 
+					 CLASS_DATA (actual)->ts.u.derived)))
     {
       if (where)
 	gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
@@ -1820,6 +1826,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (symbol_rank (formal) == actual->rank)
     return 1;
 
+  if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
+	&& CLASS_DATA (actual)->as->rank == symbol_rank (formal))
+    return 1;
+
   rank_check = where != NULL && !is_elemental && formal->as
 	       && (formal->as->type == AS_ASSUMED_SHAPE
 		   || formal->as->type == AS_DEFERRED)
@@ -1829,7 +1839,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (rank_check || ranks_must_agree
       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
-      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
+      || (actual->rank == 0
+	  && ((formal->ts.type == BT_CLASS
+	       && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
+	      || (formal->ts.type != BT_CLASS
+		   && formal->as->type == AS_ASSUMED_SHAPE))
 	  && actual->expr_type != EXPR_NULL)
       || (actual->rank == 0 && formal->attr.dimension
 	  && gfc_is_coindexed (actual)))
@@ -2158,6 +2172,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_formal_arglist *f;
   int i, n, na;
   unsigned long actual_size, formal_size;
+  bool full_array = false;
 
   actual = *ap;
 
@@ -2297,6 +2312,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
+      if (f->sym->ts.type == BT_CLASS)
+	goto skip_size_check;
+
       actual_size = get_expr_storage_size (a->expr);
       formal_size = get_sym_storage_size (f->sym);
       if (actual_size != 0 && actual_size < formal_size
@@ -2316,6 +2334,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return  0;
 	}
 
+     skip_size_check:
+
       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
 	 is provided for a procedure pointer formal argument.  */
       if (f->sym->attr.proc_pointer
@@ -2428,6 +2448,18 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
+     if (f->sym->ts.type == BT_CLASS
+	   && CLASS_DATA (f->sym)->attr.allocatable
+	   && gfc_is_class_array_ref (a->expr, &full_array)
+	   && !full_array)
+	{
+	  if (where)
+	    gfc_error ("Actual CLASS array argument for '%s' must be a full "
+		       "array at %L", f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_allocatable (f->sym, a->expr) == 0)
 	{
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3de9c72..0e12730 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5151,6 +5151,27 @@ select_type_set_tmp (gfc_typespec *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, taking care as to
+   whether or not it is a class object or not.  */
+  if (select_type_stack->selector->ts.type == BT_CLASS &&
+      CLASS_DATA (select_type_stack->selector)->attr.dimension)
+    {
+      if (ts->type == BT_CLASS)
+	{
+	  CLASS_DATA (tmp->n.sym)->attr.dimension = 1;
+	  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 = 1;
+	  tmp->n.sym->as = gfc_get_array_spec ();
+	  tmp->n.sym->as = 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;
@@ -5176,6 +5197,7 @@ gfc_match_select_type (void)
   gfc_expr *expr1, *expr2 = NULL;
   match m;
   char name[GFC_MAX_SYMBOL_LEN];
+  bool class_array;
 
   m = gfc_match_label ();
   if (m == MATCH_ERROR)
@@ -5216,8 +5238,24 @@ gfc_match_select_type (void)
   if (m != MATCH_YES)
     goto cleanup;
 
+  /* This ghastly expression seems to be needed to distinguish a CLASS
+     array, which can have a reference, from other expressions that
+     have references, such as derived type components, and are not
+     allowed by the standard.
+     TODO; see is it is sufficent to exclude component and substring
+     references.  */
+  class_array = expr1->expr_type == EXPR_VARIABLE
+		  && expr1->ts.type != BT_UNKNOWN
+		  && CLASS_DATA (expr1)
+		  && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
+		  && CLASS_DATA (expr1)->attr.dimension
+		  && expr1->ref
+		  && expr1->ref->type == REF_ARRAY
+		  && expr1->ref->next == NULL;
+
   /* Check for F03:C811.  */
-  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
+  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
+		  || (!class_array && expr1->ref != NULL)))
     {
       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
 		 "use associate-name=>");
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 0f67ec7..75c7e137 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1789,13 +1789,17 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
   if (gfc_peek_ascii_char () == '[')
     {
-      if (sym->attr.dimension)
+      if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+	      && CLASS_DATA (sym)->attr.dimension))
 	{
 	  gfc_error ("Array section designator, e.g. '(:)', is required "
 		     "besides the coarray designator '[...]' at %C");
 	  return MATCH_ERROR;
 	}
-      if (!sym->attr.codimension)
+      if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+	      && !CLASS_DATA (sym)->attr.codimension))
 	{
 	  gfc_error ("Coarray designator at %C but '%s' is not a coarray",
 		     sym->name);
@@ -1827,7 +1831,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
 			       equiv_flag,
-			       sym->ts.type == BT_CLASS
+			       sym->ts.type == BT_CLASS && CLASS_DATA (sym)
 			       ? (CLASS_DATA (sym)->as
 				  ? CLASS_DATA (sym)->as->corank : 0)
 			       : (sym->as ? sym->as->corank : 0));
@@ -2909,6 +2913,22 @@ gfc_match_rvalue (gfc_expr **result)
 	  break;
 	}
 
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+	{
+	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+			      sym->name, NULL) == FAILURE)
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
+
+	  e = gfc_get_expr ();
+	  e->symtree = symtree;
+	  e->expr_type = EXPR_VARIABLE;
+	  m = gfc_match_varspec (e, 0, false, true);
+	  break;
+	}
+
       /* Name is not an array, so we peek to see if a '(' implies a
 	 function call or a substring reference.  Otherwise the
 	 variable is just a scalar.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2e50f04..b4a9d1c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5584,14 +5584,6 @@ check_typebound_baseobject (gfc_expr* e)
       goto cleanup;
     }
 
-  /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS).  */
-  if (base->rank > 0)
-    {
-      gfc_error ("Non-scalar base object at %L currently not implemented",
-		 &e->where);
-      goto cleanup;
-    }
-
   return_value = SUCCESS;
 
 cleanup:
@@ -6765,7 +6757,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
     }
   else
     {
-      if (sym->ts.type == BT_CLASS)
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
 	{
 	  allocatable = CLASS_DATA (sym)->attr.allocatable;
 	  pointer = CLASS_DATA (sym)->attr.class_pointer;
@@ -6911,7 +6903,16 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   if (t == FAILURE)
     goto failure;
 
-  if (!code->expr3)
+  if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
+	&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
+    {
+      /* For class arrays, the initialization with SOURCE is done
+	 using _copy and trans_call. It is convenient to exploit that
+	 when the allocated type is different from the declared type but
+	 no SOURCE exists by setting expr3.  */
+      code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); 
+    }
+  else if (!code->expr3)
     {
       /* Set up default initializer if needed.  */
       gfc_typespec ts;
@@ -6955,6 +6956,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       else if (code->ext.alloc.ts.type == BT_DERIVED)
 	ts = code->ext.alloc.ts;
       gfc_find_derived_vtab (ts.u.derived);
+      if (dimension)
+	e = gfc_expr_to_initialize (e);
     }
 
   if (dimension == 0 && codimension == 0)
@@ -7531,16 +7534,6 @@ resolve_select (gfc_code *code)
       return;
     }
 
-  if (case_expr->rank != 0)
-    {
-      gfc_error ("Argument of SELECT statement at %L must be a scalar "
-		 "expression", &case_expr->where);
-
-      /* Punt.  */
-      return;
-    }
-
-
   /* Raise a warning if an INTEGER case value exceeds the range of
      the case-expr. Later, all expressions will be promoted to the
      largest kind of all case-labels.  */
@@ -7825,6 +7818,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->attr.volatile_ = tsym->attr.volatile_;
 
       sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+
+      if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS)
+	target->rank = sym->as ? sym->as->rank : 0;
     }
 
   /* Get type if this was not already set.  Note that it can be
@@ -7839,7 +7835,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 			  && !gfc_has_vector_subscript (target));
 
   /* Finally resolve if this is an array or not.  */
-  if (sym->attr.dimension && target->rank == 0)
+  if (sym->attr.dimension
+	&& (target->ts.type == BT_CLASS
+	      ? !CLASS_DATA (target)->attr.dimension
+	      : target->rank == 0))
     {
       gfc_error ("Associate-name '%s' at %L is used as array",
 		 sym->name, &sym->declared_at);
@@ -7955,6 +7954,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       assoc = gfc_get_association_list ();
       assoc->st = code->expr1->symtree;
       assoc->target = gfc_copy_expr (code->expr2);
+      assoc->target->where = code->expr2->where;
       /* assoc->variable will be set by resolve_assoc_var.  */
       
       code->ext.block.assoc = assoc;
@@ -8006,6 +8006,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       st = gfc_find_symtree (ns->sym_root, name);
       gcc_assert (st->n.sym->assoc);
       st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
+      st->n.sym->assoc->target->where = code->expr1->where;
       if (c->ts.type == BT_DERIVED)
 	gfc_add_data_component (st->n.sym->assoc->target);
 
@@ -11432,7 +11433,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
   for (c = sym->components; c != NULL; c = c->next)
     {
       /* F2008, C442.  */
-      if (c->attr.codimension /* FIXME: c->as check due to PR 43412.  */
+      if ((!sym->attr.is_class || c != sym->components)
+	  && c->attr.codimension
 	  && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
 	{
 	  gfc_error ("Coarray component '%s' at %L must be allocatable with "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4431826..e82753a 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3326,6 +3326,9 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
   gfc_array_spec *as;
   int d;
 
+  if (array->ts.type == BT_CLASS)
+    return NULL;
+
   if (array->expr_type != EXPR_VARIABLE)
     {
       as = NULL;
@@ -3462,7 +3465,9 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
     return NULL;
 
   /* Follow any component references.  */
-  as = array->symtree->n.sym->as;
+  as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
+       ? array->ts.u.derived->components->as
+       : array->symtree->n.sym->as;
   for (ref = array->ref; ref; ref = ref->next)
     {
       switch (ref->type)
@@ -3506,11 +3511,12 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	}
     }
 
-  gcc_unreachable ();
+  if (!as)
+    gcc_unreachable ();
 
  done:
 
-  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+  if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
     return NULL;
 
   if (dim == NULL)
@@ -3523,7 +3529,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
       /* Simplify the cobounds for each dimension.  */
       for (d = 0; d < as->corank; d++)
 	{
-	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
 					  upper, as, ref, true);
 	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
 	    {
@@ -3575,7 +3581,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  return &gfc_bad_expr;
 	}
 
-      return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
+      return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
     }
 }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8624d9..d441102 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2428,9 +2428,18 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  gfc_conv_expr (&se, expr);
 	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
 	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  if (gfc_is_class_scalar_expr (expr))
+	    /* This is necessary because the dynamic type will always be
+	       large than the declared type.  In consequence, assigning
+	       the value to a temporary could segfault.
+	       OOP-TODO: see if this is generally correct or is the value
+	       has to be written to an allocated temporary, whose address
+	       is passed via ss_info.  */
+	    ss_info->data.scalar.value = se.expr;
+	  else
+	    ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+							   &outer_loop->pre);
 
-	  ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
-							 &outer_loop->pre);
 	  ss_info->string_length = se.string_length;
 	  break;
 
@@ -2879,6 +2888,82 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
 }
 
 
+/* Build a scalarized array reference using the vptr 'size'.  */
+
+static bool
+build_class_array_ref (gfc_se *se, tree base, tree index)
+{
+  tree type;
+  tree size;
+  tree offset;
+  tree decl;
+  tree tmp;
+  gfc_expr *expr = se->ss->info->expr;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+  gfc_typespec *ts;
+
+  if (expr == NULL || expr->ts.type != BT_CLASS)
+    return false;
+
+  if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+    ts = &expr->symtree->n.sym->ts;
+  else
+    ts = NULL;
+  class_ref = NULL;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && ref->next && ref->next->type == REF_COMPONENT
+	    && strcmp (ref->next->u.c.component->name, "_data") == 0
+	    && ref->next->next
+	    && ref->next->next->type == REF_ARRAY
+	    && ref->next->next->u.ar.type != AR_ELEMENT)
+	{
+	  ts = &ref->u.c.component->ts;
+	  class_ref = ref;
+	  break;
+	}	   
+    }
+
+  if (ts == NULL)
+    return false;
+
+  if (class_ref == NULL)
+    decl = expr->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, expr);
+      decl = tmpse.expr;
+      class_ref->next = ref;
+    }
+
+  size = gfc_vtable_size_get (decl);
+
+  /* Build the address of the element.  */
+  type = TREE_TYPE (TREE_TYPE (base));
+  size = fold_convert (TREE_TYPE (index), size);
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    index, size);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+
+  /* Return the element in the se expression.  */
+  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  return true;
+}
+
+
 /* Build a scalarized reference to an array.  */
 
 static void
@@ -2911,6 +2996,12 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
     decl = expr->symtree->n.sym->backend_decl;
 
   tmp = build_fold_indirect_ref_loc (input_location, info->data);
+
+  /* Use the vptr 'size' field to access a class the element of a class
+     array.  */
+  if (build_class_array_ref (se, tmp, index))
+    return;
+
   se->expr = gfc_build_array_ref (tmp, index, decl);
 }
 
@@ -4592,7 +4683,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
-		     stmtblock_t * descriptor_block, tree * overflow)
+		     stmtblock_t * descriptor_block, tree * overflow,
+		     gfc_expr *expr3)
 {
   tree type;
   tree tmp;
@@ -4747,8 +4839,30 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
     }
 
   /* The stride is the number of elements in the array, so multiply by the
-     size of an element to get the total size.  */
-  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+     size of an element to get the total size.  Obviously, if there ia a
+     SOURCE expression (expr3) we must use its element size.  */
+  if (expr3 != NULL)
+    {
+      if (expr3->ts.type == BT_CLASS)
+	{
+	  gfc_se se_sz;
+	  gfc_expr *sz = gfc_copy_expr (expr3);
+	  gfc_add_vptr_component (sz);
+	  gfc_add_size_component (sz);
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr (&se_sz, sz);
+	  gfc_free_expr (sz);
+	  tmp = se_sz.expr;
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&expr3->ts);
+	  tmp = TYPE_SIZE_UNIT (tmp);
+	}
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
   /* Convert to size_t.  */
   element_size = fold_convert (size_type_node, tmp);
 
@@ -4813,7 +4927,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
-		    tree errlen)
+		    tree errlen, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -4897,7 +5011,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_init_block (&set_descriptor_block);
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
-			      &se->pre, &set_descriptor_block, &overflow);
+			      &se->pre, &set_descriptor_block, &overflow,
+			      expr3);
 
   if (dimension)
     {
@@ -4972,7 +5087,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   else
       gfc_add_expr_to_block (&se->pre, set_descriptor);
 
-  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+  if ((expr->ts.type == BT_DERIVED)
 	&& expr->ts.u.derived->attr.alloc_comp)
     {
       tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
@@ -7240,7 +7355,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
-	      /* Allocatable scalar CLASS components.  */
+	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 	      
@@ -7249,13 +7364,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
 
-	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
-						       CLASS_DATA (c)->ts);
-	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+	        tmp = gfc_trans_dealloc_allocated (comp);
+	      else
+		{
+		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+							   CLASS_DATA (c)->ts);
+		  gfc_add_expr_to_block (&fnblock, tmp);
 
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		}
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  break;
@@ -7282,17 +7402,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
-	      /* Allocatable scalar CLASS components.  */
+	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 	      /* Add reference to '_data' component.  */
 	      tmp = CLASS_DATA (c)->backend_decl;
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
-	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
 	    }
           else if (cmp_has_alloc_comps)
 	    {
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index bd593bd..340c1a7 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -22,9 +22,9 @@ along with GCC; see the file COPYING3.  If not see
 /* Generate code to free an array.  */
 tree gfc_array_deallocate (tree, tree, gfc_expr*);
 
-/* Generate code to initialize an allocate an array.  Statements are added to
+/* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, gfc_expr *);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c43bb80..1f1696f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1293,7 +1293,12 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
 	gfc_nonlocal_dummy_array_decl (sym);
 
-      return sym->backend_decl;
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+     return sym->backend_decl;
     }
 
   if (sym->backend_decl)
@@ -1314,7 +1319,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	&& !intrinsic_array_parameter
 	&& sym->module
 	&& gfc_get_module_backend_decl (sym))
-    return sym->backend_decl;
+    {
+      if (sym->ts.type == BT_CLASS && sym->backend_decl)
+	GFC_DECL_CLASS(sym->backend_decl) = 1;
+      return sym->backend_decl;
+    }
 
   if (sym->attr.flavor == FL_PROCEDURE)
     {
@@ -1431,6 +1440,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
     }
 
+  if (sym->ts.type == BT_CLASS)
+	GFC_DECL_CLASS(decl) = 1;
+
   sym->backend_decl = decl;
 
   if (sym->attr.assign)
@@ -3656,6 +3668,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	    gfc_trans_deferred_array (sym, block);
 	}
       else if ((!sym->attr.dummy || sym->ts.deferred)
+		&& (sym->ts.type == BT_CLASS
+		&& CLASS_DATA (sym)->attr.pointer))
+	break;
+      else if ((!sym->attr.dummy || sym->ts.deferred)
 		&& (sym->attr.allocatable
 		    || (sym->ts.type == BT_CLASS
 			&& CLASS_DATA (sym)->attr.allocatable)))
@@ -3669,8 +3685,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		gfc_add_data_component (e);
 
 	      gfc_init_se (&se, NULL);
-	      se.want_pointer = 1;
-	      gfc_conv_expr (&se, e);
+	      if (sym->ts.type != BT_CLASS
+		  || sym->ts.u.derived->attr.dimension
+		  || sym->ts.u.derived->attr.codimension)
+		{
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, e);
+		}
+	      else if (sym->ts.type == BT_CLASS
+		       && !CLASS_DATA (sym)->attr.dimension
+		       && !CLASS_DATA (sym)->attr.codimension)
+		{
+		  se.want_pointer = 1;
+		  gfc_conv_expr (&se, e);
+		}
+	      else
+		{
+		  gfc_conv_expr (&se, e);
+		  se.expr = gfc_conv_descriptor_data_addr (se.expr);
+		  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+		}
 	      gfc_free_expr (e);
 
 	      gfc_save_backend_locus (&loc);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cf9f0f7..b1c85e1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -41,6 +41,270 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-stmt.h"
 #include "dependency.h"
 
+
+/* This is the seed for an eventual trans-class.c
+
+   The following parameters should not be used directly since they might
+   in future implementations.  Use the corresponding APIs.  */
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+#define VTABLE_HASH_FIELD 0
+#define VTABLE_SIZE_FIELD 1
+#define VTABLE_EXTENDS_FIELD 2
+#define VTABLE_DEF_INIT_FIELD 3
+#define VTABLE_COPY_FIELD 4
+
+
+tree
+gfc_class_data_get (tree decl)
+{
+  tree data;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_DATA_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (data), decl, data,
+			  NULL_TREE);
+}
+
+
+tree
+gfc_class_vptr_get (tree decl)
+{
+  tree vptr;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			    CLASS_VPTR_FIELD);
+  return fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (vptr), decl, vptr,
+			  NULL_TREE);
+}
+
+
+static tree
+gfc_vtable_field_get (tree decl, int field)
+{
+  tree size;
+  tree vptr;
+  vptr = gfc_class_vptr_get (decl);
+  vptr = build_fold_indirect_ref_loc (input_location, vptr);
+  size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
+			    field);
+  size = fold_build3_loc (input_location, COMPONENT_REF,
+			  TREE_TYPE (size), vptr, size,
+			  NULL_TREE);
+  /* Always return size as an array index type.  */
+  if (field == VTABLE_SIZE_FIELD)
+    size = fold_convert (gfc_array_index_type, size);
+  gcc_assert (size);
+  return size;
+}
+
+
+tree
+gfc_vtable_hash_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
+}
+
+
+tree
+gfc_vtable_size_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
+}
+
+
+tree
+gfc_vtable_extends_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
+}
+
+
+tree
+gfc_vtable_def_init_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
+}
+
+
+tree
+gfc_vtable_copy_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
+}
+
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+#undef VTABLE_HASH_FIELD
+#undef VTABLE_SIZE_FIELD
+#undef VTABLE_EXTENDS_FIELD
+#undef VTABLE_DEF_INIT_FIELD
+#undef VTABLE_COPY_FIELD
+
+
+/* Takes a derived type expression and returns the address of a temporary
+   class object of the 'declared' type.  */ 
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+			   gfc_typespec class_ts)
+{
+  gfc_symbol *vtab;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* 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));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  ctree =  gfc_class_data_get (var);
+
+  if (parmse->ss && parmse->ss->info->useflags)
+    {
+      /* For an array reference in an elemental procedure call we need
+	 to retain the ss to provide the scalarized array reference.  */
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      ss = gfc_walk_expr (e);
+      if (ss == gfc_ss_terminator)
+	{
+	  parmse->ss = NULL;
+	  gfc_conv_expr_reference (parmse, e);
+	  tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+	  gfc_add_modify (&parmse->pre, ctree, tmp);
+	}
+      else
+	{
+	  parmse->ss = ss;
+	  gfc_conv_expr_descriptor (parmse, e, ss);
+	  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+	}
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+/* Takes a scalarized class array expression and returns the
+   address of a temporary scalar class object of the 'declared'
+   type.  
+   OOP-TODO: This could be improved by adding code that branched on
+   the dynamic type being the same as the declared type. In this case
+   the original class expression can be passed directly.  */ 
+static void
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
+			 gfc_typespec class_ts, bool elemental)
+{
+  tree ctree;
+  tree var;
+  tree tmp;
+  tree vptr;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+  bool full_array = false;
+
+  class_ref = NULL;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS)
+	class_ref = ref;
+
+      if (ref->next == NULL)
+	break;
+    }
+
+  if (ref == NULL || class_ref == ref)
+    return;
+
+  /* Test for FULL_ARRAY.  */
+  gfc_is_class_array_ref (e, &full_array);
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the data.  */
+  ctree = gfc_class_data_get (var);
+  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+
+  /* Return the data component, except in the case of scalarized array
+     references, where nullification of the cannot occur and so there
+     is no need.  */
+  if (!elemental && full_array)
+    gfc_add_modify (&parmse->post, parmse->expr, ctree);
+
+  /* Set the vptr.  */
+  ctree = gfc_class_vptr_get (var);
+
+  /* The vptr is the second field of the actual argument.
+     First we have to find the corresponding class reference. */
+
+  tmp = NULL_TREE;
+  if (class_ref == NULL
+	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 
+    tmp = e->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, e);
+      class_ref->next = ref;
+      tmp = tmpse.expr;
+    }
+
+  gcc_assert (tmp != NULL_TREE);
+
+  /* Dereference if needs be.  */
+  if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+  vptr = gfc_class_vptr_get (tmp);
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), vptr));
+
+  /* Return the vptr component, except in the case of scalarized array
+     references, where the dynamic type cannot change.  */
+  if (!elemental && full_array)
+    gfc_add_modify (&parmse->post, vptr,
+		    fold_convert (TREE_TYPE (vptr), ctree));
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+/* End of prototype trans-class.c  */
+
+
 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
 						 gfc_expr *);
@@ -799,6 +1063,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	    conv_parent_component_references (se, ref);
 
 	  gfc_conv_component_ref (se, ref);
+
 	  break;
 
 	case REF_SUBSTRING:
@@ -2409,6 +2674,9 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
 		|| GFC_DESCRIPTOR_TYPE_P (base_type))
     base_type = gfc_get_element_type (base_type);
 
+  if (expr->ts.type == BT_CLASS)
+    base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
+
   loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
 					      ? expr->ts.u.cl->backend_decl
 					      : NULL),
@@ -2645,64 +2913,6 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
-/* Takes a derived type expression and returns the address of a temporary
-   class object of the 'declared' type.  */ 
-static void
-gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
-			   gfc_typespec class_ts)
-{
-  gfc_component *cmp;
-  gfc_symbol *vtab;
-  gfc_symbol *declared = class_ts.u.derived;
-  gfc_ss *ss;
-  tree ctree;
-  tree var;
-  tree tmp;
-
-  /* The derived type needs to be converted to a temporary
-     CLASS object.  */
-  tmp = gfc_typenode_for_spec (&class_ts);
-  var = gfc_create_var (tmp, "class");
-
-  /* Set the vptr.  */
-  cmp = gfc_find_component (declared, "_vptr", true, true);
-  ctree = fold_build3_loc (input_location, COMPONENT_REF,
-			   TREE_TYPE (cmp->backend_decl),
-			   var, cmp->backend_decl, NULL_TREE);
-
-  /* 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));
-  gfc_add_modify (&parmse->pre, ctree,
-		  fold_convert (TREE_TYPE (ctree), tmp));
-
-  /* Now set the data field.  */
-  cmp = gfc_find_component (declared, "_data", true, true);
-  ctree = fold_build3_loc (input_location, COMPONENT_REF,
-			   TREE_TYPE (cmp->backend_decl),
-			   var, cmp->backend_decl, NULL_TREE);
-  ss = gfc_walk_expr (e);
-  if (ss == gfc_ss_terminator)
-    {
-      parmse->ss = NULL;
-      gfc_conv_expr_reference (parmse, e);
-      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
-      gfc_add_modify (&parmse->pre, ctree, tmp);
-    }
-  else
-    {
-      parmse->ss = ss;
-      gfc_conv_expr (parmse, e);
-      gfc_add_modify (&parmse->pre, ctree, parmse->expr);
-    }
-
-  /* Pass the address of the class object.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-}
-
-
 /* The following routine generates code for the intrinsic
    procedures from the ISO_C_BINDING module:
     * C_LOC           (function)
@@ -2954,6 +3164,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
+      /* Class array expressions are sometimes coming completely unadorned
+	 with either arrayspec or _data component.  Correct that here.
+	 OOP-TODO: Move this to the frontend.  */
+      if (e && e->expr_type == EXPR_VARIABLE
+	    && !e->ref
+	    && e->ts.type == BT_CLASS
+	    && CLASS_DATA (e)->attr.dimension)
+	{
+	  gfc_typespec temp_ts = e->ts;
+	  gfc_add_class_array_ref (e);
+	  e->ts = temp_ts;
+	}
+
       if (e == NULL)
 	{
 	  if (se->ignore_optional)
@@ -3010,6 +3233,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
+
+	  /* The scalarizer does not repackage the reference to a class
+	     array - instead it returns a pointer to the data element.  */
+	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
+	    gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
 	}
       else
 	{
@@ -3073,6 +3301,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  gfc_conv_expr_reference (&parmse, e);
 
+		  /* A class array element needs converting back to be a
+		     class object, if the formal argument is a class object.  */
+		  if (fsym && fsym->ts.type == BT_CLASS
+			&& e->ts.type == BT_CLASS
+			&& CLASS_DATA (e)->attr.dimension)
+		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+
 		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
 		     allocated on entry, it must be deallocated.  */
 		  if (fsym && fsym->attr.allocatable
@@ -3124,6 +3359,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    }
 		}
 	    }
+	  else if (e->ts.type == BT_CLASS
+		    && fsym && fsym->ts.type == BT_CLASS
+		    && CLASS_DATA (fsym)->attr.dimension)
+	    {
+	      /* Pass a class array.  */
+	      gfc_init_se (&parmse, se);
+	      gfc_conv_expr_descriptor (&parmse, e, argss);
+	      /* The conversion does not repackage the reference to a class
+	         array - _data descriptor.  */
+	      gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+	    }
 	  else
 	    {
               /* If the procedure requires an explicit interface, the actual
@@ -3188,6 +3434,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		gfc_conv_subref_array_arg (&parmse, e, f,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
+	      else if (gfc_is_class_array_ref (e, NULL)
+			 && fsym && fsym->ts.type == BT_DERIVED)
+		/* The actual argument is a component reference to an
+		   array of derived types.  In this case, the argument
+		   is converted to a temporary, which is passed and then
+		   written back after the procedure call.
+		   OOP-TODO: Insert code so that if the dynamic type is
+		   the same as the declared type, copy-in/copy-out does
+		   not occur.  */
+		gfc_conv_subref_array_arg (&parmse, e, f,
+				fsym ? fsym->attr.intent : INTENT_INOUT,
+				fsym && fsym->attr.pointer);
 	      else
 	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
 					  sym->name, NULL);
@@ -4895,7 +5153,12 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
           expr->ts.kind = expr->ts.u.derived->ts.kind;
         }
     }
-  
+
+  /* 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");
+
   switch (expr->expr_type)
     {
     case EXPR_OP:
@@ -6469,6 +6732,36 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
+static tree
+gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
+{
+  gfc_actual_arglist *actual;
+  gfc_expr *ppc;
+  gfc_code *ppc_code;
+  tree res;
+
+  actual = gfc_get_actual_arglist ();
+  actual->expr = gfc_copy_expr (rhs);
+  actual->next = gfc_get_actual_arglist ();
+  actual->next->expr = gfc_copy_expr (lhs);
+  ppc = gfc_copy_expr (obj);
+  gfc_add_vptr_component (ppc);
+  gfc_add_component_ref (ppc, "_copy");
+  ppc_code = gfc_get_code ();
+  ppc_code->resolved_sym = ppc->symtree->n.sym;
+  /* Although '_copy' is set to be elemental in class.c, it is
+     not staying that way.  Find out why, sometime....  */
+  ppc_code->resolved_sym->attr.elemental = 1;
+  ppc_code->ext.actual = actual;
+  ppc_code->expr1 = ppc;
+  ppc_code->op = EXEC_CALL;
+  /* Since '_copy' is elemental, the scalarizer will take care
+     of arrays in gfc_trans_call.  */
+  res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
+  gfc_free_statements (ppc_code);
+  return res;
+}
+
 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
    A MEMCPY is needed to copy the full data from the default initializer
    of the dynamic type.  */
@@ -6495,18 +6788,24 @@ gfc_trans_class_init_assign (gfc_code *code)
   gfc_get_derived_type (rhs->ts.u.derived);
   gfc_add_def_init_component (rhs);
 
-  sz = gfc_copy_expr (code->expr1);
-  gfc_add_vptr_component (sz);
-  gfc_add_size_component (sz);
-
-  gfc_init_se (&dst, NULL);
-  gfc_init_se (&src, NULL);
-  gfc_init_se (&memsz, NULL);
-  gfc_conv_expr (&dst, lhs);
-  gfc_conv_expr (&src, rhs);
-  gfc_conv_expr (&memsz, sz);
-  gfc_add_block_to_block (&block, &src.pre);
-  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+  if (code->expr1->ts.type == BT_CLASS
+	&& CLASS_DATA (code->expr1)->attr.dimension)
+    tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+  else
+    {
+      sz = gfc_copy_expr (code->expr1);
+      gfc_add_vptr_component (sz);
+      gfc_add_size_component (sz);
+
+      gfc_init_se (&dst, NULL);
+      gfc_init_se (&src, NULL);
+      gfc_init_se (&memsz, NULL);
+      gfc_conv_expr (&dst, lhs);
+      gfc_conv_expr (&src, rhs);
+      gfc_conv_expr (&memsz, sz);
+      gfc_add_block_to_block (&block, &src.pre);
+      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+    }
   gfc_add_expr_to_block (&block, tmp);
   
   return gfc_finish_block (&block);
@@ -6553,9 +6852,24 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
       gfc_free_expr (lhs);
       gfc_free_expr (rhs);
     }
+  else if (CLASS_DATA (expr2)->attr.dimension)
+    {
+      /* Insert an additional assignment which sets the '_vptr' field.  */
+      lhs = gfc_copy_expr (expr1);
+      gfc_add_vptr_component (lhs);
+
+      rhs = gfc_copy_expr (expr2);
+      gfc_add_vptr_component (rhs);
+
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
+      gfc_free_expr (lhs);
+      gfc_free_expr (rhs);
+    }
 
   /* Do the actual CLASS assignment.  */
-  if (expr2->ts.type == BT_CLASS)
+  if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension)
     op = EXEC_ASSIGN;
   else
     gfc_add_data_component (expr1);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index d8e1783..58112e3 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5028,6 +5028,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   gfc_init_se (&argse, NULL);
   actual = expr->value.function.actual;
 
+  if (actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (actual->expr);
+
   ss = gfc_walk_expr (actual->expr);
   gcc_assert (ss != gfc_ss_terminator);
   argse.want_pointer = 1;
@@ -5667,14 +5670,24 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
 
   gfc_init_se (&arg1se, NULL);
   arg1 = expr->value.function.actual;
+
+  if (arg1->expr->ts.type == BT_CLASS)
+    {
+      /* Make sure that class array expressions have both a _data
+	 component reference and an array reference....  */
+      if (CLASS_DATA (arg1->expr)->attr.dimension)
+	gfc_add_class_array_ref (arg1->expr);
+      /* .... whilst scalars only need the _data component.  */
+      else
+	gfc_add_data_component (arg1->expr);
+    }
+
   ss1 = gfc_walk_expr (arg1->expr);
 
   if (ss1 == gfc_ss_terminator)
     {
       /* Allocatable scalar.  */
       arg1se.want_pointer = 1;
-      if (arg1->expr->ts.type == BT_CLASS)
-	gfc_add_data_component (arg1->expr);
       gfc_conv_expr (&arg1se, arg1->expr);
       tmp = arg1se.expr;
     }
@@ -6998,6 +7011,9 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 static gfc_ss *
 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
 {
+  if (expr->value.function.actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (expr->value.function.actual->expr);
+
   /* The two argument version returns a scalar.  */
   if (expr->value.function.actual->next->expr)
     return ss;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index b21be45..9e903d8 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1093,14 +1093,19 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 {
   gfc_expr *e;
   tree tmp;
+  bool class_target;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
 
+  class_target = (e->expr_type == EXPR_VARIABLE)
+		    && (gfc_is_class_scalar_expr (e)
+			|| gfc_is_class_array_ref (e, NULL));
+
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
-  if (sym->attr.dimension
+  if (sym->attr.dimension && !class_target
       && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
     {
       gfc_se se;
@@ -1140,6 +1145,23 @@ 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)
+    {
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, e);
+
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
+
+      gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+      
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
   /* Do a scalar pointer assignment; this is for scalar variable targets.  */
   else if (gfc_is_associate_pointer (sym))
     {
@@ -4677,6 +4699,7 @@ tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
+  gfc_expr *e;
   gfc_expr *expr;
   gfc_se se;
   tree tmp;
@@ -4748,7 +4771,7 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
 	{
 	  /* A scalar or derived type.  */
 
@@ -4878,6 +4901,16 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
+	  else if (al->expr->ts.type == BT_CLASS && code->expr3)
+	    {
+	      /* With class objects, it is best to play safe and null the 
+		 memory because we cannot know if dynamic types have allocatable
+		 components or not.  */
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMSET),
+					 3, se.expr, integer_zero_node,  memsz);
+	      gfc_add_expr_to_block (&se.pre, tmp);
+	    }
 	}
 
       gfc_add_block_to_block (&block, &se.pre);
@@ -4901,6 +4934,60 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
  
+      /* We need the vptr of CLASS objects to be initialized.  */ 
+      e = gfc_copy_expr (al->expr);
+      if (e->ts.type == BT_CLASS)
+	{
+	  gfc_expr *lhs,*rhs;
+	  gfc_se lse;
+
+	  lhs = gfc_expr_to_initialize (e);
+	  gfc_add_vptr_component (lhs);
+	  rhs = NULL;
+	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+	    {
+	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	      rhs = gfc_copy_expr (code->expr3);
+	      gfc_add_vptr_component (rhs);
+	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+	      gfc_add_expr_to_block (&block, tmp);
+	      gfc_free_expr (rhs);
+	      rhs = gfc_expr_to_initialize (e);
+	    }
+	  else
+	    {
+	      /* VPTR is fixed at compile time.  */
+	      gfc_symbol *vtab;
+	      gfc_typespec *ts;
+	      if (code->expr3)
+		ts = &code->expr3->ts;
+	      else if (e->ts.type == BT_DERIVED)
+		ts = &e->ts;
+	      else if (code->ext.alloc.ts.type == BT_DERIVED)
+		ts = &code->ext.alloc.ts;
+	      else if (e->ts.type == BT_CLASS)
+		ts = &CLASS_DATA (e)->ts;
+	      else
+		ts = &e->ts;
+
+	      if (ts->type == BT_DERIVED)
+		{
+		  vtab = gfc_find_derived_vtab (ts->u.derived);
+		  gcc_assert (vtab);
+		  gfc_init_se (&lse, NULL);
+		  lse.want_pointer = 1;
+		  gfc_conv_expr (&lse, lhs);
+		  tmp = gfc_build_addr_expr (NULL_TREE,
+					     gfc_get_symbol_decl (vtab));
+		  gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+		}
+	    }
+	  gfc_free_expr (lhs);
+	}
+
+      gfc_free_expr (e);
+
       if (code->expr3 && !code->expr3->mold)
 	{
 	  /* Initialization via SOURCE block
@@ -4908,10 +4995,11 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
 	  if (al->expr->ts.type == BT_CLASS)
 	    {
-	      gfc_se call;
 	      gfc_actual_arglist *actual;
 	      gfc_expr *ppc;
-	      gfc_init_se (&call, NULL);
+	      gfc_code *ppc_code;
+	      gfc_ref *dataref;
+
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
 	      actual->expr = gfc_copy_expr (rhs);
@@ -4919,20 +5007,58 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_data_component (actual->expr);
 	      actual->next = gfc_get_actual_arglist ();
 	      actual->next->expr = gfc_copy_expr (al->expr);
+	      actual->next->expr->ts.type = BT_CLASS;
 	      gfc_add_data_component (actual->next->expr);
+	      dataref = actual->next->expr->ref;
+	      if (dataref->u.c.component->as)
+		{
+		  int dim;
+		  gfc_expr *temp;
+		  gfc_ref *ref = dataref->next;
+		  ref->u.ar.type = AR_SECTION;
+		  /* We have to set up the array reference to give ranges
+		    in all dimensions and ensure that the end and stride
+		    are set so that the copy can be scalarized.  */
+		  dim = 0;
+		  for (; dim < dataref->u.c.component->as->rank; dim++)
+		    {
+		      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+		      if (ref->u.ar.end[dim] == NULL)
+			{
+			  ref->u.ar.end[dim] = ref->u.ar.start[dim];
+			  temp = gfc_get_int_expr (gfc_default_integer_kind,
+						   &al->expr->where, 1);
+			  ref->u.ar.start[dim] = temp;
+			}
+		      temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
+					   gfc_copy_expr (ref->u.ar.start[dim]));
+		      temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
+							&al->expr->where, 1),
+				      temp);
+		    }
+		}
 	      if (rhs->ts.type == BT_CLASS)
 		{
 		  ppc = gfc_copy_expr (rhs);
 		  gfc_add_vptr_component (ppc);
 		}
 	      else
-		ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+		ppc = gfc_lval_expr_from_sym
+				(gfc_find_derived_vtab (rhs->ts.u.derived));
 	      gfc_add_component_ref (ppc, "_copy");
-	      gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
-					ppc, NULL);
-	      gfc_add_expr_to_block (&call.pre, call.expr);
-	      gfc_add_block_to_block (&call.pre, &call.post);
-	      tmp = gfc_finish_block (&call.pre);
+
+	      ppc_code = gfc_get_code ();
+	      ppc_code->resolved_sym = ppc->symtree->n.sym;
+	      /* Although '_copy' is set to be elemental in class.c, it is
+		 not staying that way.  Find out why, sometime....  */
+	      ppc_code->resolved_sym->attr.elemental = 1;
+	      ppc_code->ext.actual = actual;
+	      ppc_code->expr1 = ppc;
+	      ppc_code->op = EXEC_CALL;
+	      /* Since '_copy' is elemental, the scalarizer will take care
+		 of arrays in gfc_trans_call.  */
+	      tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+	      gfc_free_statements (ppc_code);
 	    }
 	  else if (expr3 != NULL_TREE)
 	    {
@@ -4972,59 +5098,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_free_expr (rhs);
 	}
 
-      /* Allocation of CLASS entities.  */
       gfc_free_expr (expr);
-      expr = al->expr;
-      if (expr->ts.type == BT_CLASS)
-	{
-	  gfc_expr *lhs,*rhs;
-	  gfc_se lse;
-
-	  /* Initialize VPTR for CLASS objects.  */
-	  lhs = gfc_expr_to_initialize (expr);
-	  gfc_add_vptr_component (lhs);
-	  rhs = NULL;
-	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
-	    {
-	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
-	      rhs = gfc_copy_expr (code->expr3);
-	      gfc_add_vptr_component (rhs);
-	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
-	      gfc_add_expr_to_block (&block, tmp);
-	      gfc_free_expr (rhs);
-	    }
-	  else
-	    {
-	      /* VPTR is fixed at compile time.  */
-	      gfc_symbol *vtab;
-	      gfc_typespec *ts;
-	      if (code->expr3)
-		ts = &code->expr3->ts;
-	      else if (expr->ts.type == BT_DERIVED)
-		ts = &expr->ts;
-	      else if (code->ext.alloc.ts.type == BT_DERIVED)
-		ts = &code->ext.alloc.ts;
-	      else if (expr->ts.type == BT_CLASS)
-		ts = &CLASS_DATA (expr)->ts;
-	      else
-		ts = &expr->ts;
-
-	      if (ts->type == BT_DERIVED)
-		{
-		  vtab = gfc_find_derived_vtab (ts->u.derived);
-		  gcc_assert (vtab);
-		  gfc_init_se (&lse, NULL);
-		  lse.want_pointer = 1;
-		  gfc_conv_expr (&lse, lhs);
-		  tmp = gfc_build_addr_expr (NULL_TREE,
-					     gfc_get_symbol_decl (vtab));
-		  gfc_add_modify (&block, lse.expr,
-			fold_convert (TREE_TYPE (lse.expr), tmp));
-		}
-	    }
-	  gfc_free_expr (lhs);
-	}
-
     }
 
   /* STAT  (ERRMSG only makes sense with STAT).  */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 88bd389..085f58f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -315,6 +315,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
 {
   tree type = TREE_TYPE (base);
   tree tmp;
+  tree span;
 
   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
     {
@@ -345,12 +346,33 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
   if (decl && (TREE_CODE (decl) == FIELD_DECL
 		 || TREE_CODE (decl) == VAR_DECL
 		 || TREE_CODE (decl) == PARM_DECL)
-	&& GFC_DECL_SUBREF_ARRAY_P (decl)
-	&& !integer_zerop (GFC_DECL_SPAN(decl)))
+	&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
+	      && !integer_zerop (GFC_DECL_SPAN(decl)))
+	   || GFC_DECL_CLASS (decl)))
     {
+      if (GFC_DECL_CLASS (decl))
+	{
+	  /* Allow for dummy arguments and other good things.  */
+	  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+	    decl = build_fold_indirect_ref_loc (input_location, decl);
+
+	  /* Check if '_data' is an array descriptor. If it is not,
+	     the array must be one of the components of the class object,
+	     so return a normal array reference.  */
+	  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
+	    return build4_loc (input_location, ARRAY_REF, type, base,
+			       offset, NULL_TREE, NULL_TREE);
+
+	  span = gfc_vtable_size_get (decl);
+	}
+      else if (GFC_DECL_SUBREF_ARRAY_P (decl))
+	span = GFC_DECL_SPAN(decl);
+      else
+	gcc_unreachable ();
+
       offset = fold_build2_loc (input_location, MULT_EXPR,
 				gfc_array_index_type,
-				offset, GFC_DECL_SPAN(decl));
+				offset, span);
       tmp = gfc_build_addr_expr (pvoid_type_node, base);
       tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
       tmp = fold_convert (build_pointer_type (type), tmp);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 8fc7599..259a08a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -333,6 +333,14 @@ typedef struct
 }
 gfc_wrapped_block;
 
+/* Class API functions.  */
+tree gfc_class_data_get (tree);
+tree gfc_class_vptr_get (tree);
+tree gfc_vtable_hash_get (tree);
+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);
 
 /* Initialize an init/cleanup block.  */
 void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
@@ -803,6 +811,7 @@ struct GTY((variable_size)) lang_decl {
 #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
 #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
 #define GFC_DECL_PUSH_TOPLEVEL(node) DECL_LANG_FLAG_7(node)
+#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
 
 /* An array descriptor.  */
 #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0921c14..b46988b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,32 @@
+2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/41539
+	PR fortran/43214
+	PR fortran/43969
+	PR fortran/44568
+	PR fortran/46356
+	PR fortran/46990
+	PR fortran/49074
+	* gfortran.dg/class_array_1.f03: New.
+	* gfortran.dg/class_array_2.f03: New.
+	* gfortran.dg/class_array_3.f03: New.
+	* gfortran.dg/class_array_4.f03: New.
+	* gfortran.dg/class_array_5.f03: New.
+	* gfortran.dg/class_array_6.f03: New.
+	* gfortran.dg/class_array_7.f03: New.
+	* gfortran.dg/class_array_8.f03: New.
+	* gfortran.dg/coarray_poly_1.f90: New.
+	* gfortran.dg/coarray_poly_2.f90: New.
+	* gfortran.dg/coarray/poly_run_1.f90: New.
+	* gfortran.dg/coarray/poly_run_2.f90: New.
+	* gfortran.dg/class_to_type_1.f03: New.
+	* gfortran.dg/type_to_class_1.f03: New.
+	* gfortran.dg/typebound_assignment_3.f03: Remove the error.
+	* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
+	now 2.
+	* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.
+
 2011-12-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/50690
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index 4cbda82..e607b6a 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -25,5 +25,5 @@ contains
 
 end program 
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03
index 78e5652..27ee7b4 100644
--- a/gcc/testsuite/gfortran.dg/class_19.f03
+++ b/gcc/testsuite/gfortran.dg/class_19.f03
@@ -39,7 +39,7 @@ program main
 
 end program main
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 
 ! { dg-final { cleanup-modules "foo_mod" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_1.f03 b/gcc/testsuite/gfortran.dg/class_array_1.f03
new file mode 100644
index 0000000..32a0e54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_1.f03
@@ -0,0 +1,76 @@
+! { dg-do run }
+!
+! Test functionality of allocatable class arrays:
+! ALLOCATE with source, ALLOCATED, DEALLOCATE, passing as arguments for
+! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER.
+!
+  type :: type1
+    integer :: i
+  end type
+  type, extends(type1) :: type2
+    real :: r
+  end type
+  class(type1), allocatable, dimension (:) :: x
+
+  allocate(x(2), source = type2(42,42.0))
+  call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)])
+  call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)])
+  if (allocated (x)) deallocate (x)
+
+  allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) 
+  call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)])
+  call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)])
+
+  if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort
+
+  if (allocated (x)) deallocate (x)
+
+  allocate(x(1:4), source = type1(42))
+  call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)])
+  call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)])
+  if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort
+
+contains
+  subroutine display(x, lower, upper, t1, t2)
+    class(type1), allocatable, dimension (:) :: x
+    integer, dimension (:) :: lower, upper
+    type(type1), optional, dimension(:) :: t1
+    type(type2), optional, dimension(:) :: t2
+    select type (x)
+      type is (type1)
+        if (present (t1)) then
+          if (any (x%i .ne. t1%i)) call abort
+        else
+          call abort
+        end if
+        x(2)%i = 99
+      type is (type2)
+        if (present (t2)) then
+          if (any (x%i .ne. t2%i)) call abort
+          if (any (x%r .ne. t2%r)) call abort
+        else
+          call abort
+        end if
+        x%i = 111
+        x%r = 99.0
+    end select
+    call bounds (x, lower, upper)
+  end subroutine
+  subroutine bounds (x, lower, upper)
+    class(type1), allocatable, dimension (:) :: x
+    integer, dimension (:) :: lower, upper
+    if (any (lower .ne. lbound (x))) call abort
+    if (any (upper .ne. ubound (x))) call abort
+  end subroutine
+  elemental function disp(y) result(ans)
+    class(type1), intent(in) :: y
+    real :: ans
+    select type (y)
+      type is (type1)
+        ans = 0.0
+      type is (type2)
+        ans = y%r
+    end select
+  end function
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_array_2.f03 b/gcc/testsuite/gfortran.dg/class_array_2.f03
new file mode 100644
index 0000000..68f1b71
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_2.f03
@@ -0,0 +1,78 @@
+! { dg-do run }
+!
+! Test functionality of pointer class arrays:
+! ALLOCATE with source, ASSOCIATED, DEALLOCATE, passing as arguments for
+! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER.
+!
+  type :: type1
+    integer :: i
+  end type
+  type, extends(type1) :: type2
+    real :: r
+  end type
+  class(type1), pointer, dimension (:) :: x
+
+  allocate(x(2), source = type2(42,42.0))
+  call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)])
+  call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)])
+  if (associated (x)) deallocate (x)
+
+  allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) 
+  call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)])
+  call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)])
+
+  if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort
+
+  if (associated (x)) deallocate (x)
+
+  allocate(x(1:4), source = type1(42))
+  call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)])
+  call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)])
+  if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort
+
+  if (associated (x)) deallocate (x)
+
+contains
+  subroutine display(x, lower, upper, t1, t2)
+    class(type1), pointer, dimension (:) :: x
+    integer, dimension (:) :: lower, upper
+    type(type1), optional, dimension(:) :: t1
+    type(type2), optional, dimension(:) :: t2
+    select type (x)
+      type is (type1)
+        if (present (t1)) then
+          if (any (x%i .ne. t1%i)) call abort
+        else
+          call abort
+        end if
+        x(2)%i = 99
+      type is (type2)
+        if (present (t2)) then
+          if (any (x%i .ne. t2%i)) call abort
+          if (any (x%r .ne. t2%r)) call abort
+        else
+          call abort
+        end if
+        x%i = 111
+        x%r = 99.0
+    end select
+    call bounds (x, lower, upper)
+  end subroutine
+  subroutine bounds (x, lower, upper)
+    class(type1), pointer, dimension (:) :: x
+    integer, dimension (:) :: lower, upper
+    if (any (lower .ne. lbound (x))) call abort
+    if (any (upper .ne. ubound (x))) call abort
+  end subroutine
+  elemental function disp(y) result(ans)
+    class(type1), intent(in) :: y
+    real :: ans
+    select type (y)
+      type is (type1)
+        ans = 0.0
+      type is (type2)
+        ans = y%r
+    end select
+  end function
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_array_3.f03 b/gcc/testsuite/gfortran.dg/class_array_3.f03
new file mode 100644
index 0000000..0ca0a00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_3.f03
@@ -0,0 +1,143 @@
+! { dg-do run }
+!
+! class based quick sort program - starting point comment #0 of pr41539
+!
+! Note assignment with vector index reference fails because temporary
+! allocation does not occur - also false dependency detected. Nullification
+! of temp descriptor data causes a segfault.
+!
+module m_qsort
+ implicit none
+ type, abstract :: sort_t
+ contains
+   procedure(disp), deferred :: disp
+   procedure(lt_cmp), deferred :: lt_cmp
+   procedure(assign), deferred :: assign
+   generic :: operator(<) => lt_cmp
+   generic :: assignment(=) => assign
+ end type sort_t
+ interface
+   elemental integer function disp(a)
+     import
+     class(sort_t), intent(in) :: a
+   end function disp
+ end interface
+ interface
+   impure elemental logical function lt_cmp(a,b)
+     import
+     class(sort_t), intent(in) :: a, b
+   end function lt_cmp
+ end interface
+ interface
+   elemental subroutine assign(a,b)
+     import
+     class(sort_t), intent(out) :: a
+     class(sort_t), intent(in) :: b
+   end subroutine assign
+ end interface
+contains
+
+ subroutine qsort(a)
+   class(sort_t), intent(inout),allocatable :: a(:)
+   class(sort_t), allocatable :: tmp (:)
+   integer, allocatable :: index_array (:)
+   integer :: i
+   allocate (tmp(size (a, 1)), source = a)
+   index_array = [(i, i = 1, size (a, 1))]
+   call internal_qsort (tmp, index_array)   ! Do not move class elements around until end
+   do i = 1, size (a, 1)                    ! Since they can be of arbitrary size.
+     a(i) = tmp(index_array(i))             ! Vector index array would be neater
+   end do
+!    a = tmp(index_array)                    ! Like this - TODO: fixme
+ end subroutine qsort
+
+ recursive subroutine internal_qsort (x, iarray)
+   class(sort_t), intent(inout),allocatable :: x(:)
+   class(sort_t), allocatable :: ptr
+   integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
+   integer :: pivot, nelem, i, iptr
+   if (.not.allocated (iarray)) return
+   nelem = size (iarray, 1)
+   if (nelem .le. 1) return
+   pivot = nelem / 2
+   allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
+   do i = 1, nelem
+     iptr = iarray(i)                  ! Index for i'th element
+     if (ptr%lt_cmp (x(iptr))) then    ! Compare pivot with i'th element
+       itmp = [iptr]
+       above = concat (itmp, above)    ! Invert order to prevent infinite loops
+     else
+       itmp = [iptr]
+       below = concat (itmp, below)    ! -ditto-
+     end if
+   end do
+   call internal_qsort (x, above)      ! Recursive sort of 'above' and 'below'
+   call internal_qsort (x, below)
+   iarray = concat (below, above)      ! Concatenate the result
+ end subroutine internal_qsort
+
+ function concat (ia, ib) result (ic)
+   integer, allocatable, dimension(:) :: ia, ib, ic
+   if (allocated (ia) .and. allocated (ib)) then
+     ic = [ia, ib]
+   else if (allocated (ia)) then
+     ic = ia
+   else if (allocated (ib)) then
+     ic = ib
+   end if
+ end function concat
+end module m_qsort
+
+module test
+ use m_qsort
+ implicit none
+ type, extends(sort_t) :: sort_int_t
+   integer :: i
+ contains
+   procedure :: disp => disp_int
+   procedure :: lt_cmp => lt_cmp_int
+   procedure :: assign => assign_int
+ end type
+contains
+ elemental integer function disp_int(a)
+     class(sort_int_t), intent(in) :: a
+     disp_int = a%i
+ end function disp_int
+ elemental subroutine assign_int (a, b)
+   class(sort_int_t), intent(out) :: a
+   class(sort_t), intent(in) :: b         ! TODO: gfortran does not throw 'class(sort_int_t)'
+   select type (b)
+     class is (sort_int_t)
+       a%i = b%i
+     class default
+       a%i = -1
+   end select
+ end subroutine assign_int
+ impure elemental logical function lt_cmp_int(a,b) result(cmp)
+   class(sort_int_t), intent(in) :: a
+   class(sort_t), intent(in) :: b
+   select type(b)
+     type is(sort_int_t)
+       if (a%i < b%i) then
+         cmp = .true.
+       else
+         cmp = .false.
+       end if
+     class default
+         ERROR STOP "Don't compare apples with oranges"
+   end select
+ end function lt_cmp_int
+end module test
+
+program main
+ use test
+ class(sort_t), allocatable :: A(:)
+ integer :: i, m(5)= [7 , 4, 5, 2, 3]
+ allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
+!  print *, "Before qsort: ", (A(i)%disp(), i = 1, size(a,1))
+ call qsort(A)
+!  print *, "After qsort:  ", (A(i)%disp(), i = 1, size(a,1))
+ if (any ([(A(i)%disp(), i = 1, size(a,1))] .ne. [2,3,4,5,7])) call abort
+end program main
+
+! { dg-final { cleanup-modules "m_qsort test" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_4.f03 b/gcc/testsuite/gfortran.dg/class_array_4.f03
new file mode 100644
index 0000000..7c748f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_4.f03
@@ -0,0 +1,26 @@
+! { dg-do run }
+! PR43214 - implementation of class arrays
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+module m
+  type t
+    real :: r = 99
+  contains
+    procedure, pass :: foo => foo
+  end type t
+contains
+  elemental subroutine foo(x, i)
+    class(t),intent(in) :: x
+    integer,intent(inout) :: i
+    i = x%r + i
+  end subroutine foo
+end module m
+
+  use m
+  type(t) :: x(3)
+  integer :: n(3) = [0,100,200]
+  call x(:)%foo(n)
+  if (any(n .ne. [99,199,299])) call abort
+end
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_5.f03 b/gcc/testsuite/gfortran.dg/class_array_5.f03
new file mode 100644
index 0000000..2a7e2f1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_5.f03
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! PR44568 - class array impelementation.
+!
+! Contributed by Hans-Werner Boschmann
+!
+module ice6
+
+  type::a_type
+   contains
+     procedure::do_something
+  end type a_type
+
+  contains
+
+  subroutine do_something(this)
+    class(a_type),intent(in)::this
+  end subroutine do_something
+
+  subroutine do_something_else()
+    class(a_type),dimension(:),allocatable::values
+    call values(1)%do_something()
+  end subroutine do_something_else
+
+end module ice6
+! { dg-final { cleanup-modules "ice6" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_6.f03 b/gcc/testsuite/gfortran.dg/class_array_6.f03
new file mode 100644
index 0000000..4f8b803
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_6.f03
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! PR46356 - class arrays 
+!
+! Contributed by Ian Harvey
+!
+MODULE procedure_intent_nonsense
+  IMPLICIT NONE  
+  PRIVATE    
+  TYPE, PUBLIC :: Parent
+    INTEGER :: comp
+  END TYPE Parent
+
+  TYPE :: ParentVector
+    INTEGER :: a
+    ! CLASS(Parent), ALLOCATABLE :: a
+  END TYPE ParentVector  
+CONTAINS           
+  SUBROUTINE vector_operation(pvec)     
+    CLASS(ParentVector), INTENT(INOUT) :: pvec(:)
+    INTEGER :: i    
+    !---
+    DO i = 1, SIZE(pvec)
+      CALL item_operation(pvec(i))
+    END DO  
+    ! PRINT *, pvec(1)%a%comp
+  END SUBROUTINE vector_operation
+
+  SUBROUTINE item_operation(pvec)  
+    CLASS(ParentVector), INTENT(INOUT) :: pvec
+    !TYPE(ParentVector), INTENT(INOUT) :: pvec
+  END SUBROUTINE item_operation
+END MODULE procedure_intent_nonsense
+! { dg-final { cleanup-modules "procedure_intent_nonsense" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_7.f03 b/gcc/testsuite/gfortran.dg/class_array_7.f03
new file mode 100644
index 0000000..225cc7e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_7.f03
@@ -0,0 +1,59 @@
+! { dg-do run }
+! PR46990 - class array implementation
+!
+! Contributed by Wolfgang Kilian on comp.lang.fortran - see comment #7 of PR
+!
+module realloc
+  implicit none
+
+  type :: base_type
+     integer :: i
+  contains
+    procedure :: assign
+    generic :: assignment(=) => assign   ! define generic assignment
+  end type base_type
+
+  type, extends(base_type) :: extended_type
+     integer :: j
+  end type extended_type
+
+contains
+
+  elemental subroutine assign (a, b)
+    class(base_type), intent(out) :: a
+    type(base_type), intent(in) :: b
+    a%i = b%i
+  end subroutine assign
+
+  subroutine reallocate (a)
+    class(base_type), dimension(:), allocatable, intent(inout) :: a
+    class(base_type), dimension(:), allocatable :: tmp
+    allocate (tmp (2 * size (a))) ! how to alloc b with same type as a ?
+    if (trim (print_type ("tmp", tmp)) .ne. "tmp is base_type") call abort
+    tmp(:size(a)) = a             ! polymorphic l.h.s.
+    call move_alloc (from=tmp, to=a)
+  end subroutine reallocate
+
+  character(20) function print_type (name, a)
+    character(*), intent(in) :: name
+    class(base_type), dimension(:), intent(in) :: a
+    select type (a)
+     type is (base_type);      print_type = NAME // " is base_type"
+     type is (extended_type);  print_type = NAME // " is extended_type"
+    end select
+  end function
+
+end module realloc
+
+program main
+  use realloc
+  implicit none
+  class(base_type), dimension(:), allocatable :: a
+
+  allocate (extended_type :: a(10))
+  if (trim (print_type ("a", a)) .ne. "a is extended_type") call abort
+  call reallocate (a)
+  if (trim (print_type ("a", a)) .ne. "a is base_type") call abort
+end program main
+
+! { dg-final { cleanup-modules "realloc" } }
diff --git a/gcc/testsuite/gfortran.dg/class_array_8.f03 b/gcc/testsuite/gfortran.dg/class_array_8.f03
new file mode 100644
index 0000000..20c57ec
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_8.f03
@@ -0,0 +1,18 @@
+! { dg-do run }
+! PR43969 - class array implementation
+!
+! Contributed by Janus Weil  <janus@gcc.gnu.org>
+!
+  implicit none
+
+  type indx_map
+  end type
+
+  type desc_type
+    class(indx_map), allocatable :: indxmap(:)
+  end type
+
+  type(desc_type)  :: desc
+  if (allocated(desc%indxmap)) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_1.f03 b/gcc/testsuite/gfortran.dg/class_to_type_1.f03
new file mode 100644
index 0000000..0243343
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_1.f03
@@ -0,0 +1,97 @@
+! { dg-do run }
+!
+! Passing CLASS to TYPE
+!
+implicit none
+type t
+  integer :: A
+  real, allocatable :: B(:)
+end type t
+
+type, extends(t) ::  t2
+  complex :: z = cmplx(3.3, 4.4)
+end type t2
+integer :: i
+class(t), allocatable :: x(:)
+
+allocate(t2 :: x(10))
+select type(x)
+ type is(t2)
+  if (size (x) /= 10) call abort ()
+  x = [(t2(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
+  do i = 1, 10
+    if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
+        .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
+        call abort()
+    end if
+    if (x(i)%z /= cmplx(3.3, 4.4)) call abort()
+  end do
+  class default
+    call abort()
+end select
+
+call base(x)
+call baseExplicit(x, size(x))
+call class(x)
+call classExplicit(x, size(x))
+contains
+  subroutine base(y)
+    type(t) :: y(:)
+    if (size (y) /= 10) call abort ()
+    do i = 1, 10
+      if (y(i)%a /= -i .or. size (y(i)%b) /= 4 &
+          .or. any (y(i)%b /= [1*i,2*i,3*i,4*i])) then
+        call abort()
+      end if
+    end do
+  end subroutine base
+  subroutine baseExplicit(v, n)
+    integer, intent(in) :: n
+    type(t) :: v(n)
+    if (size (v) /= 10) call abort ()
+    do i = 1, 10
+      if (v(i)%a /= -i .or. size (v(i)%b) /= 4 &
+          .or. any (v(i)%b /= [1*i,2*i,3*i,4*i])) then
+        call abort()
+      end if
+    end do
+  end subroutine baseExplicit
+  subroutine class(z)
+    class(t), intent(in) :: z(:)
+    select type(z)
+     type is(t2)
+      if (size (z) /= 10) call abort ()
+      do i = 1, 10
+        if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
+            .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
+            call abort()
+        end if
+        if (z(i)%z /= cmplx(3.3, 4.4)) call abort()
+      end do
+      class default
+        call abort()
+    end select
+    call base(z)
+    call baseExplicit(z, size(z))
+  end subroutine class
+  subroutine classExplicit(u, n)
+    integer, intent(in) :: n
+    class(t), intent(in) :: u(n)
+    select type(u)
+     type is(t2)
+      if (size (u) /= 10) call abort ()
+      do i = 1, 10
+        if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
+            .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
+            call abort()
+        end if
+        if (u(i)%z /= cmplx(3.3, 4.4)) call abort()
+      end do
+      class default
+        call abort()
+    end select
+    call base(u)
+    call baseExplicit(u, n)
+  end subroutine classExplicit
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
new file mode 100644
index 0000000..a371aef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
@@ -0,0 +1,43 @@
+! { dg-do run }
+!
+! Test for polymorphic coarrays
+!
+type t
+end type t
+class(t), allocatable :: A(:)[:,:]
+allocate (A(2)[1:4,-5:*])
+if (any (lcobound(A) /= [1, -5])) call abort ()
+if (num_images() == 1) then
+  if (any (ucobound(A) /= [4, -5])) call abort ()
+else
+  if (ucobound(A,dim=1) /= 4) call abort ()
+end if
+if (allocated(A)) i = 5
+call s(A)
+!call t(A) ! FIXME
+
+contains
+
+subroutine s(x)
+  class(t),allocatable :: x(:)[:,:]
+  if (any (lcobound(x) /= [1, -5])) call abort ()
+  if (num_images() == 1) then
+    if (any (ucobound(x) /= [4, -5])) call abort ()
+! FIXME: Tree-walking issue?
+!  else
+!    if (ucobound(x,dim=1) /= 4) call abort ()
+  end if
+end subroutine s
+
+! FIXME
+!subroutine st(x)
+!  class(t),allocatable :: x(:)[:,:]
+!  if (any (lcobound(x) /= [1, 2])) call abort ()
+!  if (num_images() == 1) then
+!    if (any (ucobound(x) /= [4, 2])) call abort ()
+!  else
+!    if (ucobound(x,dim=1) /= 4) call abort ()
+!  end if
+!end subroutine st
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
new file mode 100644
index 0000000..fe524a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Test for polymorphic coarrays
+!
+type t
+end type t
+class(t), allocatable :: A[:,:]
+allocate (A[1:4,-5:*])
+if (allocated(A)) stop
+if (any (lcobound(A) /= [1, -5])) call abort ()
+if (num_images() == 1) then
+  if (any (ucobound(A) /= [4, -5])) call abort ()
+! FIXME: Tree walk issue
+!else
+!  if (ucobound(A,dim=1) /= 4) call abort ()
+end if
+if (allocated(A)) i = 5
+call s(A)
+call st(A)
+contains
+subroutine s(x)
+  class(t) :: x[4,2:*]
+  if (any (lcobound(x) /= [1, 2])) call abort ()
+  if (num_images() == 1) then
+    if (any (ucobound(x) /= [4, 2])) call abort ()
+  else
+    if (ucobound(x,dim=1) /= 4) call abort ()
+  end if
+end subroutine s
+subroutine st(x)
+  class(t) :: x[:,:]
+  if (any (lcobound(x) /= [1, -5])) call abort ()
+  if (num_images() == 1) then
+    if (any (ucobound(x) /= [4, -5])) call abort ()
+  else
+    if (ucobound(x,dim=1) /= 4) call abort ()
+  end if
+end subroutine st
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_1.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_1.f90
new file mode 100644
index 0000000..03dbee7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_1.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Test for polymorphic coarrays
+!
+subroutine s2()
+  type t
+  end type t
+  class(t) :: A(:)[4,2:*] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy argument" }
+  print *, ucobound(a)
+  allocate(a) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_2.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_2.f90
new file mode 100644
index 0000000..dd5a553
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_2.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+   type t
+  end type t
+  type(t) :: a[*]
+  call test(a) ! { dg-error "Rank mismatch in argument 'x' at .1. .rank-1 and scalar." }
+contains
+  subroutine test(x)
+   class(t) :: x(:)[*]
+   print *, ucobound(x)
+  end
+end
diff --git a/gcc/testsuite/gfortran.dg/type_to_class_1.f03 b/gcc/testsuite/gfortran.dg/type_to_class_1.f03
new file mode 100644
index 0000000..173ca36
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_to_class_1.f03
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! Passing TYPE to CLASS
+!
+implicit none
+type t
+  integer :: A
+  real, allocatable :: B(:)
+end type t
+
+type(t), allocatable :: x(:)
+type(t) :: y(10)
+integer :: i
+
+allocate(x(10))
+if (size (x) /= 10) call abort ()
+x = [(t(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
+do i = 1, 10
+  if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
+      .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
+      call abort()
+  end if
+end do
+
+y = x ! TODO: Segfaults in runtime without 'y' being set
+
+call class(x)
+call classExplicit(x, size(x))
+call class(y)
+call classExplicit(y, size(y))
+
+contains
+  subroutine class(z)
+    class(t), intent(in) :: z(:)
+    select type(z)
+     type is(t)
+      if (size (z) /= 10) call abort ()
+      do i = 1, 10
+        if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
+            .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
+            call abort()
+        end if
+      end do
+      class default
+        call abort()
+    end select
+  end subroutine class
+  subroutine classExplicit(u, n)
+    integer, intent(in) :: n
+    class(t), intent(in) :: u(n)
+    select type(u)
+     type is(t)
+      if (size (u) /= 10) call abort ()
+      do i = 1, 10
+        if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
+            .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
+            call abort()
+        end if
+      end do
+      class default
+        call abort()
+    end select
+  end subroutine classExplicit
+end
+
diff --git a/gcc/testsuite/gfortran.dg/typebound_assignment_3.f03 b/gcc/testsuite/gfortran.dg/typebound_assignment_3.f03
index ce84a39..2001589 100644
--- a/gcc/testsuite/gfortran.dg/typebound_assignment_3.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_assignment_3.f03
@@ -24,7 +24,7 @@ end module
 
   use foo
   type (bar) :: foobar(2)
-  foobar = bar()           ! { dg-error "currently not implemented" }
+  foobar = bar()           ! There was a not-implemented error here 
 end
 
 ! { dg-final { cleanup-modules "foo" } }