aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-array.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-array.c')
-rw-r--r--gcc/fortran/trans-array.c90
1 files changed, 70 insertions, 20 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1e8f777..c4df4eb 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -853,7 +853,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
types if possible. Otherwise, return NULL_TREE. */
tmp = gfc_get_element_type (TREE_TYPE (desc));
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
- && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE)
+ && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
+ || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
{
if (expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER)
@@ -5366,6 +5367,28 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && TREE_CODE (descriptor) == COMPONENT_REF)
+ {
+ /* Deferred character components have their string length tucked away
+ in a hidden field of the derived type. Obtain that and use it to
+ set the dtype. The charlen backend decl is zero because the field
+ type is zero length. */
+ gfc_ref *ref;
+ tmp = NULL_TREE;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && gfc_deferred_strlen (ref->u.c.component, &tmp))
+ break;
+ gcc_assert (tmp != NULL_TREE);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+ type = gfc_get_character_type_len (expr->ts.kind, tmp);
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
+ }
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
@@ -5774,16 +5797,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (expr->ts.type == BT_CHARACTER
&& TREE_CODE (se->string_length) == COMPONENT_REF
- && expr->ts.u.cl->backend_decl != se->string_length)
- {
- if (VAR_P (expr->ts.u.cl->backend_decl))
- gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
- fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
- se->string_length));
- else
- expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length,
- &se->pre);
- }
+ && expr->ts.u.cl->backend_decl != se->string_length
+ && VAR_P (expr->ts.u.cl->backend_decl))
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+ fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
+ se->string_length));
gfc_init_block (&set_descriptor_block);
/* Take the corank only from the actual ref and not from the coref. The
@@ -5871,17 +5889,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
- /* Pointer arrays need the span field to be set. */
- if (is_pointer_array (se->expr)
- || (expr->ts.type == BT_CLASS
- && CLASS_DATA (expr)->attr.class_pointer)
+ /* Set the span field for pointer and deferred length character arrays. */
+ if ((is_pointer_array (se->expr)
+ || (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.class_pointer)
+ || (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length)
+ == COMPONENT_REF))
|| (expr->ts.type == BT_CHARACTER
- && TREE_CODE (se->string_length) == COMPONENT_REF))
+ && (expr->ts.deferred || VAR_P (expr->ts.u.cl->backend_decl))))
{
if (expr3 && expr3_elem_size != NULL_TREE)
tmp = expr3_elem_size;
else if (se->string_length
- && TREE_CODE (se->string_length) == COMPONENT_REF)
+ && (TREE_CODE (se->string_length) == COMPONENT_REF
+ || (expr->ts.type == BT_CHARACTER && expr->ts.deferred)))
{
if (expr->ts.kind != 1)
{
@@ -7053,6 +7073,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree offset;
int full;
bool subref_array_target = false;
+ bool deferred_array_component = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
@@ -7092,6 +7113,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_conv_ss_descriptor (&se->pre, ss, 0);
desc = info->descriptor;
+ /* The charlen backend decl for deferred character components cannot
+ be used because it is fixed at zero. Instead, the hidden string
+ length component is used. */
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && TREE_CODE (desc) == COMPONENT_REF)
+ deferred_array_component = true;
+
subref_array_target = se->direct_byref && is_subref_array (expr);
need_tmp = gfc_ref_needs_temporary_p (expr->ref)
&& !subref_array_target;
@@ -7140,8 +7169,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
se->expr = desc;
}
- if (expr->ts.type == BT_CHARACTER)
+ if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
se->string_length = gfc_get_expr_charlen (expr);
+ /* The ss_info string length is returned set to the value of the
+ hidden string length component. */
+ else if (deferred_array_component)
+ se->string_length = ss_info->string_length;
gfc_free_ss_chain (ss);
return;
@@ -9797,8 +9830,15 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
- if (expr1->ts.deferred)
- cond_null = gfc_evaluate_now (logical_true_node, &fblock);
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ lss->info->string_length,
+ rss->info->string_length);
+ cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, tmp, cond_null);
+ }
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
@@ -10024,6 +10064,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
else
gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+ if (expr1->ts.kind > 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ expr1->ts.kind));
}
else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
{
@@ -10037,6 +10083,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
tmp = fold_convert (gfc_array_index_type, tmp);
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
tmp, size2);
generated by cgit v1.1 at 2025-05-20 11:28:15 +0000