Re: [PATCH] Fix PR64980 and PR61960

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

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.
Give me couple of days to see whether I can push this to the end.
Otherwise, your patch will be good enough.

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,9 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_e
 }
 
 
+static void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+
+
 /* Takes a scalarized class array expression and returns the
    address of a temporary scalar class object of the 'declared'
    type.
@@ -706,30 +634,28 @@ 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;
   stmtblock_t block;
   bool full_array = false;
 
   gfc_init_block (&block);
 
-  class_ref = NULL;
+  if (e->symtree
+      && e->symtree->n.sym->ts.type == BT_CLASS)
+    class_subref = &e->ref;
+  else
+    class_subref = 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;
+	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 +691,57 @@ 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;
+	  gfc_ref ref;
+
+	  if ((*class_subref)
+	      && (*class_subref)->next)
+	    {
+	      gcc_assert ((*class_subref)->next->type == REF_ARRAY);
+	      dt_sym = e->ts.u.derived->components->ts.u.derived;
+	    }
+	  else
+	    dt_sym = e->ts.u.derived;
+
+	  memset (&ref, 0, sizeof (ref));
+
+	  while (!gfc_compare_derived_types (dt_sym, dummy_sym))
+	    {
+	      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+		parmse->expr = build_fold_indirect_ref_loc (input_location,
+							    parmse->expr);
+							    
+	      ref.u.c.component = dt_sym->components;
+	      ref.u.c.sym = dt_sym;
+	      gfc_conv_component_ref (parmse, &ref);
+
+	      if (!POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+		parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+
+	      gcc_assert (dt_sym->components->ts.type == BT_CLASS
+			  || dt_sym->components->ts.type == BT_DERIVED);
+	      dt_sym = dt_sym->components->ts.u.derived;
+	    }
+	}
+
+      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 +770,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)
+    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 +814,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 +3760,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.  */
@@ -4522,72 +4495,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
@@ -4599,10 +4507,9 @@ 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))
+		      && e->ts.type == BT_CLASS
+		      && !gfc_compare_derived_types (fsym->ts.u.derived,
+						     e->ts.u.derived))
 		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
 				     fsym->attr.intent != INTENT_IN
 				     && (CLASS_DATA (fsym)->attr.class_pointer