re PR fortran/85603 (ICE with character array substring assignment)

2018-10-23  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-23  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.

From-SVN: r265412

gcc/fortran/ChangeLog

+2018-10-23  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-21  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/71880

gcc/fortran/frontend-passes.c

@@ -704,6 +704,41 @@ insert_block ()
   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
@@ -786,6 +821,10 @@ create_var (gfc_expr * e, const char *vname)
       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;
@@ -2019,6 +2058,7 @@ get_len_trim_call (gfc_expr *str, int kind)
   return fcn;
 }
 
+
 /* Optimize expressions for equality.  */
 
 static bool

gcc/testsuite/ChangeLog

+2018-10-23  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.
+
 2018-10-22  Yury Gribov  <tetra2005@gmail.com>
 
 	PR tree-optimization/87633

gcc/testsuite/gfortran.dg/deferred_character_23.f90

@@ -3,6 +3,29 @@
 ! 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
@@ -15,8 +38,31 @@ program strlen_bug
       '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
+
+! 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