Re: [PATCH] Fix PR64980 and PR61960

[Mikael Morin <mikael dot morin at sfr dot fr>]

Le 20/02/2015 22:50, Mikael Morin a écrit :
> Le 16/02/2015 21:18, Bernd Edlinger a écrit :
>>
>> again, with attachments,
>> sorry.
>>
>>
>>>
>>> Hi,
>>>
>>>
>>> this patch fixes PR64980 and PR61960 at the same time.
>>>
>>> The unreduced test case for PR64230 is also included, because a previous version
>>> of this patch caused this test to fail but the complete test suite passed without any
>>> indication of any problem.
>>>
> Hello Bernd,
> 
> I think the testcases can do without any VIEW_CONVERT_EXPR at all.
> I'm currently trying to avoid them with the attached patch, which is not
> free of regressions unfortunately.

I finally arrived to the attached patch.
It may be a bit risky, and with the release preparation stage in mind, I
realize that your patch is probably the better alternative.
So your patch is OK for trunk.

Mikael

Index: trans-expr.c
===================================================================
--- trans-expr.c	(révision 220717)
+++ trans-expr.c	(copie de travail)
@@ -496,81 +496,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp
 }
 
 
-/* Create a new class container, which is required as scalar coarrays
-   have an array descriptor while normal scalars haven't. Optionally,
-   NULL pointer checks are added if the argument is OPTIONAL.  */
-
-static void
-class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
-			       gfc_typespec class_ts, bool optional)
-{
-  tree var, ctree, tmp;
-  stmtblock_t block;
-  gfc_ref *ref;
-  gfc_ref *class_ref;
-
-  gfc_init_block (&block);
-
-  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 (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;
-    }
-
-  var = gfc_typenode_for_spec (&class_ts);
-  var = gfc_create_var (var, "class");
-
-  ctree = gfc_class_vptr_get (var);
-  gfc_add_modify (&block, ctree,
-		  fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
-
-  ctree = gfc_class_data_get (var);
-  tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
-  gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
-
-  /* Pass the address of the class object.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
-
-  if (optional)
-    {
-      tree cond = gfc_conv_expr_present (e->symtree->n.sym);
-      tree tmp2;
-
-      tmp = gfc_finish_block (&block);
-
-      gfc_init_block (&block);
-      tmp2 = gfc_class_data_get (var);
-      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
-						  null_pointer_node));
-      tmp2 = gfc_finish_block (&block);
-
-      tmp = build3_loc (input_location, COND_EXPR, void_type_node,
-			cond, tmp, tmp2);
-      gfc_add_expr_to_block (&parmse->pre, tmp);
-    }
-  else
-    gfc_add_block_to_block (&parmse->pre, &block);
-}
-
-
 /* Takes an intrinsic type expression and returns the address of a temporary
    class object of the 'declared' type.  */
 void
@@ -686,6 +611,35 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_e
 }
 
 
+static void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+
+static void
+access_parent_derived_type (gfc_se *se, gfc_symbol *base_type,
+			    gfc_symbol *extended_type)
+{
+  gfc_ref ref;
+
+  memset (&ref, 0, sizeof (ref));
+
+  while (!gfc_compare_derived_types (base_type, extended_type))
+    {
+      if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+						    
+      ref.u.c.component = extended_type->components;
+      ref.u.c.sym = extended_type;
+      gfc_conv_component_ref (se, &ref);
+
+      if (!POINTER_TYPE_P (TREE_TYPE (se->expr)))
+	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+
+      gcc_assert (extended_type->components->ts.type == BT_CLASS
+		  || extended_type->components->ts.type == BT_DERIVED);
+      extended_type = gfc_get_derived_super_type (extended_type);
+    }
+}
+
+
 /* Takes a scalarized class array expression and returns the
    address of a temporary scalar class object of the 'declared'
    type.
@@ -706,30 +660,29 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
   tree var;
   tree tmp;
   tree vptr;
+  tree orig_expr = parmse->expr;
   tree cond = NULL_TREE;
   gfc_ref *ref;
-  gfc_ref *class_ref;
+  gfc_ref **class_subref = NULL;
   stmtblock_t block;
   bool full_array = false;
 
   gfc_init_block (&block);
 
-  class_ref = NULL;
-  for (ref = e->ref; ref; ref = ref->next)
+  if (e->expr_type == EXPR_VARIABLE)
     {
-      if (ref->type == REF_COMPONENT
-	    && ref->u.c.component->ts.type == BT_CLASS)
-	class_ref = ref;
+      if (e->symtree
+	  && e->symtree->n.sym->ts.type == BT_CLASS)
+	class_subref = &e->ref;
 
-      if (ref->next == NULL)
-	break;
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->ts.type == BT_CLASS)
+	    class_subref = &ref->next;
+	}
     }
 
-  if ((ref == NULL || class_ref == ref)
-      && (!class_ts.u.derived->components->as
-	  || class_ts.u.derived->components->as->rank != -1))
-    return;
-
   /* Test for FULL_ARRAY.  */
   if (e->rank == 0 && gfc_expr_attr (e).codimension
       && gfc_expr_attr (e).dimension)
@@ -765,9 +718,40 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
     }
   else
     {
-      if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
+      if (!class_ts.u.derived->components->as)
+	{
+	  gfc_symbol *dt_sym;
+	  gfc_symbol *dummy_sym = class_ts.u.derived->components->ts.u.derived;
+
+	  if (class_subref
+	      && (*class_subref)
+	      && (*class_subref)->next)
+	    gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+	  else
+	    parmse->expr = gfc_class_data_get (parmse->expr);
+
+	  dt_sym = CLASS_DATA (e)->ts.u.derived;
+
+	  if (!dummy_sym->attr.unlimited_polymorphic
+	      && gfc_type_is_extension_of (dummy_sym, dt_sym))
+	    access_parent_derived_type (parmse, dummy_sym, dt_sym);
+	}
+
+      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr))
+	  && !POINTER_TYPE_P (TREE_TYPE (ctree)))
+	parmse->expr = build_fold_indirect_ref_loc (input_location,
+						    parmse->expr);
+
+      if (TYPE_CANONICAL (TREE_TYPE (ctree))
+	  != TYPE_CANONICAL (TREE_TYPE (parmse->expr))
+	  || TYPE_MAIN_VARIANT (TREE_TYPE (ctree))
+	     != TYPE_MAIN_VARIANT (TREE_TYPE (parmse->expr))
+	  || (TREE_TYPE (ctree) != TREE_TYPE (parmse->expr)
+	      && AGGREGATE_TYPE_P (ctree)))
 	parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 					TREE_TYPE (ctree), parmse->expr);
+      else if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
+	parmse->expr = fold_convert (TREE_TYPE (ctree), parmse->expr);
       gfc_add_modify (&block, ctree, parmse->expr);
     }
 
@@ -796,19 +780,18 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
      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;
+  if (class_subref == NULL || *class_subref == NULL)
+    tmp = orig_expr;
   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_ref *r = *class_subref;
+      *class_subref = NULL;
       gfc_init_se (&tmpse, NULL);
       gfc_conv_expr (&tmpse, e);
-      class_ref->next = ref;
+      *class_subref = r;
       tmp = tmpse.expr;
     }
 
@@ -841,7 +824,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
 	{
 	  gfc_init_block (&block);
 
-	  tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+	  if (!class_ts.u.derived->components->as)
+	    tmp2 = gfc_class_data_get (var);
+	  else
+	    tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+
 	  gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
 						      null_pointer_node));
 	  tmp2 = gfc_finish_block (&block);
@@ -3783,10 +3770,6 @@ gfc_apply_interface_mapping_to_expr (gfc_interface
 	  expr->symtree = sym->new_sym;
 	else if (sym->expr)
 	  gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
-	/* Replace base type for polymorphic arguments.  */
-	if (expr->ref && expr->ref->type == REF_COMPONENT
-	    && sym->expr && sym->expr->ts.type == BT_CLASS)
-	  expr->ref->u.c.sym = sym->expr->ts.u.derived;
       }
 
       /* ...and to subexpressions in expr->value.  */
@@ -4155,6 +4138,61 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr,
 }
 
 
+static bool
+class_container_needed (gfc_symbol *fsym, gfc_expr *e)
+{
+  gfc_ref **class_subref = NULL, *ref;
+
+  if (!fsym || fsym->ts.type != BT_CLASS || e->ts.type != BT_CLASS)
+    return false;
+
+  if (UNLIMITED_POLY (fsym) && !UNLIMITED_POLY (e))
+    return true;
+
+  if (CLASS_DATA (fsym)->as && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK
+      && !(CLASS_DATA (e)->as && CLASS_DATA (e)->as->type == AS_ASSUMED_RANK))
+    return true;
+
+  if (!UNLIMITED_POLY (fsym)
+      && !gfc_compare_derived_types (CLASS_DATA (fsym)->ts.u.derived,
+				     CLASS_DATA (e)->ts.u.derived))
+    return true;
+
+  if (gfc_expr_attr (e).allocatable && !CLASS_DATA (fsym)->attr.allocatable)
+    return true;
+
+  if (gfc_expr_attr (e).pointer != CLASS_DATA (fsym)->attr.class_pointer)
+    return true;
+
+  if (gfc_expr_attr (e).target
+      && !fsym->attr.target
+      && !CLASS_DATA (fsym)->attr.class_pointer)
+    return true;
+
+  if (e->expr_type == EXPR_VARIABLE)
+    {
+      if (e->symtree->n.sym->ts.type == BT_CLASS)
+	class_subref = &e->ref;
+
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS)
+	    class_subref = &ref->next;
+	}
+
+      gcc_assert (class_subref);
+      if (*class_subref && (*class_subref)->next)
+	{
+	  gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+	  return true;
+	}
+    }
+
+  return false;
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -4522,72 +4560,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 		}
 	      else
 		{
-		  if (e->ts.type == BT_CLASS && fsym
-		      && fsym->ts.type == BT_CLASS
-		      && (!CLASS_DATA (fsym)->as
-			  || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
-		      && CLASS_DATA (e)->attr.codimension)
-		    {
-		      gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
-		      gcc_assert (!CLASS_DATA (fsym)->as);
-		      gfc_add_class_array_ref (e);
-		      parmse.want_coarray = 1;
-		      gfc_conv_expr_reference (&parmse, e);
-		      class_scalar_coarray_to_class (&parmse, e, fsym->ts,
-				     fsym->attr.optional
-				     && e->expr_type == EXPR_VARIABLE);
-		    }
-		  else if (e->ts.type == BT_CLASS && fsym
-			   && fsym->ts.type == BT_CLASS
-			   && !CLASS_DATA (fsym)->as
-			   && !CLASS_DATA (e)->as
-			   && (CLASS_DATA (fsym)->attr.class_pointer
-			       != CLASS_DATA (e)->attr.class_pointer
-			       || CLASS_DATA (fsym)->attr.allocatable
-				  != CLASS_DATA (e)->attr.allocatable))
-		    {
-		      type = gfc_typenode_for_spec (&fsym->ts);
-		      var = gfc_create_var (type, fsym->name);
-		      gfc_conv_expr (&parmse, e);
-		      if (fsym->attr.optional
-			  && e->expr_type == EXPR_VARIABLE
-			  && e->symtree->n.sym->attr.optional)
-			{
-			  stmtblock_t block;
-			  tree cond;
-			  tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
-			  cond = fold_build2_loc (input_location, NE_EXPR,
-						  boolean_type_node, tmp,
-						  fold_convert (TREE_TYPE (tmp),
-							    null_pointer_node));
-			  gfc_start_block (&block);
-			  gfc_add_modify (&block, var,
-					  fold_build1_loc (input_location,
-							   VIEW_CONVERT_EXPR,
-							   type, parmse.expr));
-			  gfc_add_expr_to_block (&parmse.pre,
-				 fold_build3_loc (input_location,
-					 COND_EXPR, void_type_node,
-					 cond, gfc_finish_block (&block),
-					 build_empty_stmt (input_location)));
-			  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
-			  parmse.expr = build3_loc (input_location, COND_EXPR,
-					 TREE_TYPE (parmse.expr),
-					 cond, parmse.expr,
-					 fold_convert (TREE_TYPE (parmse.expr),
-						       null_pointer_node));
-			}
-		      else
-			{
-			  gfc_add_modify (&parmse.pre, var,
-					  fold_build1_loc (input_location,
-							   VIEW_CONVERT_EXPR,
-							   type, parmse.expr));
-			  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
-			}
-		    }
-		  else
-		    gfc_conv_expr_reference (&parmse, e);
+		  gfc_conv_expr_reference (&parmse, e);
 
 		  /* Catch base objects that are not variables.  */
 		  if (e->ts.type == BT_CLASS
@@ -4598,11 +4571,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 
 		  /* 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 (fsym)->as
-			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
-			    || CLASS_DATA (e)->attr.dimension))
+		  if (class_container_needed (fsym, e))
 		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
 				     fsym->attr.intent != INTENT_IN
 				     && (CLASS_DATA (fsym)->attr.class_pointer