[fortran] PR88247 - [8/9 Regression] ICE in get_array_ctor_var_strlen, at fortran/trans-array.c:2068

Message ID CAGkQGiLJPpcWtSW3E7r0iUhAXMVBtAv625p5GcQFZDioeRj3BQ@mail.gmail.com
State New
Headers show
Series
  • [fortran] PR88247 - [8/9 Regression] ICE in get_array_ctor_var_strlen, at fortran/trans-array.c:2068
Related show

Commit Message

Paul Richard Thomas March 24, 2019, 4:34 p.m.
This one started with a simple enough testscase and then evolved as I
found out how little actually worked. All the changes in the patch
involve gathering up the string length by hook or by crook.

It will be noted that associate (y => x%d(:)(2:4)) still does not work
correctly. The associate name is correctly formed with the right
values of element length and span. However, it is unusable because the
array indexing uses the element length as the span. I did not want to
touch array indexing at this stage of 9-branch.

Bootstraps and regtests on FC29/x86_64 - OK for 8- and 9-branches?

Paul

2019-03-24  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/88247
    * expr.c (is_subref_array): Permit substrings to be detected
    as subref arrays.
    * trans-array.c (get_array_ctor_var_strlen): Obtain the length
    of deferred length strings. Handle substrings with a NULL end
    expression.
    (trans_array_constructor): Remove an unnecessary blank line.
    (gfc_conv_scalarized_array_ref): Skip to label 'done' if 'decl'
    is a pointer array.
    (get_array_charlen): If the expression is an array, convert the
    first element of the constructor and use its string length. Get
    a new charlen if necessary.
    (gfc_conv_expr_descriptor): Call 'get_array_charlen' for array
    constructor expressions. If the ss_info string length is
    available, use that to set the span of character arrays.
    * trans-expr.c (gfc_get_expr_charlen): Handle substrings
    * trans-stmt.c (trans_associate_var): Set the pointer array
    flag for variable targets and constant array constructors. Take
    care not to reset the string length or the span in the case of
    expressions that are not converted as direct by reference.

2019-03-24  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/88247
    * gfortran.dg/associate_47.f90: New test.

Comments

Thomas Koenig March 26, 2019, 8:02 p.m. | #1
Hi Paul,

> Bootstraps and regtests on FC29/x86_64 - OK for 8- and 9-branches?


OK. Thanks for the patch!

Regards

	Thomas

Patch

Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 269611)
--- gcc/fortran/expr.c	(working copy)
*************** is_subref_array (gfc_expr * e)
*** 1077,1084 ****
    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;
--- 1077,1086 ----
    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;
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 269611)
--- gcc/fortran/trans-array.c	(working copy)
*************** get_array_ctor_var_strlen (stmtblock_t *
*** 2099,2104 ****
--- 2099,2106 ----
  	{
  	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 *
*** 2107,2113 ****
  	  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.  */
--- 2109,2116 ----
  	  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
*** 2507,2513 ****
  			       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);
  	}
--- 2510,2515 ----
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3470,3475 ****
--- 3472,3480 ----
  					 || 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 *
*** 3486,3491 ****
--- 3491,3497 ----
  	decl = info->descriptor;
      }

+ done:
    se->expr = gfc_build_array_ref (base, index, decl);
  }

*************** get_array_charlen (gfc_expr *expr, gfc_s
*** 6929,6934 ****
--- 6935,6941 ----
    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
*** 6940,6945 ****
--- 6947,6980 ----

    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
*** 6947,6953 ****
        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)
--- 6982,6988 ----
        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
*** 7325,7331 ****

    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.  */
--- 7360,7367 ----

    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
*** 7447,7453 ****

        /* 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
--- 7483,7499 ----

        /* 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
*** 7509,7515 ****
  	}

        /* Set the span field.  */
!       tmp = gfc_get_array_span (desc, expr);
        if (tmp != NULL_TREE)
  	gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);

--- 7555,7564 ----
  	}

        /* 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);

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 269612)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 1824,1829 ****
--- 1824,1830 ----
  {
    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)
*** 1859,1867 ****
  	  /* Do nothing.  */
  	  break;

  	default:
- 	  /* We should never got substring references here.  These will be
- 	     broken down by the scalarizer.  */
  	  gcc_unreachable ();
  	  break;
  	}
--- 1860,1879 ----
  	  /* 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;
  	}
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 269611)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1707,1723 ****
        /* 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)
--- 1707,1725 ----
        /* 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
*** 1746,1752 ****

        /* 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);
--- 1748,1754 ----

        /* 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);
Index: gcc/testsuite/gfortran.dg/associate_47.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_47.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/associate_47.f90	(working copy)
***************
*** 0 ****
--- 1,69 ----
+ ! { 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