Patchwork [fortran] - Arrays of classes for fortran

login
register
mail settings
Submitter Paul Richard Thomas
Date Dec. 11, 2011, 4:55 p.m.
Message ID <CAGkQGiJLgoACkZv9NPkuk-uahytK1ZvozZara0Fv697NApnWog@mail.gmail.com>
Download mbox | patch
Permalink /patch/130611/
State New
Headers show

Comments

Paul Richard Thomas - Dec. 11, 2011, 4:55 p.m.
Dear All,

I have been much longer in preparing the class array patch than
intended simply because I wanted to reach the point where it would do
something useful :-)  Well here it is. Whilst I realise that we are in
phase 3, this patch is pretty bomb-proof simply because class arrays
did not work at all, previously. Also, we are a few months from
release yet and I am sure that any significant regressions will appear
by then.

I have to confess that it is still not as consistent and well ordered
as I would like.  I started the process of cleaning up, as will be
apparent in the first, new block in trans-expr.c; when this reaches
critical mass, it will be broken out into trans-class.c.

I should record here that Tobias has been extraordinarily helpful in
providing feedback, testcases and the coarray part.

Between now and the release of 4.7, I will continue to bug fix and
clean up the implementation of class arrays.  However, I am pleased to
say that it already does better than most of the other brands that we
have had access to, with the exception of NAG. The testcase
class_array_3.f03 is a quick sort program that could be generalised to
work with any comparison operator. Only NAG was able to deal with
this.

All this said, I should record where gfortran is still broken, is a
bit untidy or does not yet produce correct code:

(i) Class subarray references usually produce ICEs. eg
  type t
   integer :: i
  end type t
  class(t),allocatable :: A(:)
  allocate (A(2))
  A(1:2)%i = [33,66]  ! <<<< HERE
end
See comment #2 of PR46356
(ii) Vector indices do not work.  See class_array_3.f03 for a place
where a do loop must be used instead of:
a = tmp(index_array), where a and tmp are class arrays.  This produces
a segfault because the class array temporary that is produced is not
allocated and, still worse is nullified. In addition, the temporary is
not necessary, since no pointers are involved and the variables are
different.  For some reason, moving the index array to the lhs, causes
the massage, "Variable must not be polymorphic in assignment at (1)"
so that the statement cannot be recognised as a defined assignment.

(iii) gfc_trans_class_array_init_assign and gfc_trans_allocate make
use of front-endery to produce a call to gfc_trans_call, in order to
benefit from the scalarizer in element by element copies.  These bits
of code can be combined with advantage and moved to (trans-)class.c.

(iv) gfc_add_loop_ss_code does not produce a temporary for class
scalars, since their size can vary according to the dynamic type.
Whilst this has not been seen to fail, it should be determined if this
works generally.

(v) build_class_array_ref is an example of a place where manipulation
of front-end expressions is used heavily to generate the class
declaration. This could be done in gfc_conv_expr by adding an gfc_se
field for the class decl and storing it on the fly.

(vi) Numerous places exist, where the new class API should be used; eg
in structure_alloc_comps.

(vii) GFC_DECL_CLASS is only set for variable declarations; field and
parm dels should be set too.

(viii) Whilst some intrinsics now work, such as LBOUND, UBOUND, SIZE,
MOVE_ALLOC, ALLOCATED and ASSOCIATED, there are still others that need
to be implemented.

(ix) match.c:5247 is a horrible expression to distinguish class
arrays. gfc_is_class_array_ref does not work there and causes numerous
regressions. This must be understood and corrected.

(x) PRs are welcome!  At least it is a sign that people are trying to
use this feature and I will do my best to fix them.

Boostrapped and regtested on x86_64/FC9 - OK for trunk?

Cheers

Paul

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/auto_dealloc_2.f90: Occurences of __builtin_free
	* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.
Tobias Burnus - Dec. 11, 2011, 6:39 p.m.
Dear Paul, dear all,

first, thanks again for the patch.

Paul Richard Thomas wrote:
> Boostrapped and regtested on x86_64/FC9 - OK for trunk?

I have now re-read the patch and it is OK from my side. It wouldn't harm 
is someone else with experience with CLASS or with the scalarizer could 
also read the patch (before or after committal).

Nits:

> 	* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
> 	now 2.	* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
> 	* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.

Missing line break after "2.".


> +   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;
> + 	  }	
> +     }

Those lines look wrongly indented.


>    /* Generate code to initialize an allocate an array.  Statements are added to

Untouched by your patch, but could you nevertheless fix the sentence by 
changing "an" to "and"?

> + #if 0
> +   if (expr->ts.type == BT_CLASS&&  expr3)
> +     {
> +       tmp = build_int_cst (unsigned_char_type_node, 0);
>
> +       /* 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..
> + 	 OOP-TODO: Determine if this is necessary or not.  */

and

> + 	  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);
> + 	    }

Can the #if 0 ... #endif block be removed? Seemingly, you have not found 
a case where it is not initialized. Additionally, I think the same 
applies to the the second quote: If there is an expr3 (i.e. MOLD= or 
SOURCE=) with a nonpolymorphic or with a polymorphic source-expr, either 
the default initialization or the assignment should take care of the 
allocatable components and similar issues.

If you really prefer to keep it (or them), can you fill a 
missed-optimization PR?


After committal, can you write a quip for 
http://gcc.gnu.org/wiki/GFortran#GCC4.7 ?
(Additionally, http://gcc.gnu.org/wiki/OOP and maybe 
http://gcc.gnu.org/wiki/Fortran2003 could be updated.)

Tobias
Paul Richard Thomas - Dec. 11, 2011, 8:46 p.m.
Dear Tobias,

On Sun, Dec 11, 2011 at 7:39 PM, Tobias Burnus <burnus@net-b.de> wrote:
> Dear Paul, dear all,
>
> first, thanks again for the patch.

Thank you for the continuous reviewing over the last couple of months
- also to Dominique, Salvatore and Damian; all of whom have kept the
test cases coming in.
>
>
> Paul Richard Thomas wrote:
>>
>> Boostrapped and regtested on x86_64/FC9 - OK for trunk?

Committed as revision 182210 with comments and corrections taken on board.

Cheers

Paul

Patch

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 182187)
--- gcc/fortran/interface.c	(working copy)
*************** done:
*** 1541,1546 ****
--- 1541,1549 ----
  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;
  }
  
*************** compare_parameter (gfc_symbol *formal, g
*** 1691,1697 ****
  
    if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
        && actual->ts.type != BT_HOLLERITH
!       && !gfc_compare_types (&formal->ts, &actual->ts))
      {
        if (where)
  	gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
--- 1694,1703 ----
  
    if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
        && actual->ts.type != BT_HOLLERITH
!       && !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",
*************** compare_parameter (gfc_symbol *formal, g
*** 1820,1825 ****
--- 1826,1835 ----
    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)
*************** compare_parameter (gfc_symbol *formal, g
*** 1829,1835 ****
    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->expr_type != EXPR_NULL)
        || (actual->rank == 0 && formal->attr.dimension
  	  && gfc_is_coindexed (actual)))
--- 1839,1849 ----
    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->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)))
*************** compare_actual_formal (gfc_actual_arglis
*** 2158,2163 ****
--- 2172,2178 ----
    gfc_formal_arglist *f;
    int i, n, na;
    unsigned long actual_size, formal_size;
+   bool full_array = false;
  
    actual = *ap;
  
*************** compare_actual_formal (gfc_actual_arglis
*** 2297,2302 ****
--- 2312,2320 ----
  	  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
*************** compare_actual_formal (gfc_actual_arglis
*** 2316,2321 ****
--- 2334,2341 ----
  	  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
*************** compare_actual_formal (gfc_actual_arglis
*** 2428,2433 ****
--- 2448,2465 ----
  	  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)
  	{
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 182187)
--- gcc/fortran/trans-expr.c	(working copy)
*************** along with GCC; see the file COPYING3.  
*** 41,46 ****
--- 41,310 ----
  #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 *);
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 799,804 ****
--- 1063,1069 ----
  	    conv_parent_component_references (se, ref);
  
  	  gfc_conv_component_ref (se, ref);
+ 
  	  break;
  
  	case REF_SUBSTRING:
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 2409,2414 ****
--- 2674,2682 ----
  		|| 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),
*************** conv_arglist_function (gfc_se *se, gfc_e
*** 2645,2708 ****
  }
  
  
- /* 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)
--- 2913,2918 ----
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2954,2959 ****
--- 3164,3182 ----
        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)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3010,3015 ****
--- 3233,3243 ----
  	    }
  	  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
  	{
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3073,3078 ****
--- 3301,3313 ----
  		{
  		  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
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3124,3129 ****
--- 3359,3375 ----
  		    }
  		}
  	    }
+ 	  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
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3188,3193 ****
--- 3434,3451 ----
  		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);
*************** gfc_conv_expr (gfc_se * se, gfc_expr * e
*** 4895,4901 ****
            expr->ts.kind = expr->ts.u.derived->ts.kind;
          }
      }
!   
    switch (expr->expr_type)
      {
      case EXPR_OP:
--- 5153,5164 ----
            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:
*************** gfc_trans_assign (gfc_code * code)
*** 6469,6474 ****
--- 6732,6767 ----
  }
  
  
+ 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.  */
*************** gfc_trans_class_init_assign (gfc_code *c
*** 6495,6512 ****
    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);
    gfc_add_expr_to_block (&block, tmp);
    
    return gfc_finish_block (&block);
--- 6788,6811 ----
    gfc_get_derived_type (rhs->ts.u.derived);
    gfc_add_def_init_component (rhs);
  
!   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);
*************** gfc_trans_class_assign (gfc_expr *expr1,
*** 6553,6561 ****
        gfc_free_expr (lhs);
        gfc_free_expr (rhs);
      }
  
    /* Do the actual CLASS assignment.  */
!   if (expr2->ts.type == BT_CLASS)
      op = EXEC_ASSIGN;
    else
      gfc_add_data_component (expr1);
--- 6852,6875 ----
        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 && !CLASS_DATA (expr2)->attr.dimension)
      op = EXEC_ASSIGN;
    else
      gfc_add_data_component (expr1);
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 182187)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 2428,2436 ****
  	  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);
  
- 	  ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
- 							 &outer_loop->pre);
  	  ss_info->string_length = se.string_length;
  	  break;
  
--- 2428,2445 ----
  	  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->string_length = se.string_length;
  	  break;
  
*************** conv_array_index_offset (gfc_se * se, gf
*** 2879,2884 ****
--- 2888,2969 ----
  }
  
  
+ /* 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
*************** gfc_conv_scalarized_array_ref (gfc_se * 
*** 2911,2916 ****
--- 2996,3007 ----
      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);
  }
  
*************** gfc_conv_descriptor_cosize (tree desc, i
*** 4592,4598 ****
  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)
  {
    tree type;
    tree tmp;
--- 4683,4690 ----
  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,
! 		     gfc_expr *expr3)
  {
    tree type;
    tree tmp;
*************** gfc_array_init_size (tree descriptor, in
*** 4747,4754 ****
      }
  
    /* 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));
    /* Convert to size_t.  */
    element_size = fold_convert (size_type_node, tmp);
  
--- 4839,4868 ----
      }
  
    /* The stride is the number of elements in the array, so multiply by the
!      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);
  
*************** gfc_array_init_size (tree descriptor, in
*** 4813,4819 ****
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen)
  {
    tree tmp;
    tree pointer;
--- 4927,4933 ----
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen, gfc_expr *expr3)
  {
    tree tmp;
    tree pointer;
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 4897,4903 ****
    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);
  
    if (dimension)
      {
--- 5011,5018 ----
    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,
! 			      expr3);
  
    if (dimension)
      {
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 4953,4959 ****
--- 5068,5088 ----
      tmp = gfc_finish_block (&elseblock);
  
    gfc_add_expr_to_block (&se->pre, tmp);
+ #if 0
+   if (expr->ts.type == BT_CLASS && expr3)
+     {
+       tmp = build_int_cst (unsigned_char_type_node, 0);
  
+       /* 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..
+ 	 OOP-TODO: Determine if this is necessary or not.  */
+       tmp = build_call_expr_loc (input_location,
+ 				 builtin_decl_explicit (BUILT_IN_MEMSET),
+ 				 3, pointer, tmp,  size);
+       gfc_add_expr_to_block (&se->pre, tmp);
+     }
+ #endif
    /* Update the array descriptors. */
    if (dimension)
      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 4972,4978 ****
    else
        gfc_add_expr_to_block (&se->pre, set_descriptor);
  
!   if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
  	&& expr->ts.u.derived->attr.alloc_comp)
      {
        tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
--- 5101,5107 ----
    else
        gfc_add_expr_to_block (&se->pre, set_descriptor);
  
!   if ((expr->ts.type == BT_DERIVED)
  	&& expr->ts.u.derived->attr.alloc_comp)
      {
        tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
*************** structure_alloc_comps (gfc_symbol * der_
*** 7240,7246 ****
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
! 	      /* Allocatable scalar CLASS components.  */
  	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
  				      decl, cdecl, NULL_TREE);
  	      
--- 7369,7375 ----
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
! 	      /* Allocatable CLASS components.  */
  	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
  				      decl, cdecl, NULL_TREE);
  	      
*************** structure_alloc_comps (gfc_symbol * der_
*** 7249,7261 ****
  	      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);
! 
! 	      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;
--- 7378,7395 ----
  	      comp = fold_build3_loc (input_location, COMPONENT_REF,
  				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
  
! 	      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));
! 		}
  	      gfc_add_expr_to_block (&fnblock, tmp);
  	    }
  	  break;
*************** structure_alloc_comps (gfc_symbol * der_
*** 7282,7298 ****
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
! 	      /* Allocatable scalar 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);
  	    }
            else if (cmp_has_alloc_comps)
  	    {
--- 7416,7437 ----
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
! 	      /* 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);
! 	      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)
  	    {
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c	(revision 182187)
--- gcc/fortran/class.c	(working copy)
*************** gfc_add_component_ref (gfc_expr *e, cons
*** 64,70 ****
    while (*tail != NULL)
      {
        if ((*tail)->type == REF_COMPONENT)
! 	derived = (*tail)->u.c.component->ts.u.derived;
        if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
  	break;
        tail = &((*tail)->next);
--- 64,77 ----
    while (*tail != NULL)
      {
        if ((*tail)->type == REF_COMPONENT)
! 	{
! 	  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);
*************** gfc_add_component_ref (gfc_expr *e, cons
*** 82,87 ****
--- 89,243 ----
  }
  
  
+ /* 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.  */
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 183,189 ****
    gfc_symbol *fclass;
    gfc_symbol *vtab;
    gfc_component *c;
!   
    if (attr->class_ok)
      /* Class container has already been built.  */
      return SUCCESS;
--- 339,352 ----
    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;
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 195,206 ****
      /* 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)
--- 358,363 ----
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 277,284 ****
    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 */
    return SUCCESS;
  }
  
--- 434,441 ----
    fclass->attr.extension = ts->u.derived->attr.extension + 1;
    fclass->attr.is_class = 1;
    ts->u.derived = fclass;
!   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
!   (*as) = NULL;
    return SUCCESS;
  }
  
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 402,408 ****
    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)
--- 559,565 ----
    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)
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 556,561 ****
--- 713,721 ----
  		  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);
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 565,570 ****
--- 725,731 ----
  		  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;
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 573,578 ****
--- 734,740 ----
  		  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;
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 182187)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_array_deallocate (tree, tree, g
*** 24,30 ****
  
  /* Generate code to initialize an 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);
  
  /* 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 *,
--- 24,30 ----
  
  /* Generate code to initialize an 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, 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 *,
Index: gcc/fortran/array.c
===================================================================
*** gcc/fortran/array.c	(revision 182187)
--- gcc/fortran/array.c	(working copy)
*************** gfc_array_dimen_size (gfc_expr *array, i
*** 2112,2117 ****
--- 2112,2120 ----
    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");
  
*************** gfc_array_size (gfc_expr *array, mpz_t *
*** 2190,2195 ****
--- 2193,2201 ----
    int i;
    gfc_try t;
  
+   if (array->ts.type == BT_CLASS)
+     return FAILURE;
+ 
    switch (array->expr_type)
      {
      case EXPR_ARRAY:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 182187)
--- gcc/fortran/gfortran.h	(working copy)
*************** gfc_try gfc_calculate_transfer_sizes (gf
*** 2911,2921 ****
--- 2911,2924 ----
  
  /* 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 *,
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 182187)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1093,1106 ****
  {
    gfc_expr *e;
    tree tmp;
  
    gcc_assert (sym->assoc);
    e = sym->assoc->target;
  
    /* 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
        && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
      {
        gfc_se se;
--- 1093,1111 ----
  {
    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 && !class_target
        && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
      {
        gfc_se se;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1140,1145 ****
--- 1145,1167 ----
  			    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))
      {
*************** tree
*** 4677,4682 ****
--- 4699,4705 ----
  gfc_trans_allocate (gfc_code * code)
  {
    gfc_alloc *al;
+   gfc_expr *e;
    gfc_expr *expr;
    gfc_se se;
    tree tmp;
*************** gfc_trans_allocate (gfc_code * code)
*** 4748,4754 ****
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
  
!       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
  	{
  	  /* A scalar or derived type.  */
  
--- 4771,4777 ----
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
  
!       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
  	{
  	  /* A scalar or derived type.  */
  
*************** gfc_trans_allocate (gfc_code * code)
*** 4878,4883 ****
--- 4901,4916 ----
  	      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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4901,4906 ****
--- 4934,4993 ----
  	  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
*************** gfc_trans_allocate (gfc_code * code)
*** 4908,4917 ****
  	  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);
  	      /* Do a polymorphic deep copy.  */
  	      actual = gfc_get_actual_arglist ();
  	      actual->expr = gfc_copy_expr (rhs);
--- 4995,5005 ----
  	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
  	  if (al->expr->ts.type == BT_CLASS)
  	    {
  	      gfc_actual_arglist *actual;
  	      gfc_expr *ppc;
! 	      gfc_code *ppc_code;
! 	      gfc_ref *dataref;
! 
  	      /* Do a polymorphic deep copy.  */
  	      actual = gfc_get_actual_arglist ();
  	      actual->expr = gfc_copy_expr (rhs);
*************** gfc_trans_allocate (gfc_code * code)
*** 4919,4938 ****
  		gfc_add_data_component (actual->expr);
  	      actual->next = gfc_get_actual_arglist ();
  	      actual->next->expr = gfc_copy_expr (al->expr);
  	      gfc_add_data_component (actual->next->expr);
  	      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));
  	      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);
  	    }
  	  else if (expr3 != NULL_TREE)
  	    {
--- 5007,5064 ----
  		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));
  	      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.  */
! 	      tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
! 	      gfc_free_statements (ppc_code);
  	    }
  	  else if (expr3 != NULL_TREE)
  	    {
*************** gfc_trans_allocate (gfc_code * code)
*** 4972,5030 ****
  	  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).  */
--- 5098,5104 ----
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 182187)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_get_corank (gfc_expr *e)
*** 4309,4315 ****
    if (!gfc_is_coarray (e))
      return 0;
  
!   corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
  
    for (ref = e->ref; ref; ref = ref->next)
      {
--- 4309,4319 ----
    if (!gfc_is_coarray (e))
      return 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)
      {
*************** gfc_is_simply_contiguous (gfc_expr *expr
*** 4394,4399 ****
--- 4398,4404 ----
    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
*************** gfc_is_simply_contiguous (gfc_expr *expr
*** 4417,4427 ****
  	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)))
      return false;
  
    if (!ar || ar->type == AR_FULL)
--- 4422,4436 ----
  	ar = &ref->u.ar;
      }
  
!   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)
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 182187)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 315,320 ****
--- 315,321 ----
  {
    tree type = TREE_TYPE (base);
    tree tmp;
+   tree span;
  
    if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
      {
*************** gfc_build_array_ref (tree base, tree off
*** 345,356 ****
    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)))
      {
        offset = fold_build2_loc (input_location, MULT_EXPR,
  				gfc_array_index_type,
! 				offset, GFC_DECL_SPAN(decl));
        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);
--- 346,378 ----
    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_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, 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);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 182187)
--- gcc/fortran/trans.h	(working copy)
*************** typedef struct
*** 333,338 ****
--- 333,346 ----
  }
  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);
*************** struct GTY((variable_size)) lang_decl {
*** 803,808 ****
--- 811,817 ----
  #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)
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 182187)
--- gcc/fortran/resolve.c	(working copy)
*************** check_typebound_baseobject (gfc_expr* e)
*** 5584,5597 ****
        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:
--- 5584,5589 ----
*************** resolve_allocate_expr (gfc_expr *e, gfc_
*** 6765,6771 ****
      }
    else
      {
!       if (sym->ts.type == BT_CLASS)
  	{
  	  allocatable = CLASS_DATA (sym)->attr.allocatable;
  	  pointer = CLASS_DATA (sym)->attr.class_pointer;
--- 6757,6763 ----
      }
    else
      {
!       if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
  	{
  	  allocatable = CLASS_DATA (sym)->attr.allocatable;
  	  pointer = CLASS_DATA (sym)->attr.class_pointer;
*************** resolve_allocate_expr (gfc_expr *e, gfc_
*** 6911,6917 ****
    if (t == FAILURE)
      goto failure;
  
!   if (!code->expr3)
      {
        /* Set up default initializer if needed.  */
        gfc_typespec ts;
--- 6903,6918 ----
    if (t == FAILURE)
      goto failure;
  
!   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;
*************** resolve_allocate_expr (gfc_expr *e, gfc_
*** 6955,6960 ****
--- 6956,6963 ----
        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)
*************** resolve_select (gfc_code *code)
*** 7531,7546 ****
        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.  */
--- 7534,7539 ----
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 7825,7830 ****
--- 7818,7826 ----
        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
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 7839,7845 ****
  			  && !gfc_has_vector_subscript (target));
  
    /* Finally resolve if this is an array or not.  */
!   if (sym->attr.dimension && target->rank == 0)
      {
        gfc_error ("Associate-name '%s' at %L is used as array",
  		 sym->name, &sym->declared_at);
--- 7835,7844 ----
  			  && !gfc_has_vector_subscript (target));
  
    /* Finally resolve if this is an array or not.  */
!   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);
*************** resolve_select_type (gfc_code *code, gfc
*** 7955,7960 ****
--- 7954,7960 ----
        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;
*************** resolve_select_type (gfc_code *code, gfc
*** 8006,8011 ****
--- 8006,8012 ----
        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);
  
*************** resolve_fl_derived0 (gfc_symbol *sym)
*** 11432,11438 ****
    for (c = sym->components; c != NULL; c = c->next)
      {
        /* F2008, C442.  */
!       if (c->attr.codimension /* FIXME: c->as check due to PR 43412.  */
  	  && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
  	{
  	  gfc_error ("Coarray component '%s' at %L must be allocatable with "
--- 11433,11440 ----
    for (c = sym->components; c != NULL; c = c->next)
      {
        /* F2008, C442.  */
!       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 "
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 182187)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1293,1299 ****
  	  && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
  	gfc_nonlocal_dummy_array_decl (sym);
  
!       return sym->backend_decl;
      }
  
    if (sym->backend_decl)
--- 1293,1304 ----
  	  && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
  	gfc_nonlocal_dummy_array_decl (sym);
  
!       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)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1314,1320 ****
  	&& !intrinsic_array_parameter
  	&& sym->module
  	&& gfc_get_module_backend_decl (sym))
!     return sym->backend_decl;
  
    if (sym->attr.flavor == FL_PROCEDURE)
      {
--- 1319,1329 ----
  	&& !intrinsic_array_parameter
  	&& sym->module
  	&& gfc_get_module_backend_decl (sym))
!     {
!       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)
      {
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1431,1436 ****
--- 1440,1448 ----
        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)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3656,3661 ****
--- 3668,3677 ----
  	    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)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3669,3676 ****
  		gfc_add_data_component (e);
  
  	      gfc_init_se (&se, NULL);
! 	      se.want_pointer = 1;
! 	      gfc_conv_expr (&se, e);
  	      gfc_free_expr (e);
  
  	      gfc_save_backend_locus (&loc);
--- 3685,3710 ----
  		gfc_add_data_component (e);
  
  	      gfc_init_se (&se, NULL);
! 	      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);
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 182187)
--- gcc/fortran/match.c	(working copy)
*************** select_type_set_tmp (gfc_typespec *ts)
*** 5151,5156 ****
--- 5151,5177 ----
      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;
*************** gfc_match_select_type (void)
*** 5176,5181 ****
--- 5197,5203 ----
    gfc_expr *expr1, *expr2 = NULL;
    match m;
    char name[GFC_MAX_SYMBOL_LEN];
+   bool class_array;
  
    m = gfc_match_label ();
    if (m == MATCH_ERROR)
*************** gfc_match_select_type (void)
*** 5216,5223 ****
    if (m != MATCH_YES)
      goto cleanup;
  
    /* Check for F03:C811.  */
!   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
      {
        gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
  		 "use associate-name=>");
--- 5238,5261 ----
    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
! 		  || (!class_array && expr1->ref != NULL)))
      {
        gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
  		 "use associate-name=>");
Index: gcc/fortran/check.c
===================================================================
*** gcc/fortran/check.c	(revision 182187)
--- gcc/fortran/check.c	(working copy)
*************** logical_array_check (gfc_expr *array, in
*** 240,245 ****
--- 240,253 ----
  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;
  
*************** dim_corank_check (gfc_expr *dim, gfc_exp
*** 554,559 ****
--- 562,570 ----
  
    if (dim->expr_type != EXPR_CONSTANT)
      return SUCCESS;
+   
+   if (array->ts.type == BT_CLASS)
+     return SUCCESS;
  
    corank = gfc_get_corank (array);
  
*************** dim_rank_check (gfc_expr *dim, gfc_expr 
*** 587,592 ****
--- 598,606 ----
    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;
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 182187)
--- gcc/fortran/primary.c	(working copy)
*************** gfc_match_varspec (gfc_expr *primary, in
*** 1789,1801 ****
  
    if (gfc_peek_ascii_char () == '[')
      {
!       if (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)
  	{
  	  gfc_error ("Coarray designator at %C but '%s' is not a coarray",
  		     sym->name);
--- 1789,1805 ----
  
    if (gfc_peek_ascii_char () == '[')
      {
!       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->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);
*************** gfc_match_varspec (gfc_expr *primary, in
*** 1827,1833 ****
  
        m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
  			       equiv_flag,
! 			       sym->ts.type == BT_CLASS
  			       ? (CLASS_DATA (sym)->as
  				  ? CLASS_DATA (sym)->as->corank : 0)
  			       : (sym->as ? sym->as->corank : 0));
--- 1831,1837 ----
  
        m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
  			       equiv_flag,
! 			       sym->ts.type == BT_CLASS && CLASS_DATA (sym)
  			       ? (CLASS_DATA (sym)->as
  				  ? CLASS_DATA (sym)->as->corank : 0)
  			       : (sym->as ? sym->as->corank : 0));
*************** gfc_match_rvalue (gfc_expr **result)
*** 2909,2914 ****
--- 2913,2934 ----
  	  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.  */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 182187)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_intrinsic_size (gfc_se * se, gf
*** 5028,5033 ****
--- 5028,5036 ----
    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;
*************** gfc_conv_allocated (gfc_se *se, gfc_expr
*** 5667,5680 ****
  
    gfc_init_se (&arg1se, NULL);
    arg1 = expr->value.function.actual;
    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;
      }
--- 5670,5693 ----
  
    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;
        gfc_conv_expr (&arg1se, arg1->expr);
        tmp = arg1se.expr;
      }
*************** gfc_add_intrinsic_ss_code (gfc_loopinfo 
*** 6998,7003 ****
--- 7011,7019 ----
  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;
Index: gcc/fortran/simplify.c
===================================================================
*** gcc/fortran/simplify.c	(revision 182187)
--- gcc/fortran/simplify.c	(working copy)
*************** simplify_bound (gfc_expr *array, gfc_exp
*** 3326,3331 ****
--- 3326,3334 ----
    gfc_array_spec *as;
    int d;
  
+   if (array->ts.type == BT_CLASS)
+     return NULL;
+ 
    if (array->expr_type != EXPR_VARIABLE)
      {
        as = NULL;
*************** simplify_cobound (gfc_expr *array, gfc_e
*** 3462,3468 ****
      return NULL;
  
    /* Follow any component references.  */
!   as = array->symtree->n.sym->as;
    for (ref = array->ref; ref; ref = ref->next)
      {
        switch (ref->type)
--- 3465,3473 ----
      return NULL;
  
    /* Follow any component references.  */
!   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)
*************** simplify_cobound (gfc_expr *array, gfc_e
*** 3506,3516 ****
  	}
      }
  
!   gcc_unreachable ();
  
   done:
  
!   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
      return NULL;
  
    if (dim == NULL)
--- 3511,3522 ----
  	}
      }
  
!   if (!as)
!     gcc_unreachable ();
  
   done:
  
!   if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
      return NULL;
  
    if (dim == NULL)
*************** simplify_cobound (gfc_expr *array, gfc_e
*** 3523,3529 ****
        /* Simplify the cobounds for each dimension.  */
        for (d = 0; d < as->corank; d++)
  	{
! 	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
  					  upper, as, ref, true);
  	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
  	    {
--- 3529,3535 ----
        /* Simplify the cobounds for each dimension.  */
        for (d = 0; d < as->corank; d++)
  	{
! 	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
  					  upper, as, ref, true);
  	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
  	    {
*************** simplify_cobound (gfc_expr *array, gfc_e
*** 3575,3581 ****
  	  return &gfc_bad_expr;
  	}
  
!       return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
      }
  }
  
--- 3581,3587 ----
  	  return &gfc_bad_expr;
  	}
  
!       return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
      }
  }
  
Index: gcc/testsuite/gfortran.dg/class_array_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_5.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_5.f03	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/coarray_poly_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/coarray_poly_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/coarray_poly_1.f90	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/class_array_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_7.f03	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/class_to_type_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_to_type_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_to_type_1.f03	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/class_array_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_2.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_2.f03	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/class_array_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_4.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_4.f03	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/class_array_6.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_6.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_6.f03	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/coarray_poly_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/coarray_poly_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/coarray_poly_2.f90	(revision 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
Index: gcc/testsuite/gfortran.dg/class_array_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_8.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_8.f03	(revision 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
Index: gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/auto_dealloc_2.f90	(revision 182187)
--- gcc/testsuite/gfortran.dg/auto_dealloc_2.f90	(working copy)
*************** contains
*** 25,29 ****
  
  end program 
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
--- 25,29 ----
  
  end program 
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/type_to_class_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/type_to_class_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/type_to_class_1.f03	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/typebound_assignment_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_assignment_3.f03	(revision 182187)
--- gcc/testsuite/gfortran.dg/typebound_assignment_3.f03	(working copy)
*************** end module
*** 24,30 ****
  
    use foo
    type (bar) :: foobar(2)
!   foobar = bar()           ! { dg-error "currently not implemented" }
  end
  
  ! { dg-final { cleanup-modules "foo" } }
--- 24,30 ----
  
    use foo
    type (bar) :: foobar(2)
!   foobar = bar()           ! There was a not-implemented error here 
  end
  
  ! { dg-final { cleanup-modules "foo" } }
Index: gcc/testsuite/gfortran.dg/class_array_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_1.f03	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/class_19.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_19.f03	(revision 182187)
--- gcc/testsuite/gfortran.dg/class_19.f03	(working copy)
*************** program main
*** 39,45 ****
  
  end program main
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  
  ! { dg-final { cleanup-modules "foo_mod" } }
--- 39,45 ----
  
  end program main
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  
  ! { dg-final { cleanup-modules "foo_mod" } }
Index: gcc/testsuite/gfortran.dg/class_array_3.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_array_3.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_array_3.f03	(revision 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" } }