===================================================================
*************** is_subref_array (gfc_expr * e)
for (ref = e->ref; ref; ref = ref->next)
{
/* If we haven't seen the array reference and this is an intrinsic,
! what follows cannot be a subreference array. */
if (!seen_array && ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type != BT_CLASS
&& !gfc_bt_struct (ref->u.c.component->ts.type))
return false;
for (ref = e->ref; ref; ref = ref->next)
{
/* If we haven't seen the array reference and this is an intrinsic,
! what follows cannot be a subreference array, unless there is a
! substring reference. */
if (!seen_array && ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type != BT_CHARACTER
&& ref->u.c.component->ts.type != BT_CLASS
&& !gfc_bt_struct (ref->u.c.component->ts.type))
return false;
===================================================================
*************** get_array_ctor_var_strlen (stmtblock_t *
{
case REF_ARRAY:
/* Array references don't change the string length. */
+ if (ts->deferred)
+ get_array_ctor_all_strlen (block, expr, len);
break;
case REF_COMPONENT:
*************** get_array_ctor_var_strlen (stmtblock_t *
break;
case REF_SUBSTRING:
! if (ref->u.ss.start->expr_type != EXPR_CONSTANT
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
{
/* Note that this might evaluate expr. */
break;
case REF_SUBSTRING:
! if (ref->u.ss.end == NULL
! || ref->u.ss.start->expr_type != EXPR_CONSTANT
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
{
/* Note that this might evaluate expr. */
*************** trans_array_constructor (gfc_ss * ss, lo
ss_info->string_length);
ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
&length_se.pre);
-
gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
gfc_add_block_to_block (&outer_loop->post, &length_se.post);
}
*************** gfc_conv_scalarized_array_ref (gfc_se *
|| expr->expr_type == EXPR_FUNCTION))))
decl = expr->symtree->n.sym->backend_decl;
+ if (decl && GFC_DECL_PTR_ARRAY_P (decl))
+ goto done;
+
/* A pointer array component can be detected from its field decl. Fix
the descriptor, mark the resulting variable decl and pass it to
gfc_build_array_ref. */
*************** gfc_conv_scalarized_array_ref (gfc_se *
decl = info->descriptor;
}
+ done:
se->expr = gfc_build_array_ref (base, index, decl);
}
*************** get_array_charlen (gfc_expr *expr, gfc_s
gfc_formal_arglist *formal;
gfc_actual_arglist *arg;
gfc_se tse;
+ gfc_expr *e;
if (expr->ts.u.cl->length
&& gfc_is_constant_expr (expr->ts.u.cl->length))
*************** get_array_charlen (gfc_expr *expr, gfc_s
switch (expr->expr_type)
{
+ case EXPR_ARRAY:
+
+ /* This is somewhat brutal. The expression for the first
+ element of the array is evaluated and assigned to a
+ new string length for the original expression. */
+ e = gfc_constructor_first (expr->value.constructor)->expr;
+
+ gfc_init_se (&tse, NULL);
+ if (e->rank)
+ gfc_conv_expr_descriptor (&tse, e);
+ else
+ gfc_conv_expr (&tse, e);
+
+ gfc_add_block_to_block (&se->pre, &tse.pre);
+ gfc_add_block_to_block (&se->post, &tse.post);
+
+ if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
+ {
+ expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ expr->ts.u.cl->backend_decl =
+ gfc_create_var (gfc_charlen_type_node, "sln");
+ }
+
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+ tse.string_length);
+
+ return;
+
case EXPR_OP:
get_array_charlen (expr->value.op.op1, se);
*************** get_array_charlen (gfc_expr *expr, gfc_s
if (expr->value.op.op == INTRINSIC_PARENTHESES)
return;
! expr->ts.u.cl->backend_decl =
gfc_create_var (gfc_charlen_type_node, "sln");
if (expr->value.op.op2)
if (expr->value.op.op == INTRINSIC_PARENTHESES)
return;
! expr->ts.u.cl->backend_decl =
gfc_create_var (gfc_charlen_type_node, "sln");
if (expr->value.op.op2)
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
if (need_tmp)
{
! if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
get_array_charlen (expr, se);
/* Tell the scalarizer to make a temporary. */
if (need_tmp)
{
! if (expr->ts.type == BT_CHARACTER
! && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
get_array_charlen (expr, se);
/* Tell the scalarizer to make a temporary. */
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
/* Set the string_length for a character array. */
if (expr->ts.type == BT_CHARACTER)
! se->string_length = gfc_get_expr_charlen (expr);
/* If we have an array section or are assigning make sure that
the lower bound is 1. References to the full
/* Set the string_length for a character array. */
if (expr->ts.type == BT_CHARACTER)
! {
! se->string_length = gfc_get_expr_charlen (expr);
! if (VAR_P (se->string_length)
! && expr->ts.u.cl->backend_decl == se->string_length)
! tmp = ss_info->string_length;
! else
! tmp = se->string_length;
!
! if (expr->ts.deferred)
! gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
! }
/* If we have an array section or are assigning make sure that
the lower bound is 1. References to the full
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
}
/* Set the span field. */
! tmp = gfc_get_array_span (desc, expr);
if (tmp != NULL_TREE)
gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
}
/* Set the span field. */
! if (expr->ts.type == BT_CHARACTER && ss_info->string_length)
! tmp = ss_info->string_length;
! else
! tmp = gfc_get_array_span (desc, expr);
if (tmp != NULL_TREE)
gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
===================================================================
*************** gfc_get_expr_charlen (gfc_expr *e)
{
gfc_ref *r;
tree length;
+ gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
*************** gfc_get_expr_charlen (gfc_expr *e)
/* Do nothing. */
break;
default:
- /* We should never got substring references here. These will be
- broken down by the scalarizer. */
gcc_unreachable ();
break;
}
/* Do nothing. */
break;
+ case REF_SUBSTRING:
+ 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);
+ length = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_charlen_type_node,
+ se.expr, length);
+ length = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_charlen_type_node, length,
+ gfc_index_one_node);
+ break;
+
default:
gcc_unreachable ();
break;
}
===================================================================
*************** trans_associate_var (gfc_symbol *sym, gf
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
if (sym->assoc->variable || cst_array_ctor)
{
se.direct_byref = 1;
se.use_offset = 1;
se.expr = desc;
}
gfc_conv_expr_descriptor (&se, e);
if (sym->ts.type == BT_CHARACTER
! && sym->ts.deferred
&& !sym->attr.select_type_temporary
&& VAR_P (sym->ts.u.cl->backend_decl)
&& se.string_length != sym->ts.u.cl->backend_decl)
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
+
if (sym->assoc->variable || cst_array_ctor)
{
se.direct_byref = 1;
se.use_offset = 1;
se.expr = desc;
+ GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
}
gfc_conv_expr_descriptor (&se, e);
if (sym->ts.type == BT_CHARACTER
! && !se.direct_byref && sym->ts.deferred
&& !sym->attr.select_type_temporary
&& VAR_P (sym->ts.u.cl->backend_decl)
&& se.string_length != sym->ts.u.cl->backend_decl)
*************** trans_associate_var (gfc_symbol *sym, gf
/* If this is a subreference array pointer associate name use the
associate variable element size for the value of 'span'. */
! if (sym->attr.subref_array_pointer)
{
gcc_assert (e->expr_type == EXPR_VARIABLE);
tmp = gfc_get_array_span (se.expr, e);
/* If this is a subreference array pointer associate name use the
associate variable element size for the value of 'span'. */
! if (sym->attr.subref_array_pointer && !se.direct_byref)
{
gcc_assert (e->expr_type == EXPR_VARIABLE);
tmp = gfc_get_array_span (se.expr, e);
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR88247 and more besides :-)
+ !
+ ! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+ !
+ program p
+ type t
+ character(:), allocatable :: c
+ character(:), dimension(:), allocatable :: d
+ end type
+ type(t), allocatable :: x
+
+ call foo ('abcdef','ghijkl')
+ associate (y => [x%c(:)])
+ if (y(1) .ne. 'abcdef') stop 1
+ end associate
+
+ call foo ('ghi','ghi')
+ associate (y => [x%c(2:)])
+ if (y(1) .ne. 'hi') stop 2
+ end associate
+
+ call foo ('lmnopq','ghijkl')
+ associate (y => [x%c(:3)])
+ if (y(1) .ne. 'lmn') stop 3
+ end associate
+
+ call foo ('abcdef','ghijkl')
+ associate (y => [x%c(2:4)])
+ if (y(1) .ne. 'bcd') stop 4
+ end associate
+
+ call foo ('lmnopqrst','ghijklmno')
+ associate (y => x%d(:))
+ if (len(y) .ne. 9) stop 5
+ if (any (y .ne. ['lmnopqrst','ghijklmno'])) stop 5
+ y(1) = 'zqrtyd'
+ end associate
+ if (x%d(1) .ne. 'zqrtyd') stop 5
+
+ ! Substrings of arrays still do not work correctly.
+ call foo ('lmnopqrst','ghijklmno')
+ associate (y => x%d(:)(2:4))
+ ! if (any (y .ne. ['mno','hij'])) stop 6
+ end associate
+
+ call foo ('abcdef','ghijkl')
+ associate (y => [x%d(:)])
+ if (len(y) .ne. 6) stop 7
+ if (any (y .ne. ['abcdef','ghijkl'])) stop 7
+ end associate
+
+ call foo ('lmnopqrst','ghijklmno')
+ associate (y => [x%d(2:1:-1)])
+ if (len(y) .ne. 9) stop 8
+ if (any (y .ne. ['ghijklmno','lmnopqrst'])) stop 8
+ end associate
+
+ deallocate (x)
+ contains
+ subroutine foo (c1, c2)
+ character(*) :: c1, c2
+ if (allocated (x)) deallocate (x)
+ allocate (x)
+ x%c = c1
+ x%d = [c1, c2]
+ end subroutine foo
+ end