Dear All,
Please find attached a slightly updated version of the patch with a
consolidated testcase. The three additional testcases are nothing to do
with associate and test fixes of character related bugs.
OK for mainline?
Cheers
Paul
Fortran: Fix some of the bugs in associate [PR87477]
2023-04-07 Paul Thomas <[email protected]>
gcc/fortran
PR fortran/87477
* resolve.cc (resolve_assoc_var): Handle parentheses around the
target expression.
(resolve_block_construct): Remove unnecessary static decls.
* trans-array.cc (gfc_conv_expr_descriptor): Guard string len
expression in condition. Improve handling of string length and
span, especially for substrings of the descriptor.
(duplicate_allocatable): Make element type more explicit with
'eltype'.
* trans_decl.cc (gfc_get_symbol_decl): Emit a fatal error with
appropriate message instead of ICE if symbol type is unknown.
* trans-expr.cc (gfc_get_expr_charlen): Retain last charlen in
'previous' and use if end expression in substring reference is
null.
(gfc_conv_string_length): Use gfc_conv_expr_descriptor if
'expr_flat' is an array.
(gfc_trans_alloc_subarray_assign): If this is a deferred string
length component, store the string length in the hidden comp.
Update the typespec length accordingly. Generate a new type
spec for the call to gfc_duplicate-allocatable in this case.
* trans-io.cc (gfc_trans_transfer): Scalarize transfer of
deferred character array components.
gcc/testsuite/
PR fortran/87477
* gfortran.dg/finalize_47.f90 : Enable substring test.
* gfortran.dg/finalize_51.f90 : Update an error message.
PR fortran/85686
PR fortran/88247
PR fortran/91941
PR fortran/92779
PR fortran/93339
PR fortran/93813
PR fortran/100948
PR fortran/102106
* gfortran.dg/associate_60.f90 : New test
PR fortran/98408
* gfortran.dg/pr98408.f90 : New test
PR fortran/105205
* gfortran.dg/pr105205.f90 : New test
PR fortran/106918
* gfortran.dg/pr106918.f90 : New test
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 33794f0a858..8acad60a02b 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -230,7 +230,9 @@ gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
- if (string->ts.u.cl)
+ if (string->ts.deferred)
+ f->ts = string->ts;
+ else if (string->ts.u.cl)
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
@@ -242,7 +244,9 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
- if (string->ts.u.cl)
+ if (string->ts.deferred)
+ f->ts = string->ts;
+ else if (string->ts.u.cl)
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
@@ -3361,7 +3365,7 @@ gfc_resolve_mvbits (gfc_code *c)
}
-/* Set up the call to RANDOM_INIT. */
+/* Set up the call to RANDOM_INIT. */
void
gfc_resolve_random_init (gfc_code *c)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f6ec76acb0b..6e42397c2ea 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9084,6 +9084,7 @@ static void
resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
gfc_expr* target;
+ bool parentheses = false;
gcc_assert (sym->assoc);
gcc_assert (sym->attr.flavor == FL_VARIABLE);
@@ -9096,6 +9097,16 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
return;
gcc_assert (!sym->assoc->dangling);
+ if (target->expr_type == EXPR_OP
+ && target->value.op.op == INTRINSIC_PARENTHESES
+ && target->value.op.op1->expr_type == EXPR_VARIABLE)
+ {
+ sym->assoc->target = gfc_copy_expr (target->value.op.op1);
+ gfc_free_expr (target);
+ target = sym->assoc->target;
+ parentheses = true;
+ }
+
if (resolve_target && !gfc_resolve_expr (target))
return;
@@ -9177,6 +9188,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* See if this is a valid association-to-variable. */
sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+ && !parentheses
&& !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
@@ -9191,7 +9203,6 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
return;
}
-
/* We cannot deal with class selectors that need temporaries. */
if (target->ts.type == BT_CLASS
&& gfc_ref_needs_temporary_p (target->ref))
@@ -10885,11 +10896,6 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
/* Resolve a BLOCK construct statement. */
-static gfc_expr*
-get_temp_from_expr (gfc_expr *, gfc_namespace *);
-static gfc_code *
-build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *,
- gfc_component *, gfc_component *, locus);
static void
resolve_block_construct (gfc_code* code)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 41661b4195e..e1725808033 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7568,6 +7568,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
+ bool substr = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
@@ -7618,6 +7619,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
&& TREE_CODE (desc) == COMPONENT_REF)
deferred_array_component = true;
+ substr = info->ref && info->ref->next
+ && info->ref->next->type == REF_SUBSTRING;
+
subref_array_target = (is_subref_array (expr)
&& (se->direct_byref
|| expr->ts.type == BT_CHARACTER));
@@ -7659,7 +7663,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
subref_array_target, expr);
/* ....and set the span field. */
- tmp = gfc_conv_descriptor_span_get (desc);
+ if (ss_info->expr->ts.type == BT_CHARACTER)
+ tmp = gfc_conv_descriptor_span_get (desc);
+ else
+ tmp = gfc_get_array_span (desc, expr);
gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
}
else if (se->want_pointer)
@@ -7730,6 +7737,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
+ && expr->ts.u.cl->length
&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
get_array_charlen (expr, se);
@@ -7915,7 +7923,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
/* Set the string_length for a character array. */
if (expr->ts.type == BT_CHARACTER)
{
- if (deferred_array_component)
+ if (deferred_array_component && !substr)
se->string_length = ss_info->string_length;
else
se->string_length = gfc_get_expr_charlen (expr);
@@ -7992,7 +8000,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
/* Set the span field. */
- tmp = gfc_get_array_span (desc, expr);
+ tmp = NULL_TREE;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ tmp = gfc_conv_descriptor_span_get (desc);
+ else
+ tmp = gfc_get_array_span (desc, expr);
if (tmp)
gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
@@ -8766,6 +8778,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
tree add_when_allocated)
{
tree tmp;
+ tree eltype;
tree size;
tree nelems;
tree null_cond;
@@ -8782,10 +8795,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
null_data = gfc_finish_block (&block);
gfc_init_block (&block);
+ eltype = TREE_TYPE (type);
if (str_sz != NULL_TREE)
size = str_sz;
else
- size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ size = TYPE_SIZE_UNIT (eltype);
if (!no_malloc)
{
@@ -8812,11 +8826,19 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
else
nelems = gfc_index_one_node;
+ /* If type is not the array type, then it is the element type. */
+ if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
+ eltype = gfc_get_element_type (type);
+ else
+ eltype = type;
+
if (str_sz != NULL_TREE)
tmp = fold_convert (gfc_array_index_type, str_sz);
else
tmp = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ TYPE_SIZE_UNIT (eltype));
+
+ tmp = gfc_evaluate_now (tmp, &block);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
nelems, tmp);
if (!no_malloc)
@@ -9865,6 +9887,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
/* This component cannot have allocatable components,
therefore add_when_allocated of duplicate_allocatable ()
is always NULL. */
+ rank = c->as ? c->as->rank : 0;
tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
false, false, size, NULL_TREE);
gfc_add_expr_to_block (&fnblock, tmp);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 25737881ae0..299764b08b2 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1791,6 +1791,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
return decl;
}
+ if (sym->ts.type == BT_UNKNOWN)
+ gfc_fatal_error ("%s at %C has no default type", sym->name);
+
if (sym->attr.intrinsic)
gfc_internal_error ("intrinsic variable which isn't a procedure");
@@ -7538,6 +7541,7 @@ gfc_generate_function_code (gfc_namespace * ns)
}
trans_function_start (sym);
+ gfc_current_locus = sym->declared_at;
gfc_init_block (&init);
gfc_init_block (&cleanup);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d996d295bd2..023258c1b43 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2124,6 +2124,7 @@ gfc_get_expr_charlen (gfc_expr *e)
{
gfc_ref *r;
tree length;
+ tree previous = NULL_TREE;
gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
@@ -2149,6 +2150,7 @@ gfc_get_expr_charlen (gfc_expr *e)
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
{
+ previous = length;
switch (r->type)
{
case REF_COMPONENT:
@@ -2164,7 +2166,10 @@ gfc_get_expr_charlen (gfc_expr *e)
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
length = se.expr;
- gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ if (r->u.ss.end)
+ gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ else
+ se.expr = previous;
length = fold_build2_loc (input_location, MINUS_EXPR,
gfc_charlen_type_node,
se.expr, length);
@@ -2554,9 +2559,12 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
-
- gfc_conv_expr (&se, expr_flat);
- gfc_add_block_to_block (pblock, &se.pre);
+ if (expr_flat->rank)
+ gfc_conv_expr_descriptor (&se, expr_flat);
+ else
+ gfc_conv_expr (&se, expr_flat);
+ if (expr_flat->expr_type != EXPR_VARIABLE)
+ gfc_add_block_to_block (pblock, &se.pre);
cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
gfc_free_expr (expr_flat);
@@ -8584,6 +8592,20 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr);
+ if (cm->ts.type == BT_CHARACTER
+ && gfc_deferred_strlen (cm, &tmp))
+ {
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (tmp),
+ TREE_OPERAND (dest, 0),
+ tmp, NULL_TREE);
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ se.string_length));
+ cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
+ "slen");
+ gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
+ }
/* Deal with arrays of derived types with allocatable components. */
if (gfc_bt_struct (cm->ts.type)
@@ -8607,11 +8629,16 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
tmp, expr->rank, NULL_TREE);
}
}
+ else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ gfc_typenode_for_spec (&cm->ts),
+ cm->as->rank, NULL_TREE);
else
tmp = gfc_duplicate_allocatable (dest, se.expr,
TREE_TYPE(cm->backend_decl),
cm->as->rank, NULL_TREE);
+
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index baeea955d35..9b54d2f0d31 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2622,10 +2622,10 @@ gfc_trans_transfer (gfc_code * code)
if (expr->ts.type != BT_CLASS
&& expr->expr_type == EXPR_VARIABLE
- && gfc_expr_attr (expr).pointer)
+ && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
+ || gfc_expr_attr (expr).pointer))
goto scalarize;
-
if (!(gfc_bt_struct (expr->ts.type)
|| expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
diff --git a/gcc/testsuite/gfortran.dg/associate_47.f90 b/gcc/testsuite/gfortran.dg/associate_47.f90
index 085c6f38338..d8a50c6091c 100644
--- a/gcc/testsuite/gfortran.dg/associate_47.f90
+++ b/gcc/testsuite/gfortran.dg/associate_47.f90
@@ -39,10 +39,9 @@ program p
end associate
if (x%d(1) .ne. 'zqrtyd') stop 5
-! Substrings of arrays still do not work correctly.
call foo ('lmnopqrst','ghijklmno')
associate (y => x%d(:)(2:4))
-! if (any (y .ne. ['mno','hij'])) stop 6
+ if (any (y .ne. ['mno','hij'])) stop 6
end associate
call foo ('abcdef','ghijkl')
diff --git a/gcc/testsuite/gfortran.dg/associate_51.f90 b/gcc/testsuite/gfortran.dg/associate_51.f90
index e6f2e4fafa3..2e5218c78cf 100644
--- a/gcc/testsuite/gfortran.dg/associate_51.f90
+++ b/gcc/testsuite/gfortran.dg/associate_51.f90
@@ -51,7 +51,7 @@ recursive subroutine s
end
recursive subroutine s2
- associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" }
+ associate (y => (s2)) ! { dg-error "is a procedure name" }
end associate
end
