mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].

Browse Source 
2024-07-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/84868
	* simplify.cc (gfc_simplify_len_trim): If the argument is an
	element of a parameter array, simplify all the elements and
	build a new parameter array to hold the result, after checking
	that it doesn't already exist.
	* trans-expr.cc (gfc_get_interface_mapping_array) if a string
	length is available, use it for the typespec.
	(gfc_add_interface_mapping): Supply the se string length.

gcc/testsuite/
	PR fortran/84868
	* gfortran.dg/pr84868.f90: New test.
This commit is contained in:
Paul Thomas 2024-07-16 15:56:44 +01:00
parent fec38d7987
commit 9f966b6a8f
3 changed files with 171 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
gcc/fortran/simplify.cc
View File

@ -4637,6 +4637,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
/* If the expression is either an array element or section, an array
parameter must be built so that the reference can be applied. Constant
references should have already been simplified away. All other cases
can proceed to translation, where kind conversion will occur silently. */
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.type != AR_FULL
&& e->symtree->n.sym->value)
{
char name[2*GFC_MAX_SYMBOL_LEN + 12];
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++;
gfc_commit_symbol (st->n.sym);
already_built:
/* Build a return expression. */
expr = gfc_copy_expr (e);
expr->ts = st->n.sym->ts;
expr->symtree = st;
gfc_expression_rank (expr);
return expr;
}
clean_up:
gfc_free_expr (expr);
return NULL;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;

18
gcc/fortran/trans-expr.cc
View File

@ -4474,12 +4474,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);
@ -4626,7 +4629,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,
@ -4645,7 +4649,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. */
@ -4659,7 +4663,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);
@ -4667,7 +4672,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;
}

84
gcc/testsuite/gfortran.dg/pr84868.f90 Normal file
View File

@ -0,0 +1,84 @@
! { 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 <gscfq@t-online.de>
!
module orig
character(:), allocatable :: c
integer :: ans1(3,3), ans2(3), ans3(2)
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(4), parameter :: chr(3) = ['ab ',' cd','e f ']
character(len_trim(c(n,n))) :: z
z = c(n,n)
! Make sure that full arrays are correctly scalarized both having been previously
! used with an array reference and not previously referenced.
ans1 = len_trim (c)
ans2 = len_trim (chr)
! Finally check a slightly more complicated array reference
ans3 = len_trim (c(1:n+1:2,n-1))
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 (ans1 .ne. reshape ([2,1,2,1,2,1,2,1,2],[3,3]))) stop 7
if (any (ans2 .ne. [2,4,3])) stop 8
if (any (ans3 .ne. [2,2])) stop 9
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