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)
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
{
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;
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;
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);
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'. */
--- /dev/null
+! { 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" } }
+