Re: [Patc, fortran] PR85603 - ICE with character array substring assignment

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2609 bytes --]

Hmmm! It helps to provide the patch.

2018-10-18  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/85603
    * frontend-passes.c (get_len_call): New function to generate a
    call to intrinsic LEN.
    (create_var): Use this to make length expressions for variable
    rhs string lengths.
    Clean up some white space issues.

2018-10-18  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/85603
    * gfortran.dg/deferred_character_23.f90 : Check reallocation is
    occurring as it should and a regression caused by version 1 of
    this patch.

On Sat, 20 Oct 2018 at 13:32, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
>
> Hi Dominique,
>
> Thanks for picking that up. For some reason that I do now see, the
> regression is caused by the component references. The frontend
> temporary is picking up the deferred tag from somewhere, even though
> it is not set. Anyway, all is well if the patch is restricted to
> character right hand side symbols. I have added a test for the
> regression to the testcase.
>
> OK for trunk?
>
> Paul
>
> On Fri, 19 Oct 2018 at 23:15, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> >
> > Reduced test
> >
> > ! { dg-do compile }
> > MODULE TN4
> >   IMPLICIT NONE
> >   PRIVATE
> >   INTEGER,PARAMETER::SH4=KIND('a')
> >   TYPE,PUBLIC::TOP
> >     CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
> >     CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
> >   CONTAINS
> >     PROCEDURE,NON_OVERRIDABLE::SB=>TPX
> >   END TYPE TOP
> > CONTAINS
> >   SUBROUTINE TPX(TP6,PP4,BA3)
> >     CLASS(TOP),INTENT(INOUT)::TP6
> >     INTEGER,INTENT(IN)::PP4
> >     TYPE(TOP),INTENT(OUT)::BA3
> >     BA3%ROR=TP6%ROR(PP4:)
> >     BA3%VI8=TP6%ROR(PP4:)
> >     TP6%ROR=TP6%ROR(:PP4-1)
> >     TP6%VI8=TP6%ROR(:PP4-1)
> >   END SUBROUTINE TPX
> > END MODULE TN4
> > ! https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
> >
> > TIA
> >
> > Dominique
> >
> > > Le 19 oct. 2018 à 23:39, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
> > >
> > > Hi Paul,
> > >
> > > I get a regression with your patch:
> > >
> > > obfuscated_tn4.f90:300:0:
> > >
> > >  300 |     TP6%ROR=TP6%ROR(:PP4-1)
> > >      |
> > > internal compiler error: in gfc_trans_deferred_vars, at fortran/trans-decl.c:4754
> > >
> > >
> > > I’ll try to reduce the test.
> > >
> > > Dominique
> > >
> >
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein



-- 
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein

[-- Attachment #2: resubmit.diff --]
[-- Type: text/x-patch, Size: 11442 bytes --]

Index: gcc/fortran/frontend-passes.c
===================================================================
*** gcc/fortran/frontend-passes.c	(revision 265262)
--- gcc/fortran/frontend-passes.c	(working copy)
*************** realloc_string_callback (gfc_code **c, i
*** 280,286 ****
  	   && (expr2->expr_type != EXPR_OP
  	       || expr2->value.op.op != INTRINSIC_CONCAT))
      return 0;
!   
    if (!gfc_check_dependency (expr1, expr2, true))
      return 0;
  
--- 280,286 ----
  	   && (expr2->expr_type != EXPR_OP
  	       || expr2->value.op.op != INTRINSIC_CONCAT))
      return 0;
! 
    if (!gfc_check_dependency (expr1, expr2, true))
      return 0;
  
*************** insert_block ()
*** 704,709 ****
--- 704,744 ----
    return ns;
  }
  
+ 
+ /* Insert a call to the intrinsic len. Use a different name for
+    the symbol tree so we don't run into trouble when the user has
+    renamed len for some reason.  */
+ 
+ static gfc_expr*
+ get_len_call (gfc_expr *str)
+ {
+   gfc_expr *fcn;
+   gfc_actual_arglist *actual_arglist;
+ 
+   fcn = gfc_get_expr ();
+   fcn->expr_type = EXPR_FUNCTION;
+   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
+   actual_arglist = gfc_get_actual_arglist ();
+   actual_arglist->expr = str;
+ 
+   fcn->value.function.actual = actual_arglist;
+   fcn->where = str->where;
+   fcn->ts.type = BT_INTEGER;
+   fcn->ts.kind = gfc_charlen_int_kind;
+ 
+   gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
+   fcn->symtree->n.sym->ts = fcn->ts;
+   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+   fcn->symtree->n.sym->attr.function = 1;
+   fcn->symtree->n.sym->attr.elemental = 1;
+   fcn->symtree->n.sym->attr.referenced = 1;
+   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+   gfc_commit_symbol (fcn->symtree->n.sym);
+ 
+   return fcn;
+ }
+ 
+ 
  /* Returns a new expression (a variable) to be used in place of the old one,
     with an optional assignment statement before the current statement to set
     the value of the variable. Creates a new BLOCK for the statement if that
*************** create_var (gfc_expr * e, const char *vn
*** 786,791 ****
--- 821,830 ----
        length = constant_string_length (e);
        if (length)
  	symbol->ts.u.cl->length = length;
+       else if (e->expr_type == EXPR_VARIABLE
+ 	       && e->symtree->n.sym->ts.type == BT_CHARACTER
+ 	       && e->ts.u.cl->length)
+ 	symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
        else
  	{
  	  symbol->attr.allocatable = 1;
*************** traverse_io_block (gfc_code *code, bool
*** 1226,1232 ****
  	    {
  	      /* Check for (a(i,i), i=1,3).  */
  	      int j;
! 	      
  	      for (j=0; j<i; j++)
  		if (iters[j] && iters[j]->var->symtree == start->symtree)
  		  return false;
--- 1265,1271 ----
  	    {
  	      /* Check for (a(i,i), i=1,3).  */
  	      int j;
! 
  	      for (j=0; j<i; j++)
  		if (iters[j] && iters[j]->var->symtree == start->symtree)
  		  return false;
*************** traverse_io_block (gfc_code *code, bool
*** 1286,1292 ****
  		      || var_in_expr (var, iters[j]->end)
  		      || var_in_expr (var, iters[j]->step)))
  		  return false;
! 	    }		  
  	}
      }
  
--- 1325,1331 ----
  		      || var_in_expr (var, iters[j]->end)
  		      || var_in_expr (var, iters[j]->step)))
  		  return false;
! 	    }
  	}
      }
  
*************** get_len_trim_call (gfc_expr *str, int ki
*** 2019,2024 ****
--- 2058,2064 ----
    return fcn;
  }
  
+ 
  /* Optimize expressions for equality.  */
  
  static bool
*************** do_subscript (gfc_expr **e)
*** 2626,2632 ****
  
  	      /* If we do not know about the stepsize, the loop may be zero trip.
  		 Do not warn in this case.  */
! 	  
  	      if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
  		mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
  	      else
--- 2666,2672 ----
  
  	      /* If we do not know about the stepsize, the loop may be zero trip.
  		 Do not warn in this case.  */
! 
  	      if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
  		mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
  	      else
*************** do_subscript (gfc_expr **e)
*** 2640,2646 ****
  	      else
  		have_do_start = false;
  
! 	  
  	      if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
  		{
  		  have_do_end = true;
--- 2680,2686 ----
  	      else
  		have_do_start = false;
  
! 
  	      if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
  		{
  		  have_do_end = true;
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2806,2812 ****
  {
    gfc_expr *e, *n;
    bool *found = (bool *) data;
!   
    e = *ep;
  
    if (e->expr_type != EXPR_FUNCTION
--- 2846,2852 ----
  {
    gfc_expr *e, *n;
    bool *found = (bool *) data;
! 
    e = *ep;
  
    if (e->expr_type != EXPR_FUNCTION
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2819,2837 ****
      return 0;
  
    /* Check if this is already in the form c = matmul(a,b).  */
!   
    if ((*current_code)->expr2 == e)
      return 0;
  
    n = create_var (e, "matmul");
!   
    /* If create_var is unable to create a variable (for example if
       -fno-realloc-lhs is in force with a variable that does not have bounds
       known at compile-time), just return.  */
  
    if (n == NULL)
      return 0;
!   
    *ep = n;
    *found = true;
    return 0;
--- 2859,2877 ----
      return 0;
  
    /* Check if this is already in the form c = matmul(a,b).  */
! 
    if ((*current_code)->expr2 == e)
      return 0;
  
    n = create_var (e, "matmul");
! 
    /* If create_var is unable to create a variable (for example if
       -fno-realloc-lhs is in force with a variable that does not have bounds
       known at compile-time), just return.  */
  
    if (n == NULL)
      return 0;
! 
    *ep = n;
    *found = true;
    return 0;
*************** matmul_to_var_code (gfc_code **c, int *w
*** 2850,2856 ****
        inserted_block = NULL;
        changed_statement = NULL;
      }
!   
    return 0;
  }
  
--- 2890,2896 ----
        inserted_block = NULL;
        changed_statement = NULL;
      }
! 
    return 0;
  }
  
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2870,2876 ****
    bool a_tmp, b_tmp;
    gfc_expr *matrix_a, *matrix_b;
    bool conjg_a, conjg_b, transpose_a, transpose_b;
!   
    co = *c;
  
    if (co->op != EXEC_ASSIGN)
--- 2910,2916 ----
    bool a_tmp, b_tmp;
    gfc_expr *matrix_a, *matrix_b;
    bool conjg_a, conjg_b, transpose_a, transpose_b;
! 
    co = *c;
  
    if (co->op != EXEC_ASSIGN)
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2920,2926 ****
  
    if (!a_tmp && !b_tmp)
      return 0;
!   
    current_code = c;
    inserted_block = NULL;
    changed_statement = NULL;
--- 2960,2966 ----
  
    if (!a_tmp && !b_tmp)
      return 0;
! 
    current_code = c;
    inserted_block = NULL;
    changed_statement = NULL;
*************** scalarized_expr (gfc_expr *e_in, gfc_exp
*** 3648,3654 ****
  		      /* For assumed size, we need to keep around the final
  			 reference in order not to get an error on resolution
  			 below, and we cannot use AR_FULL.  */
! 			 
  		      if (ar->as->type == AS_ASSUMED_SIZE)
  			{
  			  ar->type = AR_SECTION;
--- 3688,3694 ----
  		      /* For assumed size, we need to keep around the final
  			 reference in order not to get an error on resolution
  			 below, and we cannot use AR_FULL.  */
! 
  		      if (ar->as->type == AS_ASSUMED_SIZE)
  			{
  			  ar->type = AR_SECTION;
*************** call_external_blas (gfc_code **c, int *w
*** 4604,4610 ****
  	default:
  	  gcc_unreachable ();
  	}
!     }    
  
    /* Handle the reallocation, if needed.  */
  
--- 4644,4650 ----
  	default:
  	  gcc_unreachable ();
  	}
!     }
  
    /* Handle the reallocation, if needed.  */
  
*************** typedef struct {
*** 4756,4762 ****
    int n[GFC_MAX_DIMENSIONS];
  } ind_type;
  
! /* Callback function to determine if an expression is the 
     corresponding variable.  */
  
  static int
--- 4796,4802 ----
    int n[GFC_MAX_DIMENSIONS];
  } ind_type;
  
! /* Callback function to determine if an expression is the
     corresponding variable.  */
  
  static int
*************** index_interchange (gfc_code **c, int *wa
*** 4842,4848 ****
    gfc_forall_iterator *fa;
    ind_type *ind;
    int i, j;
!   
    if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
      return 0;
  
--- 4882,4888 ----
    gfc_forall_iterator *fa;
    ind_type *ind;
    int i, j;
! 
    if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
      return 0;
  
*************** gfc_code_walker (gfc_code **c, walk_code
*** 5358,5364 ****
  
  	  if (co->op == EXEC_SELECT)
  	    select_level --;
!   
  	  in_omp_workshare = saved_in_omp_workshare;
  	  in_where = saved_in_where;
  	}
--- 5398,5404 ----
  
  	  if (co->op == EXEC_SELECT)
  	    select_level --;
! 
  	  in_omp_workshare = saved_in_omp_workshare;
  	  in_where = saved_in_where;
  	}
Index: gcc/testsuite/gfortran.dg/deferred_character_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_23.f90	(revision 265262)
--- gcc/testsuite/gfortran.dg/deferred_character_23.f90	(working copy)
***************
*** 3,8 ****
--- 3,31 ----
  ! Tests the fix for PR85603.
  !
  ! Contributed by Walt Spector  <w6ws@earthlink.net>
+ !_____________________________________________
+ ! Module for a test against a regression that occurred with
+ ! the first patch for this PR.
+ !
+ MODULE TN4
+   IMPLICIT NONE
+   PRIVATE
+   INTEGER,PARAMETER::SH4=KIND('a')
+   TYPE,PUBLIC::TOP
+     CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
+     CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
+   CONTAINS
+     PROCEDURE,NON_OVERRIDABLE::SB=>TPX
+   END TYPE TOP
+ CONTAINS
+   SUBROUTINE TPX(TP6,PP4)
+     CLASS(TOP),INTENT(INOUT)::TP6
+     INTEGER,INTENT(IN)::PP4
+     TP6%ROR=TP6%ROR(:PP4-1)
+     TP6%VI8=TP6%ROR(:PP4-1)
+   END SUBROUTINE TPX
+ END MODULE TN4
+ !_____________________________________________
  !
  program strlen_bug
    implicit none
*************** program strlen_bug
*** 15,22 ****
        'somewhat longer' ]
    maxlen = maxval (len_trim (strings))
    if (maxlen .ne. 15) stop 1
!   strings = strings(:)(:maxlen) ! Used to ICE
!   if (any (strings .ne. ['short          ','somewhat longer'])) stop 2
  
    deallocate (strings)          ! To check for memory leaks
  end program
--- 38,68 ----
        'somewhat longer' ]
    maxlen = maxval (len_trim (strings))
    if (maxlen .ne. 15) stop 1
! 
! ! Used to cause an ICE and in the later version of the problem did not reallocate.
!   strings = strings(:)(:maxlen)
!   if (any (strings .ne. ['short          ','somewhat longer' ])) stop 2
!   if (len (strings) .ne. maxlen) stop 3
! 
! ! Try something a bit more complicated.
!   strings = strings(:)(2:maxlen - 5)
!   if (any (strings .ne. ['hort     ','omewhat l' ])) stop 4
!   if (len (strings) .ne. maxlen - 6) stop 5
  
    deallocate (strings)          ! To check for memory leaks
+ 
+ ! Test the regression, noted by Dominique d'Humieres is fixed.
+ ! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
+ !
+   call foo
+ contains
+   subroutine foo
+     USE TN4
+     TYPE(TOP) :: Z
+ 
+     Z%ROR = 'abcd'
+     call Z%SB (3)
+     if (Z%VI8 .ne. 'ab') stop 6
+ end
+ 
  end program