Hi All, I have made a start on ASSOCIATE issues. Some of the low(-ish) hanging fruit are already fixed but I have yet to check that they a really fixed and to close them: pr102106, pr102111, pr104430, pr106048, pr85510, pr87460, pr92960 & pr93338
The attached patch picks up those PRs involving deferred length characters in one guise or another. I believe that it is all pretty straightforward. Structure constructors with allocatable, deferred length, character array components just weren't implemented and so this is the biggest part of the patch. I found two other, non-associate PRs(106918 & 105205) that are fixed and there are probably more. The chunk in trans-io.cc is something of a kludge, which I will come back to. Some descriptors come through with a data pointer that looks as if it should be OK but I thought to submit this now to get it out of the way. The ratio of PRs fixed to the size of the patch warrants this. The next stage is going to be rather messy and so "I might take a little while" (cross talk between associate and select type, in particular). Regtests OK - good for mainline? Cheers Paul Fortran: Fix some of the bugs in associate [PR87477] 2023-03-28 Paul Thomas <pa...@gcc.gnu.org> gcc/fortran PR fortran/87477 * trans-array.cc (gfc_conv_expr_descriptor): Guard string len expression in condition. (duplicate_allocatable): Make element type more explicit with 'eltype'. * 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/92994 * gfortran.dg/finalize_51.f90 : Update an error message. PR fortran/85686 * gfortran.dg/pr85686.f90 : New test PR fortran/88247 * gfortran.dg/pr88247.f90 : New test PR fortran/91941 * gfortran.dg/pr91941.f90 : New test PR fortran/92779 * gfortran.dg/pr92779.f90 : New test PR fortran/93339 * gfortran.dg/pr93339.f90 : New test PR fortran/93813 * gfortran.dg/pr93813.f90 : New test PR fortran/100948 * gfortran.dg/pr100948.f90 : New test PR fortran/102106 * gfortran.dg/pr102106.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 1a03e458d99..23a04d2c5bd 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. */
@@ -10885,11 +10897,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..2b9ca3c7c1e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7730,6 +7730,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);
@@ -8766,6 +8767,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 +8784,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 +8815,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 +9876,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 77610df340b..d0747d74f11 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");
@@ -7541,6 +7544,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_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
pr85686.f90
Description: Binary data
pr88247.f90
Description: Binary data
pr91941.f90
Description: Binary data
pr92779.f90
Description: Binary data
pr93339.f90
Description: Binary data
pr93813.f90
Description: Binary data
pr102106.f90
Description: Binary data
pr106918.f90
Description: Binary data
pr105205.f90
Description: Binary data
! { dg-do-run }
!
! Contributed by Gerhard Steinmetz <gs...@t-online.de>
!
program p
type t
character(:), allocatable :: c(:)
end type
type(t), allocatable :: x
!
! Valid test in comment 1
!
x = t(['ab','cd'])
associate (y => x%c(:))
if (any (y .ne. x%c)) stop 1
if (any (y .ne. ['ab','cd'])) stop 2
end associate
deallocate (x)
!
! Allocation with source was found to only copy over one of the array elements
!
allocate (x, source = t(['ef','gh']))
associate (y => x%c(:))
if (any (y .ne. x%c)) stop 3
if (any (y .ne. ['ef','gh'])) stop 4
end associate
deallocate (x)
end
