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

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

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

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

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


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

From-SVN: r182210

1 files changed, 173 insertions, 11 deletions

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index d3f7bf3..37c653a 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -64,7 +64,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
   while (*tail != NULL)
     {
       if ((*tail)->type == REF_COMPONENT)
-	derived = (*tail)->u.c.component->ts.u.derived;
+	{
+	  if (strcmp ((*tail)->u.c.component->name, "_data") == 0
+		&& (*tail)->next
+		&& (*tail)->next->type == REF_ARRAY
+		&& (*tail)->next->next == NULL)
+	    return;
+	  derived = (*tail)->u.c.component->ts.u.derived;
+	}
       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
 	break;
       tail = &((*tail)->next);
@@ -82,6 +89,155 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
 }
 
 
+/* This is used to add both the _data component reference and an array
+   reference to class expressions.  Used in translation of intrinsic
+   array inquiry functions.  */
+
+void
+gfc_add_class_array_ref (gfc_expr *e)
+{
+  int rank =  CLASS_DATA (e)->as->rank;
+  gfc_array_spec *as = CLASS_DATA (e)->as;
+  gfc_ref *ref = NULL;
+  gfc_add_component_ref (e, "_data");
+  e->rank = rank;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (!ref->next)
+      break;
+  if (ref->type != REF_ARRAY)
+    {
+      ref->next = gfc_get_ref ();
+      ref = ref->next;
+      ref->type = REF_ARRAY;
+      ref->u.ar.type = AR_FULL;
+      ref->u.ar.as = as;	  
+    }
+}
+
+
+/* Unfortunately, class array expressions can appear in various conditions;
+   with and without both _data component and an arrayspec.  This function
+   deals with that variability.  The previous reference to 'ref' is to a
+   class array.  */
+
+static bool
+class_array_ref_detected (gfc_ref *ref, bool *full_array)
+{
+  bool no_data = false;
+  bool with_data = false;
+
+  /* An array reference with no _data component.  */
+  if (ref && ref->type == REF_ARRAY
+	&& !ref->next
+	&& ref->u.ar.type != AR_ELEMENT)
+    {
+      if (full_array)
+        *full_array = ref->u.ar.type == AR_FULL;
+      no_data = true;
+    }
+
+  /* Cover cases where _data appears, with or without an array ref.  */
+  if (ref && ref->type == REF_COMPONENT
+	&& strcmp (ref->u.c.component->name, "_data") == 0)
+    {
+      if (!ref->next)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = true;
+	}
+      else if (ref->next && ref->next->type == REF_ARRAY
+	    && !ref->next->next
+	    && ref->type == REF_COMPONENT
+	    && ref->next->type == REF_ARRAY
+	    && ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  with_data = true;
+	  if (full_array)
+	    *full_array = ref->next->u.ar.type == AR_FULL;
+	}
+    }
+
+  return no_data || with_data;
+}
+
+
+/* Returns true if the expression contains a reference to a class
+   array.  Notice that class array elements return false.  */
+
+bool
+gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
+{
+  gfc_ref *ref;
+
+  if (!e->rank)
+    return false;
+
+  if (full_array)
+    *full_array= false;
+
+  /* Is this a class array object? ie. Is the symbol of type class?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& class_array_ref_detected (e->ref, full_array))
+    return true;
+
+  /* Or is this a class array component reference?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && class_array_ref_detected (ref->next, full_array))
+	return true;
+    }
+
+  return false;
+}
+
+
+/* Returns true if the expression is a reference to a class
+   scalar.  This function is necessary because such expressions
+   can be dressed with a reference to the _data component and so
+   have a type other than BT_CLASS.  */
+
+bool
+gfc_is_class_scalar_expr (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  if (e->rank)
+    return false;
+
+  /* Is this a class object?  */
+  if (e->symtree
+	&& e->symtree->n.sym->ts.type == BT_CLASS
+	&& CLASS_DATA (e->symtree->n.sym)
+	&& !CLASS_DATA (e->symtree->n.sym)->attr.dimension
+	&& (e->ref == NULL
+	    || (strcmp (e->ref->u.c.component->name, "_data") == 0
+		&& e->ref->next == NULL)))
+    return true;
+
+  /* Or is the final reference BT_CLASS or _data?  */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS
+	    && CLASS_DATA (ref->u.c.component)
+	    && !CLASS_DATA (ref->u.c.component)->attr.dimension
+	    && (ref->next == NULL
+		|| (strcmp (ref->next->u.c.component->name, "_data") == 0
+		    && ref->next->next == NULL)))
+	return true;
+    }
+
+  return false;
+}
+
+
 /* Build a NULL initializer for CLASS pointers,
    initializing the _data component to NULL and
    the _vptr component to the declared type.  */
@@ -183,7 +339,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
-  
+
+  if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
+    {
+      gfc_error ("Assumed size polymorphic objects or components, such "
+		 "as that at %C, have not yet been implemented");
+      return FAILURE;
+    }
+
   if (attr->class_ok)
     /* Class container has already been built.  */
     return SUCCESS;
@@ -195,12 +358,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     /* We can not build the class container yet.  */
     return SUCCESS;
 
-  if (*as)
-    {
-      gfc_fatal_error ("Polymorphic array at %C not yet supported");
-      return FAILURE;
-    }
-
   /* Determine the name of the encapsulating type.  */
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && (*as)->rank && attr->allocatable)
@@ -277,8 +434,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   fclass->attr.extension = ts->u.derived->attr.extension + 1;
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
-  attr->allocatable = attr->pointer = attr->dimension = 0;
-  (*as) = NULL;  /* XXX */
+  attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
+  (*as) = NULL;
   return SUCCESS;
 }
 
@@ -402,7 +559,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
-  
+
   /* Find the top-level namespace (MODULE or PROGRAM).  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     if (!ns->parent)
@@ -556,6 +713,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  copy->attr.flavor = FL_PROCEDURE;
 		  copy->attr.subroutine = 1;
 		  copy->attr.if_source = IFSRC_DECL;
+		  /* This is elemental so that arrays are automatically
+		     treated correctly by the scalarizer.  */
+		  copy->attr.elemental = 1;
 		  if (ns->proc_name->attr.flavor == FL_MODULE)
 		    copy->module = ns->proc_name->name;
 		  gfc_set_sym_referenced (copy);
@@ -565,6 +725,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  src->ts.u.derived = derived;
 		  src->attr.flavor = FL_VARIABLE;
 		  src->attr.dummy = 1;
+		  src->attr.intent = INTENT_IN;
 		  gfc_set_sym_referenced (src);
 		  copy->formal = gfc_get_formal_arglist ();
 		  copy->formal->sym = src;
@@ -573,6 +734,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  dst->ts.u.derived = derived;
 		  dst->attr.flavor = FL_VARIABLE;
 		  dst->attr.dummy = 1;
+		  dst->attr.intent = INTENT_OUT;
 		  gfc_set_sym_referenced (dst);
 		  copy->formal->next = gfc_get_formal_arglist ();
 		  copy->formal->next->sym = dst;