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

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

[Paul Richard Thomas]

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

Yet another 'obvious' deferred character fix. Committed to trunk as
r264502. Will backport in about ten days time.

Paul

2018-09-22  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/85603
    * trans-array.c (gfc_alloc_allocatable_for_assignment): Test
    the charlen backend_decl before using the VAR_P macro.

2018-09-22  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/85603
    * gfortran.dg/deferred_character_23.f90 : New test.

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

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 264486)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9950,9956 ****
      {
        if (expr2->ts.deferred)
  	{
! 	  if (VAR_P (expr2->ts.u.cl->backend_decl))
  	    tmp = expr2->ts.u.cl->backend_decl;
  	  else
  	    tmp = rss->info->string_length;
--- 9950,9957 ----
      {
        if (expr2->ts.deferred)
  	{
! 	  if (expr2->ts.u.cl->backend_decl
! 	      && VAR_P (expr2->ts.u.cl->backend_decl))
  	    tmp = expr2->ts.u.cl->backend_decl;
  	  else
  	    tmp = rss->info->string_length;
Index: gcc/testsuite/gfortran.dg/deferred_character_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_23.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_character_23.f90	(working copy)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR85603.
+ !
+ ! Contributed by Walt Spector  <w6ws@earthlink.net>
+ !
+ program strlen_bug
+   implicit none
+ 
+   character(:), allocatable :: strings(:)
+   integer :: maxlen
+ 
+   strings = [ character(32) ::  &
+       'short',  &
+       '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

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

[Paul Richard Thomas]

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

It turned out that this patch did not quite complete the job (Thanks
Walt): The ICE has gone but reallocation on assignment is not
occurring because the correct string length for the rhs expression was
not being picked up. The fix for this took rather more detective work
than I anticipated but here it is.

Bootstraps and regtests on FC28/x86_64 - OK for trunk?

Cheers

Paul

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..

On Sat, 22 Sep 2018 at 11:23, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
>
> Yet another 'obvious' deferred character fix. Committed to trunk as
> r264502. Will backport in about ten days time.
>
> Paul
>
> 2018-09-22  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/85603
>     * trans-array.c (gfc_alloc_allocatable_for_assignment): Test
>     the charlen backend_decl before using the VAR_P macro.
>
> 2018-09-22  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/85603
>     * gfortran.dg/deferred_character_23.f90 : New test.



-- 
"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: 10212 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,828 ----
        length = constant_string_length (e);
        if (length)
  	symbol->ts.u.cl->length = length;
+       else if (e->expr_type == EXPR_VARIABLE && 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;
--- 1263,1269 ----
  	    {
  	      /* 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;
! 	    }		  
  	}
      }
  
--- 1323,1329 ----
  		      || 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 ****
--- 2056,2062 ----
    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
--- 2664,2670 ----
  
  	      /* 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;
--- 2678,2684 ----
  	      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
--- 2844,2850 ----
  {
    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;
--- 2857,2875 ----
      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;
  }
  
--- 2888,2894 ----
        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)
--- 2908,2914 ----
    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;
--- 2958,2964 ----
  
    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;
--- 3686,3692 ----
  		      /* 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.  */
  
--- 4642,4648 ----
  	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
--- 4794,4800 ----
    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;
  
--- 4880,4886 ----
    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;
  	}
--- 5396,5402 ----
  
  	  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)
*************** 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
--- 15,30 ----
        '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
  end program

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

[Dominique d'Humières]

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

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

[Dominique d'Humières]

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
> 

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

[Paul Richard Thomas]

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

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

[Paul Richard Thomas]

[-- 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

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

[Thomas Koenig]

Hi Paul,

> 
> 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.

OK.

Thanks for the patch!

Regards

	Thomas