Hi All,
Harald has pointed out that I attached the ChangeLog twice and the patch
not at all :-(
Please find the patch duly attached.
Paul
On Sat, 13 Jul 2024 at 10:58, Paul Richard Thomas <
paul.richard.tho...@gmail.com> wrote:
> Hi All,
>
> After messing around with argument mapping, where I found and fixed
> another bug, I realised that the problem lay with simplification of
> len_trim with an argument that is the element of a parameter array. The fix
> was then a straightforward lift of existing code in expr.cc. The mapping
> bug is also fixed by supplying the se string length when building character
> typespecs.
>
> Regtests just fine. OK for mainline? I believe that this is safe for
> backporting to 14-branch before the 14.2 release - thoughts?
>
> Regards
>
> Paul
>
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 7a5d31c01a6..5199ede98fe 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4637,6 +4637,76 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.dimen_type[0] == DIMEN_ELEMENT
+ && e->symtree->n.sym->value)
+ {
+ char name[GFC_MAX_SYMBOL_LEN + 10];
+ gfc_namespace *ns = e->symtree->n.sym->ns;
+ gfc_symtree *st;
+ gfc_expr *expr;
+ gfc_expr *p;
+ gfc_constructor *c;
+ int cnt = 0;
+
+ sprintf (name, "_len_trim_%s", e->symtree->n.sym->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ goto already_built;
+
+ /* Recursively call this fcn to simplify the constructor elements. */
+ expr = gfc_copy_expr (e->symtree->n.sym->value);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = k;
+ expr->ts.u.cl = NULL;
+ expr->rank = 1;
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ if (c->iterator)
+ continue;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ p = gfc_simplify_len_trim (c->expr, kind);
+ if (p == NULL)
+ goto clean_up;
+ gfc_replace_expr (c->expr, p);
+ cnt++;
+ }
+ }
+
+ if (cnt)
+ {
+ /* Build a new parameter to take the result. */
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = gfc_new_symbol (st->name, ns);
+ st->n.sym->value = expr;
+ st->n.sym->ts = expr->ts;
+ st->n.sym->attr.dimension = 1;
+ st->n.sym->attr.save = SAVE_IMPLICIT;
+ st->n.sym->attr.flavor = FL_PARAMETER;
+ st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+
+already_built:
+ /* Build a return expression. */
+ expr = gfc_copy_expr (e);
+ expr->ts = st->n.sym->ts;
+ expr->symtree = st;
+ expr->rank = 0;
+ return expr;
+ }
+
+clean_up:
+ gfc_free_expr (expr);
+ return NULL;
+ }
+
if (e->expr_type != EXPR_CONSTANT)
return NULL;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 477c2720187..fe872a661ec 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4490,12 +4490,15 @@ gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
- gfc_packed packed, tree data)
+ gfc_packed packed, tree data, tree len)
{
tree type;
tree var;
- type = gfc_typenode_for_spec (&sym->ts);
+ if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+ type = gfc_get_character_type_len (sym->ts.kind, len);
+ else
+ type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.target && !sym->attr.pointer
&& !sym->attr.proc_pointer);
@@ -4642,7 +4645,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
convert it to a boundless character type. */
else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
{
- tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
+ se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
+ tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
tmp = build_pointer_type (tmp);
if (sym->attr.pointer)
value = build_fold_indirect_ref_loc (input_location,
@@ -4661,7 +4665,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
/* For character(*), use the actual argument's descriptor. */
else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ se->expr);
/* If the argument is an array descriptor, use it to determine
information about the actual argument's shape. */
@@ -4675,7 +4679,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
/* Create the replacement variable. */
tmp = gfc_conv_descriptor_data_get (desc);
value = gfc_get_interface_mapping_array (&se->pre, sym,
- PACKED_NO, tmp);
+ PACKED_NO, tmp,
+ se->string_length);
/* Use DESC to work out the upper bounds, strides and offset. */
gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
@@ -4683,7 +4688,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
else
/* Otherwise we have a packed array. */
value = gfc_get_interface_mapping_array (&se->pre, sym,
- PACKED_FULL, se->expr);
+ PACKED_FULL, se->expr,
+ se->string_length);
new_sym->backend_decl = value;
}
diff --git a/gcc/testsuite/gfortran.dg/pr84868.f90 b/gcc/testsuite/gfortran.dg/pr84868.f90
new file mode 100644
index 00000000000..eb9cb67e14a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr84868.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+!
+! Test the fix for PR84868. Module 'orig' and the call to 'f_orig' is the
+! original bug. The rest tests variants and the fix for a gimplifier ICE.
+!
+! Contributed by Gerhard Steinmetx <gs...@t-online.de>
+!
+module orig
+ character(:), allocatable :: c
+contains
+ function f_orig(n) result(z)
+ character(2), parameter :: c(3) = ['x1', 'y ', 'z2']
+ integer, intent(in) :: n
+ character(len_trim(c(n))) :: z
+ z = c(n)
+ end
+end module orig
+
+module m
+ character(:), allocatable :: c
+contains
+ function f(n, c) result(z)
+ character (2) :: c(:)
+ integer, intent(in) :: n
+ character(len_trim(c(n))) :: z
+ z = c(n)
+ end
+ subroutine foo (pc)
+ character(2) :: pc(:)
+ if (any ([(len (f(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 1
+ end
+end
+program p
+ use m
+ use orig
+ character (2) :: pc(3) = ['x1', 'y ', 'z2']
+ integer :: i
+
+ if (any ([(len (f_orig(i)), i = 1,3)] .ne. [2,1,2])) stop 2 ! ICE
+
+ call foo (pc)
+ if (any ([(len (g(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 3
+ if (any ([(bar1(i), i = 1,3)] .ne. [2,1,2])) stop 4
+ if (any ([(bar2(i), i = 1,3)] .ne. [2,1,2])) stop 5
+contains
+ function g(n, c) result(z)
+ character (2) :: c(:)
+ integer, intent(in) :: n
+ character(len_trim(c(n))) :: z
+ z = c(n)
+ end
+ integer function bar1 (i)
+ integer :: i
+ bar1 = len (f(i, pc)) ! ICE in is_gimple_min_invariant
+ end
+ integer function bar2 (i)
+ integer :: i
+ bar2 = len (g(i, pc))
+ end
+end
