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

	Tobias Burnus  <burnus@gcc.gnu.org>

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

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

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



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

1 files changed, 145 insertions, 20 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8624d96a32..d4411024768 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2428,9 +2428,18 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  gfc_conv_expr (&se, expr);
 	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
 	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  if (gfc_is_class_scalar_expr (expr))
+	    /* This is necessary because the dynamic type will always be
+	       large than the declared type.  In consequence, assigning
+	       the value to a temporary could segfault.
+	       OOP-TODO: see if this is generally correct or is the value
+	       has to be written to an allocated temporary, whose address
+	       is passed via ss_info.  */
+	    ss_info->data.scalar.value = se.expr;
+	  else
+	    ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
+							   &outer_loop->pre);
 
-	  ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
-							 &outer_loop->pre);
 	  ss_info->string_length = se.string_length;
 	  break;
 
@@ -2879,6 +2888,82 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
 }
 
 
+/* Build a scalarized array reference using the vptr 'size'.  */
+
+static bool
+build_class_array_ref (gfc_se *se, tree base, tree index)
+{
+  tree type;
+  tree size;
+  tree offset;
+  tree decl;
+  tree tmp;
+  gfc_expr *expr = se->ss->info->expr;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+  gfc_typespec *ts;
+
+  if (expr == NULL || expr->ts.type != BT_CLASS)
+    return false;
+
+  if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+    ts = &expr->symtree->n.sym->ts;
+  else
+    ts = NULL;
+  class_ref = NULL;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && ref->next && ref->next->type == REF_COMPONENT
+	    && strcmp (ref->next->u.c.component->name, "_data") == 0
+	    && ref->next->next
+	    && ref->next->next->type == REF_ARRAY
+	    && ref->next->next->u.ar.type != AR_ELEMENT)
+	{
+	  ts = &ref->u.c.component->ts;
+	  class_ref = ref;
+	  break;
+	}	   
+    }
+
+  if (ts == NULL)
+    return false;
+
+  if (class_ref == NULL)
+    decl = expr->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, expr);
+      decl = tmpse.expr;
+      class_ref->next = ref;
+    }
+
+  size = gfc_vtable_size_get (decl);
+
+  /* Build the address of the element.  */
+  type = TREE_TYPE (TREE_TYPE (base));
+  size = fold_convert (TREE_TYPE (index), size);
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    index, size);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+
+  /* Return the element in the se expression.  */
+  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  return true;
+}
+
+
 /* Build a scalarized reference to an array.  */
 
 static void
@@ -2911,6 +2996,12 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
     decl = expr->symtree->n.sym->backend_decl;
 
   tmp = build_fold_indirect_ref_loc (input_location, info->data);
+
+  /* Use the vptr 'size' field to access a class the element of a class
+     array.  */
+  if (build_class_array_ref (se, tmp, index))
+    return;
+
   se->expr = gfc_build_array_ref (tmp, index, decl);
 }
 
@@ -4592,7 +4683,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
-		     stmtblock_t * descriptor_block, tree * overflow)
+		     stmtblock_t * descriptor_block, tree * overflow,
+		     gfc_expr *expr3)
 {
   tree type;
   tree tmp;
@@ -4747,8 +4839,30 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
     }
 
   /* The stride is the number of elements in the array, so multiply by the
-     size of an element to get the total size.  */
-  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+     size of an element to get the total size.  Obviously, if there ia a
+     SOURCE expression (expr3) we must use its element size.  */
+  if (expr3 != NULL)
+    {
+      if (expr3->ts.type == BT_CLASS)
+	{
+	  gfc_se se_sz;
+	  gfc_expr *sz = gfc_copy_expr (expr3);
+	  gfc_add_vptr_component (sz);
+	  gfc_add_size_component (sz);
+	  gfc_init_se (&se_sz, NULL);
+	  gfc_conv_expr (&se_sz, sz);
+	  gfc_free_expr (sz);
+	  tmp = se_sz.expr;
+	}
+      else
+	{
+	  tmp = gfc_typenode_for_spec (&expr3->ts);
+	  tmp = TYPE_SIZE_UNIT (tmp);
+	}
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
   /* Convert to size_t.  */
   element_size = fold_convert (size_type_node, tmp);
 
@@ -4813,7 +4927,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
-		    tree errlen)
+		    tree errlen, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -4897,7 +5011,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_init_block (&set_descriptor_block);
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
-			      &se->pre, &set_descriptor_block, &overflow);
+			      &se->pre, &set_descriptor_block, &overflow,
+			      expr3);
 
   if (dimension)
     {
@@ -4972,7 +5087,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   else
       gfc_add_expr_to_block (&se->pre, set_descriptor);
 
-  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+  if ((expr->ts.type == BT_DERIVED)
 	&& expr->ts.u.derived->attr.alloc_comp)
     {
       tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
@@ -7240,7 +7355,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
-	      /* Allocatable scalar CLASS components.  */
+	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 	      
@@ -7249,13 +7364,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
 
-	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
-						       CLASS_DATA (c)->ts);
-	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+	        tmp = gfc_trans_dealloc_allocated (comp);
+	      else
+		{
+		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+							   CLASS_DATA (c)->ts);
+		  gfc_add_expr_to_block (&fnblock, tmp);
 
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		}
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  break;
@@ -7282,17 +7402,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
-	      /* Allocatable scalar CLASS components.  */
+	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 	      /* Add reference to '_data' component.  */
 	      tmp = CLASS_DATA (c)->backend_decl;
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
-	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
+		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	      else
+		{
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
 	    }
           else if (cmp_has_alloc_comps)
 	    {