Re: [Patch, fortran] [0/5] PR 45586: restrict vs. non-restrict type compatibility hell

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

On 25/08/2012 20:00, Dominique Dhumieres wrote:
> Dear Mikael,
> 
> Your set of patches works as defined, i.e., it fixes pr45586 without 
> regression on the test suite. However, If the test suite is run with 
> -flto, there are still some failures depending on the way gcc is 
> configured.
Thanks for testing. All right, I'll have to master the LTO beast too. In
the meantime is it by any chance better if the first patch in the serie
is replaced by the attached one?

Mikael

diff --git a/trans-expr.c b/trans-expr.c
index ebaa238..37dfb5a 100644
--- a/trans-expr.c
+++ b/trans-expr.c
@@ -6306,6 +6332,127 @@ gfc_conv_string_parameter (gfc_se * se)
 }
 
 
+static void
+whole_struct_copy (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
+		   stmtblock_t *block)
+{
+  gfc_ref ref;
+  gfc_component *comp;
+  tree old_lhs, old_rhs, tmp;
+  gfc_symbol *derived;
+
+#if 0
+  if ((ts.type != BT_CLASS && ts.type != BT_DERIVED)
+      || !ts.u.derived->attr.alloc_comp)
+    {
+      gfc_add_modify (block, lse->expr,
+		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
+      return;
+    }
+#endif
+
+  derived = ts.u.derived;
+  old_lhs = lse->expr;
+  old_rhs = gfc_evaluate_now (rse->expr, block);
+
+  ref.type = REF_COMPONENT;
+  ref.next = NULL;
+  ref.u.c.sym = derived;
+  for (comp = derived->components; comp; comp = comp->next)
+    {
+      ref.u.c.component = comp;
+      gfc_conv_component_ref (lse, &ref);
+      gfc_conv_component_ref (rse, &ref);
+      if ((comp->attr.pointer
+           && !comp->attr.dimension
+	   && !comp->attr.codimension)
+          || comp->attr.proc_pointer)
+	{
+	  /* Undereference pointers.  */
+	  if (TREE_CODE (lse->expr) == INDIRECT_REF)
+	    lse->expr = TREE_OPERAND (lse->expr, 0);
+	  if (TREE_CODE (rse->expr) == INDIRECT_REF)
+	    rse->expr = TREE_OPERAND (rse->expr, 0);
+	  gfc_add_modify (block, lse->expr, rse->expr);
+	}
+
+      else if (!comp->attr.allocatable || !comp->attr.dimension)
+	{
+	  bool deep_copy;
+
+	  if (comp->attr.dimension)
+	    {
+	      lse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+				      TREE_TYPE (lse->expr), lse->expr,
+				      gfc_index_zero_node, NULL_TREE,
+				      NULL_TREE);
+	      rse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+				      TREE_TYPE (rse->expr), rse->expr,
+				      gfc_index_zero_node, NULL_TREE,
+				      NULL_TREE);
+	      /* Disable subreferences after the array range.  */
+	      deep_copy = false;
+	    }
+	  else
+	    deep_copy = true;
+
+	  tmp = gfc_trans_scalar_assign (lse, rse, comp->ts, true, deep_copy,					    false);
+	  gfc_add_expr_to_block (block, tmp);
+	}
+      else
+	{
+	  tree l_base_expr, r_base_expr;
+	  tree l_field, r_field;
+	
+	  l_base_expr = lse->expr;
+	  r_base_expr = rse->expr;
+	  gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (l_base_expr))
+		      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (r_base_expr)));
+	  /* copy all but the data pointer in the descriptor.  */
+	  for (l_field = TYPE_FIELDS (TREE_TYPE (l_base_expr)),
+	       r_field = TYPE_FIELDS (TREE_TYPE (r_base_expr));
+	       l_field != NULL_TREE && r_field != NULL_TREE;
+	       l_field = DECL_CHAIN (l_field),
+	       r_field = DECL_CHAIN (r_field))
+	    {
+	      gcc_assert (TREE_CODE (l_field) == FIELD_DECL
+			  && TREE_CODE (r_field) == FIELD_DECL
+			  && DECL_NAME (l_field) == DECL_NAME (r_field));
+	      if (strcmp (IDENTIFIER_POINTER (DECL_NAME (l_field)),
+			  "data") == 0)
+		continue;
+	
+	      lse->expr = fold_build3_loc (input_location, COMPONENT_REF,
+					   TREE_TYPE (l_field),
+					   l_base_expr,
+					   l_field, NULL_TREE);
+	      rse->expr = fold_build3_loc (input_location, COMPONENT_REF,
+					   TREE_TYPE (r_field), r_base_expr,
+					   r_field, NULL_TREE);
+	      if (TREE_CODE (TREE_TYPE (lse->expr)) == ARRAY_TYPE)
+		{
+		  gcc_assert (TREE_CODE (TREE_TYPE (rse->expr)) == ARRAY_TYPE);
+		  lse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+					  TREE_TYPE (lse->expr),
+					  lse->expr, gfc_index_zero_node,
+					  NULL_TREE, NULL_TREE);
+		  rse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+					  TREE_TYPE (rse->expr),
+					  rse->expr, gfc_index_zero_node,
+					  NULL_TREE, NULL_TREE);
+	
+	
+		}
+	      gfc_add_modify (block, lse->expr, rse->expr);
+	    }
+	}
+  
+      lse->expr = old_lhs;
+      rse->expr = old_rhs;
+    }
+}
+
+
 /* Generate code for assignment of scalar variables.  Includes character
    strings and derived types with allocatable components.
    If you know that the LHS has no allocations, set dealloc to false.
@@ -6396,8 +6543,30 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_block_to_block (&block, &rse->pre);
       gfc_add_block_to_block (&block, &lse->pre);
 
-      gfc_add_modify (&block, lse->expr,
-			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+      if (deep_copy)
+	whole_struct_copy (lse, rse, ts, &block);
+      else
+	{
+	  tree converted;
+
+	  if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
+	       != TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr))
+	      && !POINTER_TYPE_P (TREE_TYPE (lse->expr))
+	      && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
+	    {
+	      gcc_assert (TYPE_CANONICAL (TREE_TYPE (lse->expr))
+			  == TYPE_CANONICAL (TREE_TYPE (rse->expr))
+			  && gfc_nonrestricted_type (TREE_TYPE (lse->expr))
+			     == gfc_nonrestricted_type (TREE_TYPE (rse->expr)));
+	      /* fold_convert won't like this.  Let's bypass it.  */
+	      converted = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+					   TREE_TYPE (lse->expr), rse->expr);
+	    }
+	  else
+	    converted = fold_convert (TREE_TYPE (lse->expr), rse->expr);
+
+	  gfc_add_modify (&block, lse->expr, converted);
+	}
 
       /* Do a deep copy if the rhs is a variable, if it is not the
 	 same as the lhs.  */