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;
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);
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,
/* 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. */
/* 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);
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;
}
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
