I've done it again! Patch duly added.
Paul
On Mon, 15 Jul 2024 at 09:21, Paul Richard Thomas <
paul.richard.tho...@gmail.com> wrote:
> Hi Harald,
>
> Thank you for the review and for the testing to destruction. Both issues
> are fixed in the attached patch. Note the new function 'h', which both
> tests that the namespace confusion is fixed and that the elemental-ness of
> LEN_TRIM is respected.
>
> The patch continues to regtest OK. If I don't receive anymore
> comments/corrections, I will commit tomorrow morning.
>
> Regards
>
> Paul
>
>
> On Sun, 14 Jul 2024 at 19:50, Harald Anlauf <anl...@gmx.de> wrote:
>
>> Hi Paul,
>>
>> at first sight the patch seems to be the right approach, but
>> it breaks for the following two variations:
>>
>> (1) LEN_TRIM is elemental, but the following is erroneously rejected:
>>
>> function g(n) result(z)
>> integer, intent(in) :: n
>> character, parameter :: d(3,3) = 'x'
>> character(len_trim(d(n,n))) :: z
>> z = d(n,n)
>> end
>>
>> This is fixed here by commenting/removing the line
>>
>> expr->rank = 1;
>>
>> as the result shall have the same shape as the argument.
>> Can you check?
>>
>> (2) The handling of namespaces is problematic: using the same name
>> for a parameter within procedures in the same scope generates another
>> ICE. The following testcase demonstrates this:
>>
>> module m
>> implicit none
>> integer :: c
>> contains
>> function f(n) result(z)
>> integer, intent(in) :: n
>> character, parameter :: c(3) = ['x', 'y', 'z']
>> character(len_trim(c(n))) :: z
>> z = c(n)
>> end
>> function h(n) result(z)
>> integer, intent(in) :: n
>> character, parameter :: c(3,3) = 'x'
>> character(len_trim(c(n,n))) :: z
>> z = c(n,n)
>> end
>> end
>> program p
>> use m
>> implicit none
>> print *, f(2)
>> print *, h(1)
>> end
>>
>> I get:
>>
>> pr84868-z0.f90:22:15:
>>
>> 22 | print *, h(1)
>> | 1
>> internal compiler error: in gfc_conv_descriptor_stride_get, at
>> fortran/trans-array.cc:483
>> 0x243e156 internal_error(char const*, ...)
>> ../../gcc-trunk/gcc/diagnostic-global-context.cc:491
>> 0x96dd70 fancy_abort(char const*, int, char const*)
>> ../../gcc-trunk/gcc/diagnostic.cc:1725
>> 0x749d68 gfc_conv_descriptor_stride_get(tree_node*, tree_node*)
>> ../../gcc-trunk/gcc/fortran/trans-array.cc:483
>> [rest of traceback elided]
>>
>> Renaming the parameter array in h solves the problem.
>>
>> Am 13.07.24 um 17:57 schrieb Paul Richard Thomas:
>> > 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?
>>
>> If you manage to correct/fix the above issues, I am fine with
>> backporting, as this appears a very reasonable fix.
>>
>> Thanks,
>> Harald
>>
>> >> Regards
>> >>
>> >> Paul
>> >>
>> >
>>
>>
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 7a5d31c01a6..931a9a8f5ed 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4637,6 +4637,75 @@ 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[2*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_%s", e->symtree->n.sym->name, ns->proc_name->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;
+ 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..a3b98f097a6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr84868.f90
@@ -0,0 +1,76 @@
+! { 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.
+!
+! Subroutine 'h' and calls to it were introduced to check the corrections
+! needed to fix additional problems, noted in the review of the patch by
+! Harald Anlauf
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+module orig
+ character(:), allocatable :: c
+ integer :: ans(3,3)
+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
+ function h(n) result(z)
+ integer, intent(in) :: n
+ character(2), parameter :: c(3,3) = &
+ reshape (['ab','c ','de','f ','gh','i ','jk','l ','mn'],[3,3])
+ character(len_trim(c(n,n))) :: z
+ z = c(n,n)
+ ans = len_trim (c)
+ 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
+
+ if (h(2) .ne. 'gh') stop 6
+ if (any (ans .ne. reshape ([2,1,2,1,2,1,2,1,2],[3,3]))) stop 7
+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
