Prevent malicious descriptor stacking for scalar components [V2].

gcc/fortran/ChangeLog:

	PR fortran/103790
	* trans-array.cc (structure_alloc_comps): Prevent descriptor
	stacking for non-array data; do not broadcast caf-tokens.
	* trans-intrinsic.cc (conv_co_collective): Prevent generation
	of unused descriptor.

gcc/testsuite/ChangeLog:

	PR fortran/103790
	* gfortran.dg/coarray_collectives_18.f90: New test.

3 files changed, 108 insertions, 43 deletions

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2f0c8a4..cfb6eac 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9102,6 +9102,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		continue;
 	    }
 
+	  /* Do not broadcast a caf_token.  These are local to the image.  */
+	  if (attr->caf_token)
+	    continue;
+
 	  add_when_allocated = NULL_TREE;
 	  if (cmp_has_alloc_comps
 	      && !c->attr.pointer && !c->attr.proc_pointer)
@@ -9134,10 +9138,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  if (attr->dimension)
 	    {
 	      tmp = gfc_get_element_type (TREE_TYPE (comp));
-	      ubound = gfc_full_array_size (&tmpblock, comp,
-					    c->ts.type == BT_CLASS
-					    ? CLASS_DATA (c)->as->rank
-					    : c->as->rank);
+	      if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+		ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
+	      else
+		ubound = gfc_full_array_size (&tmpblock, comp,
+					      c->ts.type == BT_CLASS
+					      ? CLASS_DATA (c)->as->rank
+					      : c->as->rank);
 	    }
 	  else
 	    {
@@ -9145,26 +9152,39 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      ubound = build_int_cst (gfc_array_index_type, 1);
 	    }
 
-	  cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
-					     &ubound, 1,
-					     GFC_ARRAY_ALLOCATABLE, false);
+	  /* Treat strings like arrays.  Or the other way around, do not
+	   * generate an additional array layer for scalar components.  */
+	  if (attr->dimension || c->ts.type == BT_CHARACTER)
+	    {
+	      cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+						 &ubound, 1,
+						 GFC_ARRAY_ALLOCATABLE, false);
 
-	  cdesc = gfc_create_var (cdesc, "cdesc");
-	  DECL_ARTIFICIAL (cdesc) = 1;
+	      cdesc = gfc_create_var (cdesc, "cdesc");
+	      DECL_ARTIFICIAL (cdesc) = 1;
 
-	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
-			  gfc_get_dtype_rank_type (1, tmp));
-	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
-					  gfc_index_zero_node,
-					  gfc_index_one_node);
-	  gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
-					  gfc_index_zero_node,
-					  gfc_index_one_node);
-	  gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
-					  gfc_index_zero_node, ubound);
+	      gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
+			      gfc_get_dtype_rank_type (1, tmp));
+	      gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
+	      gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
+	      gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
+					      gfc_index_zero_node, ubound);
+	    }
+	  else
+	    /* Prevent warning.  */
+	    cdesc = NULL_TREE;
 
 	  if (attr->dimension)
-	    comp = gfc_conv_descriptor_data_get (comp);
+	    {
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+		comp = gfc_conv_descriptor_data_get (comp);
+	      else
+		comp = gfc_build_addr_expr (NULL_TREE, comp);
+	    }
 	  else
 	    {
 	      gfc_se se;
@@ -9172,14 +9192,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      gfc_init_se (&se, NULL);
 
 	      comp = gfc_conv_scalar_to_descriptor (&se, comp,
-	      					    c->ts.type == BT_CLASS
-	      					    ? CLASS_DATA (c)->attr
-	      					    : c->attr);
-	      comp = gfc_build_addr_expr (NULL_TREE, comp);
+						     c->ts.type == BT_CLASS
+						     ? CLASS_DATA (c)->attr
+						     : c->attr);
+	      if (c->ts.type == BT_CHARACTER)
+		comp = gfc_build_addr_expr (NULL_TREE, comp);
 	      gfc_add_block_to_block (&tmpblock, &se.pre);
 	    }
 
-	  gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+	  if (attr->dimension || c->ts.type == BT_CHARACTER)
+	    gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+	  else
+	    cdesc = comp;
 
 	  tree fndecl;
 
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index da854fa..e680de1 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -11212,24 +11212,31 @@ conv_co_collective (gfc_code *code)
       return gfc_finish_block (&block);
     }
 
+  gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
+    ? code->ext.actual->expr->ts.u.derived : NULL;
+
   /* Handle the array.  */
   gfc_init_se (&argse, NULL);
-  if (code->ext.actual->expr->rank == 0)
-    {
-      symbol_attribute attr;
-      gfc_clear_attr (&attr);
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr (&argse, code->ext.actual->expr);
-      gfc_add_block_to_block (&block, &argse.pre);
-      gfc_add_block_to_block (&post_block, &argse.post);
-      array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
-      array = gfc_build_addr_expr (NULL_TREE, array);
-    }
-  else
+  if (!derived || !derived->attr.alloc_comp
+      || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
     {
-      argse.want_pointer = 1;
-      gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
-      array = argse.expr;
+      if (code->ext.actual->expr->rank == 0)
+	{
+	  symbol_attribute attr;
+	  gfc_clear_attr (&attr);
+	  gfc_init_se (&argse, NULL);
+	  gfc_conv_expr (&argse, code->ext.actual->expr);
+	  gfc_add_block_to_block (&block, &argse.pre);
+	  gfc_add_block_to_block (&post_block, &argse.post);
+	  array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
+	  array = gfc_build_addr_expr (NULL_TREE, array);
+	}
+      else
+	{
+	  argse.want_pointer = 1;
+	  gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
+	  array = argse.expr;
+	}
     }
 
   gfc_add_block_to_block (&block, &argse.pre);
@@ -11290,9 +11297,6 @@ conv_co_collective (gfc_code *code)
       gcc_unreachable ();
     }
 
-  gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
-    ? code->ext.actual->expr->ts.u.derived : NULL;
-
   if (derived && derived->attr.alloc_comp
       && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
     /* The derived type has the attribute 'alloc_comp'.  */
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
new file mode 100644
index 0000000..c83899d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original -fcoarray=lib" }
+!
+! PR 103970
+! Test case inspired by code submitted by Damian Rousson
+
+program main
+
+  implicit none
+
+  type foo_t
+    integer i
+    integer, allocatable :: j
+  end type
+
+  type(foo_t) foo
+  integer, parameter :: source_image = 1
+
+  if (this_image() == source_image)  then
+    foo = foo_t(2,3)
+  else
+    allocate(foo%j)
+  end if
+  call co_broadcast(foo, source_image)
+
+  if ((foo%i /= 2) .or. (foo%j /= 3))  error stop 1
+  sync all
+
+end program
+
+! Wrong code generation produced too many temp descriptors
+! leading to stacked descriptors handed to the co_broadcast.
+! This lead to access to non exsitant memory in opencoarrays.
+! In single image mode just checking for reduced number of
+! descriptors is possible, i.e., execute always works.
+! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
+