gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
return gfc_conv_descriptor_stride (desc, dim);
/* Calculate the array size (number of elements); if dim != NULL_TREE,
- return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
+ return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
+ If !expr && descriptor array, the rank is taken from the descriptor. */
tree
gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
{
return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
}
tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
- symbol_attribute attr = gfc_expr_attr (expr);
- gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
- if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
- || !dim)
- {
- if (expr->rank < 0)
- rank = fold_convert (signed_char_type_node,
- gfc_conv_descriptor_rank (desc));
- else
- rank = build_int_cst (signed_char_type_node, expr->rank);
- }
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
+ if (expr == NULL || expr->rank < 0)
+ rank = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (desc));
+ else
+ rank = build_int_cst (signed_char_type_node, expr->rank);
- if (dim || expr->rank == 1)
+ if (dim || (expr && expr->rank == 1))
{
if (!dim)
dim = gfc_index_zero_node;
size = max (0, size); */
size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
size, gfc_index_zero_node);
- if (!attr.pointer && !attr.allocatable
- && as && as->type == AS_ASSUMED_RANK)
+ if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
rank, build_int_cst (signed_char_type_node, 1));
extent = 0
size *= extent. */
cond = NULL_TREE;
- if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
rank, build_int_cst (signed_char_type_node, 1));
tree idx;
tree nelems;
tree tmp;
- idx = gfc_rank_cst[rank - 1];
+ if (rank < 0)
+ idx = gfc_conv_descriptor_rank (decl);
+ else
+ idx = gfc_rank_cst[rank - 1];
nelems = gfc_conv_descriptor_ubound_get (decl, idx);
tmp = gfc_conv_descriptor_lbound_get (decl, idx);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
tree size = create_tmp_var (gfc_array_index_type);
tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
elemsz = fold_convert (gfc_array_index_type, elemsz);
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+ if (akind == GFC_ARRAY_ALLOCATABLE
+ || akind == GFC_ARRAY_POINTER
+ || akind == GFC_ARRAY_POINTER_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
{
stmtblock_t cond_block;
tree tem, then_b, else_b, zero, cond;
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
- tem = gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type));
+ tem = gfc_full_array_size (&cond_block, unshare_expr (decl), rank);
gfc_add_modify (&cond_block, size, tem);
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
zero = build_int_cst (gfc_array_index_type, 0);
gfc_add_modify (&cond_block, size, zero);
else_b = gfc_finish_block (&cond_block);
- tem = gfc_conv_descriptor_data_get (decl);
+ tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
tem = fold_convert (pvoid_type_node, tem);
cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tem, null_pointer_node);
stmtblock_t cond_block;
tree then_b;
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, size,
- gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&cond_block, unshare_expr (decl),
+ rank));
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
}
else
{
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_add_modify (&block, size,
- gfc_full_array_size (&block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&block, unshare_expr (decl),
+ rank));
gfc_add_modify (&block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE;
else if (as->type == AS_ASSUMED_RANK)
- akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
- : GFC_ARRAY_ASSUMED_RANK;
+ {
+ if (akind == GFC_ARRAY_ALLOCATABLE)
+ akind = GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE;
+ else if (akind == GFC_ARRAY_POINTER || akind == GFC_ARRAY_POINTER_CONT)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ : GFC_ARRAY_ASSUMED_RANK_POINTER;
+ else
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ }
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
corank, lbound, ubound, 0, akind,
}
if (derived->components
- && derived->components->ts.type == BT_DERIVED
- && strcmp (derived->components->name, "_data") == 0
- && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->ts.u.derived->attr.unlimited_polymorphic)
unlimited_entity = true;
/* Go through the derived type components, building them as
if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
- if (c->attr.pointer)
+ bool is_ptr = ((c == derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && (strcmp (derived->components->name, "_data")
+ == 0))
+ ? c->attr.class_pointer : c->attr.pointer);
+ if (is_ptr)
akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
: GFC_ARRAY_POINTER;
- else
+ else if (c->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
+ else if (c->as->type == AS_ASSUMED_RANK)
+ akind = GFC_ARRAY_ASSUMED_RANK;
+ else
+ /* FIXME – see PR fortran/104651. Additionally, the following
+ gfc_build_array_type should use !is_ptr instead of
+ c->attr.pointer and codim unconditionally without '? :'. */
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. Every
array pointer in a coarray derived type needs to provide space
t = fold_build_pointer_plus (t, data_off);
t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+ if (akind == GFC_ARRAY_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE)
info->allocated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
- else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ else if (akind == GFC_ARRAY_POINTER
+ || akind == GFC_ARRAY_POINTER_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
info->associated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
- if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
+ if ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
&& dwarf_version >= 5)
{
rank = 1;
dim_off, upper_suboff));
t = build1 (INDIRECT_REF, gfc_array_index_type, t);
info->dimen[dim].upper_bound = t;
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
+ if (akind == GFC_ARRAY_ASSUMED_SHAPE
+ || akind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
{
/* Assumed shape arrays have known lower bounds. */
info->dimen[dim].upper_bound
GFC_ARRAY_ASSUMED_SHAPE_CONT,
GFC_ARRAY_ASSUMED_RANK,
GFC_ARRAY_ASSUMED_RANK_CONT,
+ GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE,
+ GFC_ARRAY_ASSUMED_RANK_POINTER,
+ GFC_ARRAY_ASSUMED_RANK_POINTER_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT