Re: PR 55905: ICE for polymorphic dummy argument with an allocatable coarray component

[Tobias Burnus <burnus at net-b dot de>]

Janus Weil wrote:
> > >and let me know
> > >the likelihood of a fix making it into stage 3?
> Zero (since stage three has already ended two days ago).
>
> To make it into the 4.8 release: Also close to zero (since it's not a
> regression: 4.7 gives me a couple of different errors on your test
> case).

I think there some leeway for simple fixes of bugs.

I believe the attached patch is correct - for a -fcoarray=single 
implementation.*

(For coarrays - in particular with -fcoarray=lib* - but presumably also 
for finalization, there are still some known issues with allocatable 
components.)

Tobias

PS: The attached patch is loosely tested. I intent to do a regtest and 
create a test-suite test for it.

* One issue with coarray components is that in an intrinsic assignment, 
they may not be reallocated, which currently happens. For 
-fcoarray=single, that's probably detectable using TARGET and a pointer. 
And for -fcoarray=lib, I am not even sure whether it properly calls the 
library (de)registering functions. That's an issue which is still high 
up on my coarray to-do list.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 794322a..cca9748 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7335,22 +7335,45 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
   if (rank == 0)
     {
       tmp = null_pointer_node;
-      tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
-      gfc_add_expr_to_block (&block, tmp);
+      /* Handle coarray.  */
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      else
+	{
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
       null_data = gfc_finish_block (&block);
 
       gfc_init_block (&block);
-      size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+	size = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+      else
+	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
       if (!no_malloc)
 	{
-	  tmp = gfc_call_malloc (&block, type, size);
-	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
-				 dest, fold_convert (type, tmp));
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+	    {
+	      tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+	      tmp = gfc_call_malloc (&block, tmp, size);
+	      gfc_conv_descriptor_data_set (&block, dest, tmp);
+	    }
+	  else
+	    {
+	      tmp = gfc_call_malloc (&block, type, size);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     void_type_node, dest,
+				     fold_convert (type, tmp));
+	    }
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
       tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
-      tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+      tmp = build_call_expr_loc (input_location, tmp, 3,
+				 GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))
+				 ? gfc_conv_descriptor_data_get (dest): dest,
+				 GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))
+				 ? gfc_conv_descriptor_data_get (src): src,
 				 fold_convert (size_type_node, size));
     }
   else
@@ -7385,7 +7408,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
 
   /* Null the destination if the source is null; otherwise do
      the allocate and copy.  */
-  if (rank == 0)
+  if (rank == 0 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
     null_cond = src;
   else
     null_cond = gfc_conv_descriptor_data_get (src);